21 | 08 | 2017

Freeze Layer in Viewport

Code below alows you to disable (freeze) a layer in the active viewport. 

Sub VpLayerOff(VPlayer As String)  

'****************************************
'*** Code from VisibleVisual.com ********
'****************************************
' freeze the layer in the CURRENT viewport
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
' Get the active ViewPort
Set objPViewport = ThisDrawing.ActivePViewport
' Get the Xdata from the Viewport
objPViewport.GetXData "ACAD", XdataType, XdataValue
For I = LBound(XdataType) To UBound(XdataType)
   ' Look for frozen Layers in this viewport
   If XdataType(I) = 1003 Then
      ' Set the counter AFTER the position of the Layer frozen layer(s)
       Counter = I + 1
      ' If the layer is already in the frozen layers xdata of this viewport the
      ' exit this sub program
      If XdataValue(I) = VPlayer Then Exit Sub
   End If
Next
' If no frozen layers exist in this viewport then
' find the Xdata location 1002 and place the frozen layer infront of the "}"
' found at Xdata location 1002
If Counter = 0 Then
   For I = LBound(XdataType) To UBound(XdataType)
       If XdataType(I) = 1002 Then Counter = I - 1
    Next
End If
' set the Xdata for the layer that is beeing frozen
XdataType(Counter) = 1003
XdataValue(Counter) = VPlayer
ReDim Preserve XdataType(Counter + 1)
ReDim Preserve XdataValue(Counter + 1)
' put the first "}" back into the xdata array
XdataType(Counter + 1) = 1002
XdataValue(Counter + 1) = "}"
' Keep the xdata Array and add one more to the array
ReDim Preserve XdataType(Counter + 2)
ReDim Preserve XdataValue(Counter + 2)
' put the second "}" back into the xdata array
XdataType(Counter + 2) = 1002
XdataValue(Counter + 2) = "}"
' Reset the Xdata on to the viewport
objPViewport.SetXData XdataType, XdataValue
'If no change is visible run VPupdate after this code.
End Sub

 To update the viewport after running the code above. Add the code below.

Sub VPupdateUpdate()

' Update the viewport...
Dim objPViewport As AcadObject

Set objPViewport = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = False
'objPViewport.Display (False)
objPViewport.Display (True)
ThisDrawing.MSpace = True
ThisDrawing.Utility.Prompt ("Viewport Updated!" & vbCr)

End Sub 

 

Login

Sign up now and upload your code to the website.

Help us to continue.....
Statistics
Articles View Hits
2330648
Latest Articles