田草博客

互联网田草博客


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

微信 公众号:ByCAD

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

用户登陆
用户:
密码:
 

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


站点统计

最新评论



CAD 文字的上标和下标(单行文字和多行文字) 减小CAD文件的大小和优化显示速度
未知 单行文字对齐平均行距   [ 日期:2007-05-20 ]   [ 来自:本站原创 ]  HTML
单行文字对齐平均行距


         我最恨改图了,还不如画新的图纸。特别在调整建筑说明等文字的时候,不是乱码就是变形的乱七八糟,手东调整是很麻烦的。你可以试试下面的:

Sub TextAlignment()
    Dim RowHeight As Double              '文字间距
    Dim TextFirstPoint(0 To 2) As Double '最上面一行文字的基点坐标
    Dim TextNextPoint(0 To 2) As Double  '文字行距调整后新的基点坐标
    Dim ssText As AcadSelectionSet    '选择集
    Dim acText As AcadText            '选择集中的文本
    Dim DimTxt As Double              '默认文字行距(我自定义为标注文本高度的3倍)
    Dim Y() As Double                 '为了防止选择的文字顺序乱,根据文字插入点的Y坐标进行排序
    Dim j As Integer, N As Integer, Temp As Double    '排序用的临时变量和计数变量
    Dim Index() As Integer            '排序后的Text在原选择集中的序号
    
    On Error Resume Next
   
    DimTxt = 3 * Val(ThisDrawing.GetVariable("DIMTXT"))
    '获得偏移所有文字对象的间距(从第一个被选择的文字对象开始)
    RowHeight = ThisDrawing.Utility.GetDistance(, "请输入文字的行距(" & DimTxt & "):")
    '错误检查
    If Err.Number = -2147352567 Then
        Exit Sub                   '用户按下Esc键,则退出
    ElseIf Err Then
        RowHeight = DimTxt: Err.Clear '如果用户按下 enter 按钮或者输入有误,行距使用默认文字行距
    End If
     
    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
    
    '对选择的插入点进行排序
    '   只对Y方向进行排序
    '   不对X方向进行排序
    N = ssText.Count - 1
    ReDim Y(N)
    ReDim Index(N)
    '           读取Y坐标到数组Y()中
    '           没有排序之前Text在选择集中的序号并没有变化,仍然是0、1、2、3……
    For i = 0 To N
        Set acText = ssText.item(i)
        Y(i) = acText.insertionPoint(1)
        Index(i) = i
        '检测赋值是否正确
        'ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        'ThisDrawing.Utility.Prompt Y(i) & vbCrLf
    Next i
    '           对数组Y()排序
    For i = 0 To N - 1
        For j = i + 1 To N
            '如果前一个比后面小的话,则把它的序号和后面的交换。
            If Y(i) <= Y(j) Then
                '交换Y坐标
                Temp = Y(i)
                Y(i) = Y(j)
                Y(j) = Temp
                '交换Text在选择集中的位置
                Temp = Index(i)
                Index(i) = Index(j)
                Index(j) = Temp
            End If
        Next j
    Next i
    '检测排序是否正确
    'ThisDrawing.Utility.Prompt "_______________" & vbCrLf
    'For i = 0 To n
    '    ThisDrawing.Utility.Prompt Index(i) & vbCrLf
    '    Set acText = ssText.item(Index(i))
    '    ThisDrawing.Utility.Prompt acText.insertionPoint(1) & vbCrLf
    'Next
    '对选择集中的文字对象进行操作
    '根据第一个对象的位置确定基点
    Set acText = ssText.item(Index(0))
    'MsgBox acText.insertionPoint(0)
    TextFirstPoint(0) = acText.insertionPoint(0)
    TextFirstPoint(1) = acText.insertionPoint(1)
    TextFirstPoint(2) = acText.insertionPoint(2)
    '调整文字行距和对齐
    For i = 0 To N
        ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        Set acText = ssText.item(Index(i))
        '将RowHeight的值与相对基点的位置叠加,然后进行移动操作
        TextNextPoint(0) = TextFirstPoint(0)
        TextNextPoint(1) = TextFirstPoint(1) - (RowHeight * i)
        TextNextPoint(2) = TextFirstPoint(2)
        acText.Move acText.insertionPoint, TextNextPoint
    Next
    '删除选择集
    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update
    
End Sub


‘2008-9-4 号 新改的的文字平均行距和左对齐

