- UID
- 747365
- 积分
- 6
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2015-2-14
- 最后登录
- 1970-1-1
|
马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
以下是程序源码,在执行的时候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
|
|