Switching layers on/off in viewports using VBA

[gert.rombaut]

Hello,

Let's assume I have a drawing with one layout and the layout contains 5 viewports.
In every viewport I select which layers are visible by turning the "VP Freeze" property of this layer on or off.

My problem is that everytime I create a new layer in modelspace, this new layer is visible in all the viewports in the layout. So now I have to select every viewport and turn the new layer off if necessary. If it's only one drawing with one layout and 5 viewports I will do it manually. But what if we are talking about a drawing containing 5 layouts and each layout contains 5 viewports. That's 25 times I have to select a viewport and turn the new layer off.

Here's my question:

Is there a way to export for every viewport the layerproperties to excel, turn the layers on or off in excel and import the layerproperties back in to autocad. I know how to export and import data from autocad to excel. What I don't know is the syntax to select viewports and the layerproperties.

I hope this makes any sence.
If there is another way to do this just let me know.

Best regards,

Gert

[RobertB]

Sounds like way too much work. If you collect all the data to have Excel do the work, why not just do the work in AutoCAD, since you have the data?

[B_Roche]

While we're on the subject, has anyone seen code that 'Thaws' paperspace viewports using the same method as the 'VP Freeze' routine does? The 'VP_Freeze' routines Ive seen append the layers names to the Xdata, but the VP_Freeze routine erases, then recreates the viewport.. that's a no-go if you are using Sheet Set manager ....

[Dieter Vermeulen]

Gert,

Below some code that can help you out. Just choose one viewport with the correct layer state (frozen or not), and enter. The code will copy the layer state to all viewports of all layouts in the current drawing. Beware of two things:
1. To see any changes in the viewports, switch between ModelSpace en Paperspace, to update the viewports
2. This code only works for FREEZING viewports. When layers in the "source viewport" are not frozen, you can not thawn those same layers in the other viewports. See remark of B_Roche.


Private Sub CopyLayerStateViewport()

Dim AcadDoc As AcadDocument
Dim ssetObj As AcadSelectionSet
Dim entObj As AcadObject
Dim oSrcViewPort As IAcadPViewport2
Dim oTrgViewPort As IAcadPViewport2
Dim oLayout As AcadLayout
Dim ent As AcadEntity
Dim XdataType As Variant
Dim XdataValue As Variant

Set AcadDoc = Application.ActiveDocument

'PROMPT COMMAND LINE
AcadDoc.Utility.Prompt ("-> Choose source viewport to copy layerstate from." & vbCrLf)

'SELECT SOURCE VIEWPORT
On Error Resume Next
Set ssetObj = AcadDoc.SelectionSets.Item("SS1")
If Err Then
Set ssetObj = AcadDoc.SelectionSets.Add("SS1")
Err.Clear
Else
ssetObj.Clear
End If
On Error GoTo 0
SEL: ssetObj.SelectOnScreen

'CHECK SELECTION
'Check number of selected objectsSelect Case ssetObj.Count
Case Is = 0 'To end application, select none viewport (press RMB)
ssetObj.Clear
Exit Sub
Case Is > 1 'If number of viewports selected > 1, then return to line SEL
MsgBox "Select maximum 1 object!", vbCritical, "ERROR"
ssetObj.Clear
GoTo SEL
End Select
'Check if selected object is viewport
Set entObj = ssetObj.Item(0)
If TypeOf entObj Is IAcadPViewport2 Then
GoTo MAIN
Else
MsgBox "Select 1 viewport!", vbCritical, "ERROR"
ssetObj.Clear
GoTo SEL
End If

'MAIN PROCEDURE FOR COPYING LAYERSTATE
MAIN:
Set oSrcViewPort = entObj
'Get the Xdata from the Viewport
oSrcViewPort.GetXData "ACAD", XdataType, XdataValue

'Set the Xdata from Source Viewport to all other viewports in document
For Each oLayout In AcadDoc.Layouts
For Each ent In oLayout.Block
If TypeName(ent) = "IAcadPViewport2" Then
Set oTrgViewPort = ent
oTrgViewPort.SetXData XdataType, XdataValue
End If
Next
Next

' 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.

End Sub

[daniel.olives]

Hi I prefer this sub :
with case 2 object like viewport/polyline
Daniel OLIVES


Private Sub CopyLayerStateViewport()

Dim AcadDoc As AcadDocument
Dim ssetObj As AcadSelectionSet
Dim entObj As AcadObject
Dim oSrcViewPort As IAcadPViewport2
Dim oTrgViewPort As IAcadPViewport2
Dim oLayout As AcadLayout
Dim ent As AcadEntity
Dim XdataType As Variant
Dim XdataValue As Variant

