Sub lc()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim lc As Double
Dim SF As Double
Dim tx As String
Dim sa As Boolean
Dim i As Integer
i = 0
sa = False
Dim Obj As AcadEntity
For Each ent In ss
If TypeOf ent Is AcadEntity Then
i = i + 1
Set Obj = ent
If sa = False Then
SF = Obj.LinetypeScale
On Error GoTo errtap
lc = ThisDrawing.Utility.GetReal("输入新的线型比例:")
If i = 1 Then
ThisDrawing.Utility.InitializeUserInput 0, "Y N"
If Err Or tx = "" Then
tx = "Y"
End If
If tx = "Y" Then
sa = True
End If
End If
End If
ent.LinetypeScale = lc
End If
Next
errtap: Exit Sub
End Sub
Function GetSelSet() As AcadSelectionSet
Dim ss As AcadSelectionSet
Set ss = ThisDrawing.PickfirstSelectionSet
On Error Resume Next
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
问题如下：1.在使用过程中会自动修改filedia的变量值为“0”
2.在使用一定时间后程序就不在起作用，这是最烦人的地方
3.目前只能是先执行程序在选择对象，请问怎样同时做到先选择后执行程序
Function GetSelSet() As AcadSelectionSet
Dim ss As AcadSelectionSet
Dim ssName As String
ssName = "ICKFIRST"
On Error Resume Next
Set ss = ThisDrawing.SelectionSets.Add(ssName)
If Err Then
Set ss = ThisDrawing.SelectionSets(ssName)
ss.Delete
End If
Set ss = ThisDrawing.PickfirstSelectionSet
If ss.Count = 0 Then
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
置顶卡
