problemen met activeren van een viewport

[nootie]

Hoi,

Nu mijn ander probleem is opgelost, zit ik al met een nieuwe moelijkheid.
Ik zit nog steeds met mijn 2 viewporten die ik allebei wil activeren om de layers te bevriezen.

Ik dacht d.m.v. de volgende code dat ik beurtelings mijn 2 viewporten kon activeren, maar telkens wordt dezelfde viewport geselecteerd (m.a.w. diegene die laatst geactiveerd was in autocad).

Code Selecteer Uitklappen

Set objVPLeft = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True

Set objVPRight = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True


Heeft er iemand een oplossing voor dit probleem?

[roy_043]

Ik weet nagenoeg niets van VBA maar volgens mij zit de oplossing al in de code bij jouw vorige probleem:

Code Selecteer Uitklappen


...
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = objVPLeft
...
...
ThisDrawing.ActivePViewport = objVPRight
...
...
ThisDrawing.MSpace = False


[nootie]

Hier hebt u momenteel mijn volledige code:

Code Selecteer Uitklappen

public sub bevriezenlayers()


Dim objEntity As AcadObject
Dim objPViewport As AcadObject
Dim objPViewport2 As AcadObject
Dim objViewPortNew As AcadPViewport
Dim XdataType As Variant
Dim XdataValue As Variant
Dim I As Integer
Dim D As Integer
Dim Counter As Integer
Dim strLayer As String


Dim objVPLeft As AcadPViewport
Dim objVPRight As AcadPViewport
Dim objEnt As AcadEntity
Dim objLayout As AcadLayout
Dim xL As Double
Dim xR As Double
Dim elem As Variant

Set objVPLeft = Nothing
Set objVPRight = Nothing

'onderscheid maken tussen de 2 viewports

For Each elem In ThisDrawing.ActiveLayout.Block
With elem
      If elem.EntityName = "AcDbViewport" Then
            If objVPLeft Is Nothing Then
                Set objVPLeft = elem
            Else
                Set objVPRight = elem
                xL = objVPLeft.center(0)
                xR = objVPRight.center(0)
                If xL > xR Then
                   Set objVPRight = objVPLeft
                   Set objVPLeft = elem
                End If
            End If
        End If
End With
Next elem
   
If ThisDrawing.ActiveSpace = acModelSpace Then
    MsgBox "This program only works with PaperSpace Viewports" & vbCr & _
    "Please go to PaperSpace", vbCritical
    Exit Sub
End If



'viewport 1 bevriezen                     

                        Set objVPLeft = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        Set objVPLeft = ThisDrawing.ActivePViewport
                        objVPLeft.GetXData "ACAD", XdataType, XdataValue
                       
                        For I = LBound(XdataType) To UBound(XdataType)
                           If XdataType(I) = 1003 Then
                               Counter = I + 1
                               If XdataValue(i) = "strLayer1" Then Exit Sub
                           End If
                        Next
                       
                        If Counter = 0 Then
                           For I = LBound(XdataType) To UBound(XdataType)
                               If XdataType(I) = 1002 Then Counter = I - 1
                            Next
                        End If
                       
                        XdataType(Counter) = 1003
                        XdataValue(Counter) = "strLayer1"
                       
                        ReDim Preserve XdataType(Counter + 1)
                        ReDim Preserve XdataValue(Counter + 1)
                       
                        XdataType(Counter + 1) = 1002
                        XdataValue(Counter + 1) = "}"
                       
                        ReDim Preserve XdataType(Counter + 2)
                        ReDim Preserve XdataValue(Counter + 2)
                       
                        XdataType(Counter + 2) = 1002
                        XdataValue(Counter + 2) = "}"
                       
                        objVPLeft.SetXData XdataType, XdataValue
                               
                        Set objVPLeft = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        objVPLeft.Display (False)
                        objVPLeft.Display (True)



