程序运行时卡顿现象很严重
以下是程序源码，在执行的时候CAD卡顿现象很严重。比如块（见附件）比较多情况下，选择块进行复制或其他操作是都比较卡顿，选中进行下一步操作都会卡顿几秒，已测试是该程序问题。还有该程序会导致保存卡顿，请大神们看下问题在哪，给修改下 。谢谢！Private Sub AcadDocument_SelectionChanged()
On Error Resume Next
Dim EqINFO As Variant
Dim xtypeout As Variant
Dim xdataout As Variant
Dim ELE As AcadBlockReference
Dim EQ_BLOCK_DATA As Variant '¿éÄúêôDÔ¼ˉoÏ
Dim EqName_att As AcadAttributeReference'êôDÔ
Dim EqId_att As AcadAttributeReference '
Dim EQ_BLOCK_entity As AcadEntity '¿éÄúμÄêμìå
Dim pline As AcadLWPolyline '¿éÄú¶à¶ÎÏß
Set ELE = PickfirstSelectionSet.Item(0)
Dim a(2), b(2) As Variant
Dim c(2), d(2) As Variant
If ELE.HasAttributes Then EQ_BLOCK_DATA = ELE.GetAttributes
Set EqName_att = EQ_BLOCK_DATA(1) 'μÃμ½êôDÔ¶ÔÏó
Set EqId_att = EQ_BLOCK_DATA(0)
'MsgBox EqName_att.MTextAttribute
'End If
With EqName_att
a(0) = .InsertionPoint(0) '2åèëμãX×ø±ê
a(1) = .InsertionPoint(1) '2åèëμãY×ø±ê
b(0) = .TextAlignmentPoint(0)'¶ÔÆëμãX×ø±ê,ÖD¼ä¶ÔÆë
b(1) = .TextAlignmentPoint(1)'¶ÔÆëμãY×ø±ê￡¬ÖD¼ä¶ÔÆë
End With
With EqId_att
c(0) = .InsertionPoint(0) '2åèëμãX×ø±ê
c(1) = .InsertionPoint(1) '2åèëμãY×ø±ê
d(0) = .TextAlignmentPoint(0)'¶ÔÆëμãX×ø±ê,ÖD¼ä¶ÔÆë
d(1) = .TextAlignmentPoint(1)'¶ÔÆëμãY×ø±ê￡¬ÖD¼ä¶ÔÆë
End With
Dim S_DATA, S_data1, S_data2
S_data1 = (b(0) - a(0)) * 2
'MsgBox S_DATA
S_data2 = (d(0) - c(0)) * 2
'MsgBox S_data1 & "," & S_data2
If S_data1 < S_data2 Then
S_DATA = S_data2
ElseIf S_data1 > S_data2 Then
S_DATA = S_data1
End If
Dim dybprop As Variant
Dim i
If ELE.IsDynamicBlock Then
dybprop = ELE.GetDynamicBlockProperties
For i = LBound(dybprop) To UBound(dybprop) 'Goes through Results
If dybprop(i).PropertyName = "eqline" Then 'Looks for the PropertyName
dybprop(i).Value = S_DATA 'Change the Value of the PropertyName
End If
Next i
End If
End Sub
页:
[1]