freeze layer in current viewport (vba)

[nootie]

Hello,

 

I have 50 layouts with 2 viewports. For each viewport, i have to freeze some layers. So I have to select the left viewport from the layout and freeze or unfreeze some layers, then I select the right viewport and also freeze or unfreeze some other layers.

 

I have allready find some code on the internet but I still have two problems:

 

1. I can't select two different viewports. It is always the same viewport who acitvates.

 

Sub SetupFullSizeTab()
Dim objVPLeft As AcadPViewport
Dim objVPRight As AcadPViewport
Dim objEnt As AcadEntity
Dim objLayout As AcadLayout
Dim bTest As Boolean
Dim xL As Double
Dim xR As Double

ThisDrawing.SetVariable "CTAB", "FULL SIZE"
For Each objEnt In ThisDrawing.ActiveLayout.Block
'this test skips the first object in the layout which is always _
the PS Vport of the layout itself
If bTest = True Then
If TypeOf objEnt Is AcadPViewport Then
If objVPLeft Is Nothing Then
Set objVPLeft = objEnt
Else
Set objVPRight = objEnt
xL = objVPLeft.Center(0)
xR = objVPRight.Center(0)
If xL > xR Then
Set objVPRight = objVPLeft
Set objVPLeft = objEnt
Exit For
Else
Exit For
End If
End If
End If
Else
bTest = True
End If
Next

''do whatever with the 2 viewports now
objVPLeft.DisplayLocked = False
objVPLeft.Display True
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = objVPLeft
ThisDrawing.Application.ZoomExtents
objVPLeft.StandardScale = acVpCustomScale
objVPLeft.CustomScale = 0.25 / 12#
objVPLeft.DisplayLocked = True
objVPRight.DisplayLocked = False

ThisDrawing.ActivePViewport = objVPRight
ThisDrawing.Application.ZoomExtents
objVPRight.StandardScale = acVpCustomScale
objVPRight.CustomScale = 0.25 / 12#
objVPRight.DisplayLocked = True
ThisDrawing.MSpace = False

End Sub

2. I work with polygonal viewports and the code for unfreezing the layers always works with new viewports. But each time

the code add a new viewport, it's never a polygonal viewports. Doesn't there exist a code for unfreezing the layers without removing the viewport.

 

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
   objP[font=Courier New]viewport.Delete[/font]
[font=Courier New] [color=navy]End Sub

[/color][/font]

thx

[nootie]

Does nobody has a solution for these problems

[audeser]

I know this thread is 11 years old, and probably is useless for you right now, but your code was really illustrative for me; so, to get info under the same thread, I will continue the post, if it could help somebody in the future.

For the first issue, following code solves the matter, first activates one, the activates the other one:

 

Private Sub SetupFullSizeTab()
' select two different viewports... one after the other
    Dim ocadDrw As AutoCAD.AcadDocument
    Dim ocadVPortLft As AutoCAD.AcadPViewport
    Dim ocadVPortRgt As AutoCAD.AcadPViewport
    Dim ocadEntity As AutoCAD.AcadEntity
    Dim ocadLayout As AutoCAD.AcadLayout
    Dim Coordinates As Variant
    Dim bTest As Boolean
    Dim xL As Double
    Dim xR As Double
    
    Set ocadDrw = ThisDrawing
    With ocadDrw

        ' Add a Layout, activate, and enter PViewPort ModelSpace
        '.Layouts.Add "SomeName"
        '.ActiveLayout = .Layouts("SomeName") 'or: .SetVariable "CTAB", "FULL_SIZE"  ' activates the tab with that name...


        For Each ocadEntity In ocadDrw.ActiveLayout.Block
        ' test skips the first object in the layout (which is always the PaperSpace Vport of the layout itself)

            If bTest = True Then
                If TypeOf ocadEntity Is AutoCAD.AcadLWPolyline Then
                ' when the viewport is not rectangular, there is a LwPolyLine embebded
                ' To change coordinates:
                    Coordinates = ocadEntity.Coordinates
                    Coordinates(0) = 150
                    ocadEntity.Coordinates = Coordinates
                    ocadEntity.Update
                End If
                
                If TypeOf ocadEntity Is AutoCAD.AcadPViewport Then
                    If ocadVPortLft Is Nothing Then
                        Set ocadVPortLft = ocadEntity
                    Else
                        Set ocadVPortRgt = ocadEntity
                        If ocadVPortLft.Center(0) > ocadVPortRgt.Center(0) Then
                            Set ocadVPortRgt = ocadVPortLft
                            Set ocadVPortLft = ocadEntity
                        End If
                        'Exit For
                    End If
                'Else
                '    Debug.Print ocadEntity.ObjectName
                End If
            Else
                bTest = True
            End If
        Next
        
        ' do whatever with the 2 viewports now
        .MSpace = True
        .ActivePViewport = ocadVPortLft
        With ocadVPortLft
            .DisplayLocked = False
            .Display True
            ocadDrw.Application.ZoomExtents
            .StandardScale = acVpCustomScale
            .CustomScale = 0.25 / 12#
            .DisplayLocked = True
        End With
        
        ' Change to the other viewport
        .ActivePViewport = ocadVPortRgt
        .MSpace = True
        With ocadVPortRgt
            .DisplayLocked = False
            ocadDrw.Application.ZoomExtents
            .StandardScale = acVpCustomScale
            .CustomScale = 0.25 / 12#
            .DisplayLocked = True
        End With
        .MSpace = False
    End With
End Sub

 

The second one, should be solved with VPLAYER command

 

Sub sLayers_PViewport_VPlayer()
' more info in the following reference:
' www.contractcaddgroup.com/articles/vport.htm

' Freeze / Thaw to unfreeze...
' NewFrz to freeze on new viewports...
' Transparency
' reMoveOverrides
' vpVisDflt
' Color
' LWeight
' LType
    
    Dim ocadDrw As AutoCAD.AcadDocument
    Dim pviewportObj As AutoCAD.AcadPViewport
    
    Set ocadDrw = ThisDrawing
    With ocadDrw
        '.Layers.Add ("Apple")
        '.Layers.Add ("Orange")
        
        .ActiveLayer = .Layers("Orange")
        .ActiveSpace = acPaperSpace
        
        .ActivePViewport.Display (True)
        .MSpace = True
        
        ' Go freeze some layers... (works even if layers do not exists)
        .SendCommand "vplayer freeze 0,Apple,Orange" & vbCr & vbCr & vbCr
        
        ' Go unfreeze some layers... (works even if layers do not exists)
        .SendCommand "vplayer Thaw 0,Apple" & vbCr & vbCr & vbCr
        
        '.ActivePViewport.DisplayLocked = True
        .MSpace = False
    End With
End Sub

 

Edited May 6, 2021 by CADTutor
Moved code to code block (BBCode is not supported)

[mhupp]

On 5/6/2010 at 1:56 PM, nootie said:

Does nobody has a solution for these problems

 

Might want to post in the .NET, ObjectARX & VBA forums This is for AutoLISP, Visual LISP & DCL

 

--edit-- lol didn't see the 11 year old post

 

 

 

Edited May 6, 2021 by mhupp