[VBA]冻结当前视口中的图层示例

mccad

2. Option Explicit
3. ' 冻结当前视口中的图层示例
4. ' VBA没有直接的方法来冻结当前视口中的图层
5. ' 这里通过扩展数据的方法来进行操作。Public Sub selectVPobjectsToFreeze()Dim objEntity As AcadObject
6. Dim strLayer As String
7. Dim PT1 As Variant
8. Dim newSS As AcadSelectionSet
9. Dim vLayers() As VariantOn Error GoTo err_selectVPobjectsToFreezeThisDrawing.StartUndoMarkIf ThisDrawing.ActiveSpace = acModelSpace Then
10.        MsgBox "该程序只能在图纸空间视口中运行。" & vbCr & _
11.        "请切换到图纸空间", vbCritical, "明经通道VBA示例"
12.      Exit Sub
13. End IfThisDrawing.MSpace = True
14. Set newSS = ThisDrawing.SelectionSets.Add("Vplayers")
15. ThisDrawing.Utility.Prompt ("选择视口中需要冻结图层的对象:" & vbCr)
16. newSS.SelectOnScreen
17. For Each objEntity In newSS
18.        strLayer = objEntity.Layer
19.        VpLayerOff (strLayer)
20. NextViewPortUpdate
21. newSS.Delete
22. ThisDrawing.EndUndoMarkExit Suberr_selectVPobjectsToFreeze:
23. MsgBox Err.Description, vbInformation
24. Err.Clear
25. ThisDrawing.EndUndoMark
26. End SubSub ViewPortUpdate()
27. ' 更新视口...
28. Dim objPViewport As AcadObjectSet objPViewport = ThisDrawing.ActivePViewport
29. ThisDrawing.MSpace = False
30. objPViewport.Display (False)
31. objPViewport.Display (True)
32. ThisDrawing.MSpace = True
33. ThisDrawing.Utility.Prompt ("完成!" & vbCr)
34. End SubSub VpLayerOff(strLayer As String)
35. ' 使图层在当前视口中不显示(冻结)
36. Dim objEntity As AcadObject
37. Dim objPViewport As AcadObject
38. Dim objPViewport2 As AcadObject
39. Dim XdataType As Variant
40. Dim XdataValue As Variant
41. Dim I As Integer
42. Dim Counter As Integer
43. Dim PT1 As Variant' 获得活动的视口
44. Set objPViewport = ThisDrawing.ActivePViewport' 从视口中获取扩展数据
45. objPViewport.GetXData "ACAD", XdataType, XdataValueFor I = LBound(XdataType) To UBound(XdataType)
46.      ' 在视口中查看已冻结的图层
47.      If XdataType(I) = 1003 Then
48.            ' 设置冻结图层的计数器
49.              Counter = I + 1
50.            ' 如果指定图层已经在视口扩展数据中的冻结图层列表中
51.            ' 则退出该程序
52.            If XdataValue(I) = strLayer Then Exit Sub
53.      End If
54. Next' 如果视口中无冻结的图层则
55. ' 查找位于1002的Xdata并在1002扩展数据的"}"前设置冻结图层
56. If Counter = 0 Then
57.      For I = LBound(XdataType) To UBound(XdataType)
58.              If XdataType(I) = 1002 Then Counter = I - 1
59.        Next
60. End If' 设置图层的Xdata为冻结
61. XdataType(Counter) = 1003
62. XdataValue(Counter) = strLayerReDim Preserve XdataType(Counter + 1)
63. ReDim Preserve XdataValue(Counter + 1)' 将第一个 "}" 设置回到xdata数组中
64. XdataType(Counter + 1) = 1002
65. XdataValue(Counter + 1) = "}"' 保持xdata数组并再增加一个元素到该数组中
66. ReDim Preserve XdataType(Counter + 2)
67. ReDim Preserve XdataValue(Counter + 2)' 将第二个 "}" 放到xdata数组中
68. XdataType(Counter + 2) = 1002
69. XdataValue(Counter + 2) = "}"' 重新设置视口的Xdata。
70. objPViewport.SetXData XdataType, XdataValue' 注意此时视口中不会显示任何的变化。
71. ' 可切换到布局或将Mview设置为关然后再设为开就会显示视口的Xdata更改后的情况。
72. ' 参阅 ViewPortUpdate 以了解怎样更新视口。End Sub

