Custom programming solutions, applications and training!

  Freeze Layer(s) in PaperSpace Viewport
Contract CADD Group - Phone: (604) 591-1140 Email: frank.zander@contractcaddgroup.com

Looking for CADD expertise? 
Looking for Web Solutions?   

Think Contract CADD Group!
Think CORBIMITE!

Phone: (604) 591-1140
Toll Free: 1 866 433-2233

CORBIMITE Web Solutions
CORBIMITE Web Solutions

Code for freezing layer(s) in a PaperSpace Viewport (mview)

Creative Commons License
This work is licensed under a Creative Commons Attribution-ShareAlike 2.5 License.

Paste this code into the code window of a form.
Then on the form create a button and from the button call the sub

selectVPobjectsToFreeze.

Option Explicit 

Public Sub selectVPobjectsToFreeze()

Dim objEntity As AcadObject
Dim strLayer As String
Dim
PT1 As Variant
Dim newSS As AcadSelectionSet
Dim vLayers() As Variant

On Error GoTo err_selectVPobjectsToFreeze

ThisDrawing.StartUndoMark

If ThisDrawing.ActiveSpace = acModelSpace Then
    MsgBox "This program only works with PaperSpace Viewports" & vbCr & _
    "Please go to PaperSpace", vbCritical
   Exit Sub
End If

ThisDrawing.MSpace = True
Set newSS = ThisDrawing.SelectionSets.Add("Vplayers")
ThisDrawing.Utility.Prompt ("Select Objects layers to freeze in the viewport:" & vbCr)
newSS.SelectOnScreen

For Each objEntity In newSS
    strLayer = objEntity.Layer
    VpLayerOff (strLayer)

Next

ViewPortUpdate
newSS.Delete
ThisDrawing.EndUndoMark

Exit Sub

err_selectVPobjectsToFreeze:
MsgBox Err.Description, vbInformation
Err.Clear
ThisDrawing.EndUndoMark
End Sub

 

Sub ViewPortUpdate()
' 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 ("Done!" & vbCr)
End Sub

Sub VpLayerOff(strLayer As String)
' make the layer non displayable (freeze) 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) = strLayer 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) = strLayer

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

' notice that at this point NOTHING happens in the viewport to visibly show
' any changes to the viewport.
' flipping to a different layout or turning the Mview Off and On will display the
' Xdata changes to the viewport.
' See sub ViewPortUpdate for how to update the Viewport.

End Sub

   

CORBIMITE Web Solutions CORBIMITE Web Solutions CORBIMITE Web Solutions
CORBIMITE Web Solutions
CORBIMITE Web Solutions

CORBIMITE Web Solutions
Website created By Frank Zander
Phone: (604) 591-1140
Copyright 2006 
Contract CADD Group
All rights reserved.


Contract CADD Group is an Autodesk Developer Network member.

Please give us Feedback!
Send your comments and  suggestions to:
Frank Zander
Revised: May 03, 2009.

Back Back Top of Page
Search