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

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

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

Exit 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

' 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

End Sub