[求助]请帮我看一下这段程序

gjliang

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("输入新的线型比例<" & SF & ">:")
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.目前只能是先执行程序在选择对象，请问怎样同时做到先选择后执行程序

mccad

不起作用是指程序不运行还是运行了不起效果，说详细点。
对于先选择后操作，你可以在二次开发栏目中找到答案：
有关PickfirstSelectionSet方法的讨论
http://www.mjtd.com/a2/list.asp?id=434

gjliang

是程序运行了不起效果，打开一个文件当执行几次以后就会出现程序仍运行但没有效果的现象。

gjliang

今天找到了程序运行中失效的一个问题，就是在一个文档中操作时，如果此时执行open命令，并取消打开文档，然后在运行本程序就会产生只选择而无法执行更改线形比例的程序代码。

mccad

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

gjliang

真是太感谢了，明天去办公室调试。