[求助]请斑竹帮我看以下这个问题
下面是我利用选择集做的修改字的宽度因子的程序。Sub ts()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As String
For Each ent In ss
On Error GoTo errtap
ts = ThisDrawing.Utility.GetString(False, "宽度比例：")
If TypeOf ent Is AcadText Then
ent.ScaleFactor = ts
End If
Next
errtap:
Exit Sub
End Sub
Function GetSelSet() As AcadSelectionSet
Dim ss As AcadSelectionSet
Set ss = ThisDrawing.PickfirstSelectionSet
If ss.Count = 0 Then
Dim ssName As String
ssName = "strSSet"
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
ss.SelectOnScreen
End If
Set GetSelSet = ss
End Function
有两个问题：１.怎样实现在要求输入新的宽度比例因子时，把旧的宽度比例因子参数传到“宽度比例”后面譬如：宽度比例<旧的参数>：
２.如何实现一次选取多行文本进行宽度比例因子替换。
谢谢了！期待答复！
可以使用以下的过程来完成
Sub ts()Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
Set ObjTxt = ent
ObjTxt.Highlight True
SF = ObjTxt.ScaleFactor
ts = ThisDrawing.Utility.GetReal("宽度比例<" & SF & ">：")
If Err Then
ts = SF
End If
ent.ScaleFactor = ts
End If
Next
End Sub
好象自动一次改一行啊
我调试了一下，好象只能一次进行一行，并不能一次把所有选中的各行文字进行一次调整。那是因为每一文字行的宽度因子可能不同，我再改一下你试试
Dim ss As AcadSelectionSetSet ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim tx As String
Dim sa As Boolean
Dim i As Integer
i = 0
sa = False
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
i = i + 1
Set ObjTxt = ent
If sa = False Then
ObjTxt.Highlight True
SF = ObjTxt.ScaleFactor
ts = ThisDrawing.Utility.GetReal("宽度比例<" & SF & ">：")
If Err Then
ts = SF
End If
If i = 1 Then
ThisDrawing.Utility.InitializeUserInput 0, "Y N"
tx = ThisDrawing.Utility.GetKeyword("是否将所有宽度比例设置为 " & ts & " [是(Y)/否(N)]<是>")
If Err Or tx = "" Then
tx = "Y"
End If
If tx = "Y" Then
sa = True
End If
End If
End If
ent.ScaleFactor = ts
End If
Next
End Sub
可以了，但能否不要中间的判断而直接修改呢？
可以一次调整比例因子了，但是要判断是否全部才行，是不是能不经过选择而直接进行一次调整呢？可以了，我把那两行要判断是否要全部转换的程序注释了。
那就更简单了，你应该可能自己改吧
Sub ts()Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim i As Integer
i = 0
Dim ObjTxt As AcadText
For Each ent In ss
On Error Resume Next
If ent.ObjectName = "AcDbText" Then
i = i + 1
Set ObjTxt = ent
If i = 1 Then
ObjTxt.Highlight True
SF = ObjTxt.ScaleFactor
ts = ThisDrawing.Utility.GetReal("宽度比例<" & SF & ">：")
If Err Then
ts = SF
End If
End If
ObjTxt.ScaleFactor = ts
End If
Next
End Sub
是的，根据你提供的思路，我又写了个修改线宽的程序。
Sub cw()Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim ts As Double
Dim SF As Double
Dim tx As String
Dim i As Integer
i = 0
Dim Obj As AcadEntity
For Each ent In ss
If TypeOf ent Is AcadEntity Then
i = i + 1
Set Obj = ent
If i = 1 Then
SF = Obj.Lineweight / 100
On Error GoTo errtap
ts = ThisDrawing.Utility.GetReal("新线宽<" & SF & "mm" & ">:")
End If
ent.Lineweight = ts * 100
End If
Next
errtap: Exit Sub
End Sub
我前一段时间也写了个改线宽的程序，代码如下，请大家看看还有没有可改进的地方！
Sub jczx()On Error Resume Next
Dim i As Integer
Dim allobj As AcadEntity
Dim spnt As Variant
Dim epnt As Variant
Dim plineobj As AcadLWPolyline
Dim ver(0 To 3) As Double
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
Dim sset As AcadSelectionSet
Set sset = ThisDrawing.SelectionSets.Add("lineset")
sset.SelectOnScreen
If sset.Count = 0 Then Exit Sub
Dim w As String
w = ThisDrawing.Utility.GetString(1, vbCrLf & "请输入宽度:")
For Each allobj In sset
If allobj.ObjectName <> "AcDbLine" Then
allobj.ConstantWidth = w
End If
If allobj.ObjectName = "AcDbLine" Then
spnt = allobj.StartPoint
epnt = allobj.EndPoint
ver(0) = spnt(0): ver(1) = spnt(1)
ver(2) = epnt(0): ver(3) = epnt(1)
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ver)
plineobj.ConstantWidth = w
allobj.Delete
End If
Next
Exit Sub
end sub
不知道都可以改哪些线宽？
不知道都是可以改哪些线宽呢，我的选择对象是acadentity所以只要是可以设置线宽的cad实体都可以设置线宽的。
页:
[1]
2