[VBA]冻结当前视口中的图层示例
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 于 2014-1-17 13:58 编辑
方法可行的。。
页:
[1]