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).
Set objVPLeft = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True
Set objVPRight = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True
Heeft er iemand een oplossing voor dit probleem?
Ik weet nagenoeg niets van VBA maar volgens mij zit de oplossing al in de code bij jouw vorige probleem (http://www.cadsite.be/smf/index.php?topic=4067.0):
...
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = objVPLeft
...
...
ThisDrawing.ActivePViewport = objVPRight
...
...
ThisDrawing.MSpace = False
Hier hebt u momenteel mijn volledige code:
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.
bedoel je zoiets?
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