田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



PKPM 转到CAD中的字体修改 vba 局部放大程序 快速绘制详图
未知 AutoCAD vba 合并文字   [ 日期:2007-05-18 ]   [ 来自:本站原创 ]  HTML
单行文字合并

我们常常遇到很多文字被分成一块一块的,比如天正的炸开后中文字符和英文字符是分开的,用这个就方便多了。


Sub HBWZ_Text()
    Dim objSelected As Object
    Dim acText  As AcadText
    Dim ssText As AcadSelectionSet
    Dim AllText As String
    Dim H As Double
    Dim P As Variant
    On Error Resume Next
    Set ssText = ThisDrawing.SelectionSets.Add("Text")
    '定义过滤机制
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "TEXT"
    
    ssText.SelectOnScreen FilterType, FilterData
    Set acText = ssText.item(0)
    H = acText.height
    P = acText.insertionPoint
    
    '对选择集中的文字对象进行操作
    For Each objSelected In ssText
        If TypeOf objSelected Is AcadText Then
            Set acText = objSelected
            
            AllText = AllText & acText.textString
            acText.Delete
        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("Text").Delete
        End If
    Next
    ThisDrawing.ModelSpace.AddText AllText, P, H
    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update
    
End Sub


多行文字合并


多行文字的优点就是便于编辑,其功能不亚于word,我们常常要把很多单行文字合并成多行文字。


Sub HBWZ_MText()
    Dim objSelected As Object
    Dim acText  As AcadText
    Dim ssText As AcadSelectionSet
    Dim AllText As String
    Dim Mtxt As AcadMText
    Dim H As Double
    Dim P As Variant
    On Error Resume Next
    Set ssText = ThisDrawing.SelectionSets.Add("Text")
    '定义过滤机制
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "TEXT"
    
    ssText.SelectOnScreen FilterType, FilterData
    Set acText = ssText.item(0)
    H = acText.height
    P = acText.insertionPoint
    
    '对选择集中的文字对象进行操作
    For Each objSelected In ssText
        If TypeOf objSelected Is AcadText Then
            Set acText = objSelected
            
            AllText = AllText & acText.textString
            acText.Delete
        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("Text").Delete
        End If
    Next
    Dim W As Double
    W = ThisDrawing.Utility.GetDistance(, "多行文本框的宽度:")
      '错误检查
    If Err.Number = -2147352567 Then                                    '用户按下Esc键,则退出.(错误代码可以通过MsgBox提示获得)
        Err.Clear
        Exit Sub
    ElseIf Err Then                                                     '如果用户按下 enter 按钮或者输入有误,行距使用默认文字行距
        W = ThisDrawing.width
        Err.Clear
    End If
    Set Mtxt = ThisDrawing.ModelSpace.AddMText(P, W, AllText)
    Mtxt.height = 300
    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update
    
End Sub


[本日志由 田草 于 2008-08-12 01:49 PM 编辑]


引用这个评论 田草 于 2008-08-12 01:50 PM 发表评论: 
' 单行文字文字合并 *************************************************
Sub HBWZ_Text()
    Dim objSelected As Object
    Dim acText  As AcadText
    Dim ssText As AcadSelectionSet
    Dim AllText As String
    Dim H As Double
    Dim W As Double
    Dim S As String
    Dim P As Variant
    On Error Resume Next
    Set ssText = ThisDrawing.SelectionSets.Add("Text")
    '定义过滤机制
    Dim filterType(0) As Integer
    Dim filterData(0) As Variant
    filterType(0) = 0
    filterData(0) = "TEXT"
    
    ssText.SelectOnScreen filterType, filterData
    Dim n As Integer
    Dim i As Integer
    Dim j As Integer
    Dim Temp As Double
    Dim X() As Double
    Dim Index() As Integer
    '对选择的插入点进行排序
    '   只对Y方向进行排序
    '   不对X方向进行排序
    n = ssText.Count - 1
    ReDim X(n)
    ReDim Index(n)
    '           读取Y坐标到数组Y()中
    '           没有排序之前Text在选择集中的序号并没有变化,仍然是0、1、2、3……
    For i = 0 To n
        Set acText = ssText.item(i)
        X(i) = acText.insertionPoint(0)
        Index(i) = i
    Next i
    '           对数组X()排序
    For i = 0 To n - 1
        For j = i + 1 To n
            '如果前一个比后面小的话,则把它的序号和后面的交换。
            If X(i) >= X(j) Then
                '交换X坐标
                Temp = X(i)
                X(i) = X(j)
                X(j) = Temp
                '交换Text在选择集中的位置
                Temp = Index(i)
                Index(i) = Index(j)
                Index(j) = Temp
            End If
        Next j
    Next i
    
    Set acText = ssText.item(Index(0))
    H = acText.height
    W = acText.ScaleFactor
    S = acText.StyleName
    P = acText.insertionPoint
    
    '对选择集中的文字对象进行操作
    For i = 0 To n
            Set acText = ssText.item(Index(i))
            AllText = AllText & acText.textString
            acText.Delete
    Next
    Dim NText As AcadText
    Set NText = ThisDrawing.ModelSpace.AddText(AllText, P, H)
    NText.ScaleFactor = W
    NText.StyleName = S
    ThisDrawing.SelectionSets.item("Text").Delete
    NText.Update
End Sub
'*******************************************************

引用这个评论 田草 于 2008-08-08 09:43 AM 发表评论: 
这段代码,不要按照顺序去选择文字了,他自己会按照x坐标自动排序的

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:3*6=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©