'viewport 2 bevriezen                               
                        Set objVPRight = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        objVPRight.GetXData "ACAD", XdataType, XdataValue
                       
                        For I = LBound(XdataType) To UBound(XdataType)
                           If XdataType(I) = 1003 Then
                               Counter = I + 1
                              If XdataValue(I) = "strLayer2" Then Exit Sub
                           End If
                        Next
                       
                        If Counter = 0 Then
                           For I = LBound(XdataType) To UBound(XdataType)
                               If XdataType(I) = 1002 Then Counter = I - 1
                            Next
                        End If
                       
                        XdataType(Counter) = 1003
                        XdataValue(Counter) = "strLayer2"
                       
                        ReDim Preserve XdataType(Counter + 1)
                        ReDim Preserve XdataValue(Counter + 1)
                       
                        XdataType(Counter + 1) = 1002
                        XdataValue(Counter + 1) = "}"
                       
                        ReDim Preserve XdataType(Counter + 2)
                        ReDim Preserve XdataValue(Counter + 2)
                       
                        XdataType(Counter + 2) = 1002
                        XdataValue(Counter + 2) = "}"
                       
                        objVPRight.SetXData XdataType, XdataValue
                               
                        Set objVPRight = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = False
                        objVPRight.Display (False)
                        objVPRight.Display (True)


end sub

De naam strLayer1 en strLayer2 zijn de namen van de layers die men wil bevriezen in de viewports.

[sschevers]

bedoel je zoiets?

Code Selecteer Uitklappen


Option Explicit
Public Sub FreezeLayers()
   Dim vpLeft As AcadPViewport
   Dim vpRight As AcadPViewport
   Dim ent As AcadEntity
   Dim test As Boolean
   Dim xL As Double
   Dim xR As Double

   If ThisDrawing.ActiveSpace = acPaperSpace Then
      For Each ent In ThisDrawing.ActiveLayout.Block
         'this test skips the first object in the layout which is always _
          the PS Vport of the layout itself
         If test = True Then
            If TypeOf ent Is AcadPViewport Then
               If vpLeft Is Nothing Then
                  Set vpLeft = ent
               Else
                  Set vpRight = ent
                  xL = vpLeft.Center(0)
                  xR = vpRight.Center(0)
                  If xL > xR Then
                     Set vpRight = vpLeft
                     Set vpLeft = ent
                     Exit For
                  Else
                     Exit For
                  End If
               End If
            End If
         Else
           test = True
         End If
      Next
     
      'lagen uitzetten het linker Viewport
      VpLayerOff "rode laag", vpLeft
      ViewPortUpdate vpLeft
     
      'lagen uitzetten het rechter Viewport
      VpLayerOff "groene laag", vpRight
      ViewPortUpdate vpRight
     
     

   Else
      MsgBox "This program only works in Paperspace" & vbCrLf & "Switch to paperspace.", vbOKOnly + vbExclamation, "Error"

   End If




End Sub




Private Sub ViewPortUpdate(PViewport As AcadPViewport)
   ' Update the viewport...
   ThisDrawing.MSpace = True
   ThisDrawing.ActivePViewport = PViewport
   PViewport.Display (False)
   PViewport.Display (True)
   ThisDrawing.MSpace = False
   ThisDrawing.Utility.Prompt ("Done!" & vbCr)
End Sub

Private Sub VpLayerOff(strLayer As String, PViewport As AcadPViewport)
   ' make the layer non displayable (freeze) in the current Viewport
   Dim objEntity As AcadObject
   Dim XdataType As Variant
   Dim XdataValue As Variant
   Dim I As Integer
   Dim Counter As Integer
   Dim PT1 As Variant

   ThisDrawing.MSpace = True
   ThisDrawing.ActivePViewport = PViewport



   ' Get the Xdata from the Viewport
   PViewport.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
   PViewport.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.

   ThisDrawing.MSpace = False

End Sub



"rode laag" en "groene laag" zijn de namen van de lagen die gefreezed moeten worden

stephan