Option Explicit ' 冻结当前视口中的图层示例 ' VBA没有直接的方法来冻结当前视口中的图层 ' 这里通过扩展数据的方法来进行操作。Public Sub selectVPobjectsToFreeze()Dim objEntity As AcadObject Dim strLayer As String Dim PT1 As Variant Dim newSS As AcadSelectionSet Dim vLayers() As VariantOn Error GoTo err_selectVPobjectsToFreezeThisDrawing.StartUndoMarkIf ThisDrawing.ActiveSpace = acModelSpace Then        MsgBox "该程序只能在图纸空间视口中运行。" & vbCr & _        "请切换到图纸空间", vbCritical, "明经通道VBA示例"      Exit Sub End IfThisDrawing.MSpace = True Set newSS = ThisDrawing.SelectionSets.Add("Vplayers") ThisDrawing.Utility.Prompt ("选择视口中需要冻结图层的对象:" & vbCr) newSS.SelectOnScreen For Each objEntity In newSS        strLayer = objEntity.Layer        VpLayerOff (strLayer) NextViewPortUpdate newSS.Delete ThisDrawing.EndUndoMarkExit Suberr_selectVPobjectsToFreeze: MsgBox Err.Description, vbInformation Err.Clear ThisDrawing.EndUndoMark End SubSub ViewPortUpdate() ' 更新视口... Dim objPViewport As AcadObjectSet objPViewport = ThisDrawing.ActivePViewport ThisDrawing.MSpace = False objPViewport.Display (False) objPViewport.Display (True) ThisDrawing.MSpace = True ThisDrawing.Utility.Prompt ("完成!" & vbCr) End SubSub VpLayerOff(strLayer As String) ' 使图层在当前视口中不显示(冻结) Dim objEntity As AcadObject Dim objPViewport As AcadObject Dim objPViewport2 As AcadObject Dim XdataType As Variant Dim XdataValue As Variant Dim I As Integer Dim Counter As Integer Dim PT1 As Variant' 获得活动的视口 Set objPViewport = ThisDrawing.ActivePViewport' 从视口中获取扩展数据 objPViewport.GetXData "ACAD", XdataType, XdataValueFor I = LBound(XdataType) To UBound(XdataType)      ' 在视口中查看已冻结的图层      If XdataType(I) = 1003 Then            ' 设置冻结图层的计数器              Counter = I + 1            ' 如果指定图层已经在视口扩展数据中的冻结图层列表中            ' 则退出该程序            If XdataValue(I) = strLayer Then Exit Sub      End If Next' 如果视口中无冻结的图层则 ' 查找位于1002的Xdata并在1002扩展数据的"}"前设置冻结图层 If Counter = 0 Then      For I = LBound(XdataType) To UBound(XdataType)              If XdataType(I) = 1002 Then Counter = I - 1        Next End If' 设置图层的Xdata为冻结 XdataType(Counter) = 1003 XdataValue(Counter) = strLayerReDim Preserve XdataType(Counter + 1) ReDim Preserve XdataValue(Counter + 1)' 将第一个 "}" 设置回到xdata数组中 XdataType(Counter + 1) = 1002 XdataValue(Counter + 1) = "}"' 保持xdata数组并再增加一个元素到该数组中 ReDim Preserve XdataType(Counter + 2) ReDim Preserve XdataValue(Counter + 2)' 将第二个 "}" 放到xdata数组中 XdataType(Counter + 2) = 1002 XdataValue(Counter + 2) = "}"' 重新设置视口的Xdata。 objPViewport.SetXData XdataType, XdataValue' 注意此时视口中不会显示任何的变化。 ' 可切换到布局或将Mview设置为关然后再设为开就会显示视口的Xdata更改后的情况。 ' 参阅 ViewPortUpdate 以了解怎样更新视口。End Sub

wxd20130610

方法可行的。。