[求助]请斑竹帮我看以下这个问题

gjliang

下面是我利用选择集做的修改字的宽度因子的程序。
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
有两个问题：１.怎样实现在要求输入新的宽度比例因子时，把旧的宽度比例因子参数传到“宽度比例”后面譬如：宽度比例<旧的参数>：
２.如何实现一次选取多行文本进行宽度比例因子替换。
谢谢了！期待答复！

mccad

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

gjliang

我调试了一下，好象只能一次进行一行，并不能一次把所有选中的各行文字进行一次调整。

mccad

Dim ss As AcadSelectionSet
Set 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

gjliang

可以一次调整比例因子了，但是要判断是否全部才行，是不是能不经过选择而直接进行一次调整呢？

gjliang

mccad

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

gjliang

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

myfreemind

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

gjliang

不知道都是可以改哪些线宽呢，我的选择对象是acadentity所以只要是可以设置线宽的cad实体都可以设置线宽的。