Custom programming solutions, applications and training!

  THAW a layer in a 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

After several request and users saying "Hey you can't do that in VBA"  here we go. With the tweedle dee to the tweedle dum of Freezing Layers in a PaperSpace View Port.  You got it, THAW a layer in a PaperSpace ViewPort!

First we build a test wrapper to run vpLayerOn

Sub  testVplayerOn()
    Dim  strLayer As String
    Dim  objPviewport As AcadPViewport
    Dim  Pt1 As Variant
    Dim strPrompt As String

    On Error GoTo err_selectVPobjectsToFreeze

    ' set an undo mark in the drawing
    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
    ' let's get into Paper Space
    ThisDrawing.MSpace = False

    ' Select a viewport
    ThisDrawing.Utility.GetEntity objPviewport, Pt1, "Select ViewPort:"

    strPrompt = "Enter Layer Name to thaw in Veiw Port: "

    ' Ask the user for a layer to thaw in the Paperspace View port
    strLayer = ThisDrawing.Utility.GetString(True, strPrompt)


    ' run the main program that does the grunt of the work
    ' yhea for vpLayer on!

    VpLayerOn strLayer, objPviewport

    ' Place an end to the undo mark
    ThisDrawing.EndUndoMark

    ' exit this sub
    Exit Sub
    ' error handling
err_selectVPobjectsToFreeze:
    MsgBox Err.Description, vbInformation
    Err.Clear
    ThisDrawing.EndUndoMark

End Sub

' Next the VpLayerOn!

Sub  VpLayerOn(strLayer As String, objPviewport As AcadPViewport)
    Dim  XdataType As Variant
    Dim  XdataValue As Variant
    Dim  newXdataType As Variant
    Dim  newXdataValue As Variant
    Dim  I As Integer
    Dim  counter As Integer
    Dim  Pt1 As Variant
    Dim  varCenter As Variant
    Dim  dblWidth As Double
    Dim  dblHeight As Double
    Dim  objViewPortNew As AcadPViewport

    ' 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
            ' Match the layer we are looking for and exit the sub --
            ' bingo we have the frozen layer location
!
            If UCase(XdataValue(I)) = UCase(strLayer) Then Exit For
        End If
    Next


    ' Layer not found in this Mview
    If counter = 0 Then Exit Sub

    ' pull Width Height and Center from selected veiwport
    dblWidth = objPviewport.Width
    dblHeight = objPviewport.Height
    varCenter = objPviewport.Center

    ' set the Xdata for the layer that is beeing frozen
    newXdataType = XdataType
    newXdataValue = XdataValue

    ' work throught the remaining array...
    For I = counter To UBound(XdataType)
        ReDim Preserve newXdataType(I - 1)
        ReDim Preserve newXdataValue(I - 1)
        newXdataType(I - 1) = XdataType(I)
        newXdataValue(I - 1) = XdataValue(I)

    Next

    'objViewPortNew.SetXData XdataType, XdataValue
    Set objViewPortNew = ThisDrawing.PaperSpace.AddPViewport(varCenter, dblWidth, dblHeight)
    ' Apply xdata to new Pviewport
    objViewPortNew.SetXData newXdataType, newXdataValue
    ' Put the new viewPort on the same layer as the original viewport
    objViewportNew.Layer = objPviewport.Layer
    ' Refresh viewport!!
    ThisDrawing.MSpace = False
    objViewPortNew.Display (False)
    objViewPortNew.Display (True)
    ThisDrawing.Utility.Prompt ("Done!" & vbCr)

    ' Delete Old viewport
    objPviewport.Delete
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