Set AcadDoc = Application.ActiveDocument

'PROMPT COMMAND LINE
AcadDoc.Utility.Prompt ("-> Choose source viewport to copy layerstate from." & vbCrLf)

'SELECT SOURCE VIEWPORT
On Error Resume Next
Set ssetObj = AcadDoc.SelectionSets.item("SS1")
If Err Then
Set ssetObj = AcadDoc.SelectionSets.Add("SS1")
Err.Clear
Else
ssetObj.Clear
End If
On Error GoTo 0
SEL: ssetObj.SelectOnScreen

Dim ObjSel As AcadObject
Dim n As Integer
Dim Findviewport As Boolean

For n = 0 To ssetObj.Count - 1
'Check if selected object is viewport - polyline - 2 objets
Set entObj = ssetObj.item(n)
If TypeOf entObj Is IAcadPViewport2 Then
Findviewport = True
End If
Next

'CHECK SELECTION
If Findviewport Then
GoTo MAIN
Else
MsgBox "Retry and Select 1 viewport object!", vbCritical, "ERROR"
ssetObj.Clear
Exit Sub
End If

'MAIN PROCEDURE FOR COPYING LAYERSTATE
MAIN:
Set oSrcViewPort = entObj
'Get the Xdata from the Viewport
oSrcViewPort.GetXData "ACAD", XdataType, XdataValue

'Set the Xdata from Source Viewport to all other viewports in document
For Each oLayout In AcadDoc.Layouts
For Each ent In oLayout.Block
If TypeName(ent) = "IAcadPViewport2" Then
Set oTrgViewPort = ent
oTrgViewPort.SetXData XdataType, XdataValue
End If
Next
Next

' 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.

End Sub

[daniel.olives]

Hi this one is more correct for Xdata to LWPolyline of viewport:


Private Sub CopyLayerStateViewport()

Dim AcadDoc As AcadDocument
Dim ssetObj As AcadSelectionSet
Dim entObj As AcadObject
Dim oSrcViewPort As IAcadPViewport2
Dim oTrgViewPort As IAcadPViewport2
Dim oSrcLWpolyline As IAcadLWPolyline
Dim oTrgLWpolyline As IAcadLWPolyline
Dim oLayout As AcadLayout
Dim ent As AcadEntity
Dim XdataType As Variant
Dim XdataValue As Variant

Set AcadDoc = Application.ActiveDocument

'PROMPT COMMAND LINE
AcadDoc.Utility.Prompt ("-> Choose source viewport to copy layerstate from." & vbCrLf)

'SELECT SOURCE VIEWPORT
On Error Resume Next
Set ssetObj = AcadDoc.SelectionSets.item("SS1")
If Err Then
Set ssetObj = AcadDoc.SelectionSets.Add("SS1")
Err.Clear
Else
ssetObj.Clear
End If
On Error GoTo 0
SEL: ssetObj.SelectOnScreen

Dim ObjSel As AcadObject
Dim n As Integer
Dim Findviewport As Boolean

For n = 0 To ssetObj.Count - 1
'Check if selected object is viewport - polyline - 2 objets
Set entObj = ssetObj.item(n)
If TypeOf entObj Is IAcadPViewport2 Then
Findviewport = True
End If
Next

'CHECK SELECTION
If Findviewport Then
GoTo MAIN
Else
MsgBox "Retry and Select 1 viewport object!", vbCritical, "ERROR"
ssetObj.Clear
Exit Sub
End If

'MAIN PROCEDURE FOR COPYING LAYERSTATE
MAIN:
Set oSrcViewPort = entObj
'Get the Xdata from the Viewport
oSrcViewPort.GetXData "ACAD", XdataType, XdataValue

'Set the Xdata from Source Viewport to all other viewports in document
For Each oLayout In AcadDoc.Layouts
For Each ent In oLayout.Block
If TypeName(ent) = "IAcadPViewport2" Then
Set oTrgViewPort = ent
oTrgViewPort.SetXData XdataType, XdataValue
End If
If TypeName(ent) = "IAcadLWPolyline" Then
Set oTrgLWpolyline = ent
oTrgLWpolyline.SetXData XdataType, XdataValue
End If
Next
Next

' 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.

End Sub

[jwanstaett]

You can try this form
it use the sendcomand function of VBA
it let you select witch Layout
to FREEZING or THAWN layer in

you can this one layout or all layout
and use will card to match layer

the zip file has a form file in it load the form in to vba and run it

note: I have use the form in adt3.3 2000 and 2007 ref my need change in it