用户登陆
站点日历
站点统计
最新评论
单行文字对齐平均行距 [ 日期：2007-05-20 ] [ 来自：单行文字对齐平均行距
我最恨改图了，还不如画新的图纸。特别在调整建筑说明等文字的时候，不是乱码就是变形的乱七八糟，手东调整是很麻烦的。你可以试试下面的：
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
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
' 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 编辑]
|
|
暂时没有评论
| 发表评论 - 不要忘了输入验证码哦！ |