'文字排版
'       1 文字左对齐
'       2 文字左对齐 且行距相等
'       3 文字行距相等
Function TextAlign(S As Integer)
    Dim RowHeight As Double              '文字间距
    Dim TextFirstPoint(0 To 2) As Double '最上面一行文字的基点坐标
    Dim TextNextPoint(0 To 2) As Double  '文字行距调整后新的基点坐标
    Dim ssText As AcadSelectionSet    '选择集
    Dim acText As AcadText            '选择集中的文本
    Dim DimTxt As Double              '默认文字行距(我自定义为标注文本高度的3倍)
    Dim Y() As Double                 '为了防止选择的文字顺序乱,根据文字插入点的Y坐标进行排序
    Dim j As Integer, N As Integer, Temp As Double    '排序用的临时变量和计数变量
    Dim Index() As Integer            '排序后的Text在原选择集中的序号
    
    On Error Resume Next
    If S <> 1 Then '不需要调整行距则跳过此步骤
        DimTxt = 3 * Val(ThisDrawing.GetVariable("DIMTXT"))
        '获得偏移所有文字对象的间距(从第一个被选择的文字对象开始)
        RowHeight = ThisDrawing.Utility.GetDistance(, "请输入文字的行距(" & DimTxt & "):")
        '错误检查
        If Err.Number = -2147352567 Then
            Exit Function              '用户按下Esc键,则退出
        ElseIf Err Then
            RowHeight = DimTxt: Err.Clear '如果用户按下 enter 按钮或者输入有误,使用默认值
        End If
    End If
    
    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
    
    '对选择的插入点进行排序
    '   只对Y方向进行排序
    '   不对X方向进行排序
    N = ssText.Count - 1
    ReDim Y(N)
    ReDim Index(N)
    '           读取Y坐标到数组Y()中
    '           没有排序之前Text在选择集中的序号并没有变化,仍然是0、1、2、3……
    For i = 0 To N
        Set acText = ssText.item(i)
        Y(i) = acText.insertionPoint(1)
        Index(i) = i
        '检测赋值是否正确
        'ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        'ThisDrawing.Utility.Prompt Y(i) & vbCrLf
    Next i
    '           对数组Y()排序
    For i = 0 To N - 1
        For j = i + 1 To N
            '如果前一个比后面小的话,则把它的序号和后面的交换。
            If Y(i) <= Y(j) Then
                '交换Y坐标
                Temp = Y(i)
                Y(i) = Y(j)
                Y(j) = Temp
                '交换Text在选择集中的位置
                Temp = Index(i)
                Index(i) = Index(j)
                Index(j) = Temp
            End If
        Next j
    Next i
    '检测排序是否正确
    'ThisDrawing.Utility.Prompt "_______________" & vbCrLf
    'For i = 0 To n
    '    ThisDrawing.Utility.Prompt Index(i) & vbCrLf
    '    Set acText = ssText.item(Index(i))
    '    ThisDrawing.Utility.Prompt acText.insertionPoint(1) & vbCrLf
    'Next
    '对选择集中的文字对象进行操作
    '根据第一个对象的位置确定基点
    Set acText = ssText.item(Index(0))
    'MsgBox acText.insertionPoint(0)
    TextFirstPoint(0) = acText.insertionPoint(0)
    TextFirstPoint(1) = acText.insertionPoint(1)
    TextFirstPoint(2) = acText.insertionPoint(2)
    '调整文字行距和对齐
    For i = 0 To N
        ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        Set acText = ssText.item(Index(i))
        If S = 1 Then
            TextNextPoint(0) = TextFirstPoint(0)
            TextNextPoint(1) = acText.insertionPoint(1)     'y坐标不变
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        ElseIf S = 2 Then
            '将RowHeight的值与相对基点的位置叠加,然后进行移动操作
            TextNextPoint(0) = TextFirstPoint(0)
            TextNextPoint(1) = TextFirstPoint(1) - (RowHeight * i)
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        ElseIf S = 3 Then
            '将RowHeight的值与相对基点的位置叠加,然后进行移动操作
            TextNextPoint(0) = acText.insertionPoint(0)     'x坐标不变
            TextNextPoint(1) = TextFirstPoint(1) - (RowHeight * i)
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        End If
        acText.Move acText.insertionPoint, TextNextPoint
    Next
    '删除选择集
    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update
End Function
'文字左对齐
Sub WZZDQ()
    TextAlign 1
End Sub
'文字平均行距左对齐
Sub WZPJHJZDQ()
    TextAlign 2
End Sub
'文字平均行距
Sub WZPJHJ()
    TextAlign 3
End Sub


[本日志由 tiancao1001 于 2008-09-04 05:18 PM 编辑]


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

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

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