VP Freeze a Xref layer in a specific layout...

[Dubweisertm]

Hi everybody !

Im very new to VBA for autocad, I searched on this site but no corresponding subject.

I want to VP Freeze a Xref layer in a specific layout with a VBA Macro...

Layer name: 88888 - Module A|Details
Layout name: Production (3 viewports within)

Is someone could help me ?

Thanks in advance !

[christian.montagnac]

Hi,

What do you mean "VP" freeze?

To freeze or unfreeze a Layer "sLayerName" in the current active document just try the following sub, no matter the layout name is.





Sub SetLayerFreeze(sLayerName As String, bFreeze As Boolean)
On Error GoTo ErrorHandler
ActiveDocument.Layers(sLayerName).Freeze = bFreeze
Exit Sub
ErrorHandler:
MsgBox ("Layer " & sLayerName & " does not exist in current active document")
End Sub

[Dubweisertm]

VP Freeze: Used to freeze layer only in a specific viewport...

Please check the printscreen attached !

[Opie]

How many viewports are in the desired layout? If more than one, do you want it frozen in all or just a select few?

[Dubweisertm]

How many viewports are in the desired layout? If more than one, do you want it frozen in all or just a select few?
I want to do that in all viewports whitin the layout...

[Dubweisertm]

After searching on many sites, I think it will be better to do that in LISP !

I want to vpfreeze layer in all viewports whitin a specific layout via model space...

I dont want to have to select the viewport.

Is someone could help me ?

Thanks again !

[jwanstaett]

look here http://forums.augi.com/showthread.php?t=79882

I

[Dubweisertm]

As I said, Im trying to do that in LISP, I will ask my question on the good sub-forum

I saw on many site that VBA will "die" after Autocad 2011

Thank you anaway ;)

[fixo]

As I said, Im trying to do that in LISP, I will ask my question on the good sub-forum

I saw on many site that VBA will "die" after Autocad 2011

Thank you anaway ;)

Give this a shot


(vl-load-com)
(defun C:demo(/ adoc layername layout layoutname layouts)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
layouts (vla-get-layouts adoc)
layoutname "Production" ;<-- layout name
layername "88888 - Module AllDetails" ;<-- layer name
)
(setq layout (vla-item layouts layoutname))
(vla-put-activelayout adoc layout)
(vl-cmdf "._vplayer" "_f" layername "_a" "") ; <-- freeze in all viewports
(princ)
)


~'J'~

[Opie]

fixo, doesn't that freeze it in all viewports within the drawing and not just the ones on the current layout?

[christian.montagnac]

Hi

As remarked by Opie the previous Lisp function freezes all viewports in the drawing and not only those belonging to the considered layout, but it drives me to the following VBA solution, which works nice for me. (I'm not easy with Lisp)

Give me feedback please...

Christian




Sub Test()
Call VPFreeze(ActiveDocument, "Présentation2", "calque1,calque2,calque3", True)
End Sub

'Sub to freeze (or thaw) layers in all PViewports of a single layout
'
'aDoc is an open AcadDocument
'alayoutName is the name of the pviewports layout
'LayerNames may be a list of names separated by commas (ex: "Layer1,Layer2,Layer3")
'bFreeze = True => Freeze the layers False: Thaw the layers
'Usage example : Call VPFreeze(ActiveDocument, "Sheet2", "Layer1,Layer2,Layer3", False)
'
Sub VPFreeze(aDoc As AcadDocument, aLayoutName As String, LayerNames As String, bFreeze As Boolean)
Dim CmdAcad As String
Dim aLayout As AcadLayout
Dim aEntity As AcadEntity
Dim aPViewport As AcadPViewport
Dim LastActivePViewport As AcadPViewport
Dim LastActiveLayout As AcadLayout

On Error Resume Next
'Memorize active layout and active pviewport
Set LastActiveLayout = aDoc.ActiveLayout
Set LastActivePViewport = aDoc.ActivePViewport

'Set aLayoutName the active layout
Set aLayout = aDoc.Layouts(aLayoutName)
If Err <> 0 Then
MsgBox ("Layout " & aLayoutName & " doesn't exist")
GoTo SubEnd
End If
'Layout should not be the model layout
If aLayout.ModelType Then
MsgBox ("Layout " & aLayoutName & " is modeltype")
GoTo SubEnd
End If
'Activate the layout
aDoc.ActiveLayout = aLayout
'Set the command to freeze the layers in the list
CmdAcad = "._vplayer" & vbCr & "_f" & vbCr & LayerNames & vbCr & "_c" & vbCr & vbCr
'If bFreeze=false, set the command to thaw the layers '(replace _f with _t in the command)
If Not bFreeze Then CmdAcad = Replace(CmdAcad, "_f", "_t")

'Loop through layout entities
For Each aEntity In aLayout.Block
'if entity is a pviewport
If TypeOf aEntity Is AcadPViewport Then
Set aPViewport = aEntity
'Display the pviewport
aPViewport.Display (True)
ShowError
'Switch to model space
aDoc.MSpace = True
ShowError
'Activate the pviewport
aDoc.ActivePViewport = aPViewport
If Err = 0 Then
'Send the acad command vplayer
aDoc.SendCommand (CmdAcad)
Else
ShowError
End If
'Update the pviewport
aPViewport.Update
End If
Next
SubEnd:
'Restore previous active layout and active pviewport
aDoc.ActiveLayout = LastActiveLayout
aDoc.ActivePViewport = LastActivePViewport
End Sub

Sub ShowError()
If Err <> 0 Then
Call MsgBox(Err.Description, vbCritical + vbOKOnly)
Err.Clear
End If
End Sub

[Opie]

Are you making sure the layers you pass to vplayer exist prior to sending them to the command? vplayer doesn't like it when they do not exist. I've also done something similar in LISP for the OP.

[christian.montagnac]

You're right Opie

Following the adjusted VBA code (Function LayersExist added)

Thanks also for the link to an Autolisp version, even if I'm not easy with this language :-(...




Sub Test()
Call VPFreeze(ActiveDocument, "Présentation2", "calque1,calque2,calque3", True)
End Sub

'Sub to freeze (or thaw) layers in all PViewports of a single layout
'
'aDoc is an open AcadDocument
'alayoutName is the name of the pviewports layout
'LayerNames may be a list of names separated by commas (ex: "Layer1,Layer2,Layer3")
'bFreeze = True => Freeze the layers False: Thaw the layers
'Usage example : Call VPFreeze(ActiveDocument, "Sheet2", "Layer1,Layer2,Layer3", False)
'
Sub VPFreeze(aDoc As AcadDocument, aLayoutName As String, LayerNames As String, bFreeze As Boolean)
Dim CmdAcad As String
Dim aLayout As AcadLayout
Dim aEntity As AcadEntity
Dim aPViewport As AcadPViewport
Dim LastActivePViewport As AcadPViewport
Dim LastActiveLayout As AcadLayout

On Error Resume Next
'Memorize active layout and active pviewport
Set LastActiveLayout = aDoc.ActiveLayout
Set LastActivePViewport = aDoc.ActivePViewport

'Set aLayoutName the active layout
Set aLayout = aDoc.Layouts(aLayoutName)
If Err <> 0 Then
MsgBox ("Layout " & aLayoutName & " doesn't exist")
GoTo SubEnd
End If
'Layout should not be the model layout
If aLayout.ModelType Then
MsgBox ("Layout " & aLayoutName & " is model type")
GoTo SubEnd
End If
'Verify existence of all layers in the list
If Not LayersExist(aDoc, LayerNames) Then GoTo SubEnd

'Activate the layout
aDoc.ActiveLayout = aLayout
'Set the command to freeze the layers in the list
CmdAcad = "._vplayer" & vbCr & "_f" & vbCr & LayerNames & vbCr & "_c" & vbCr & vbCr
'If bFreeze=false, set the command to thaw the layers '(replace _f with _t in the command)
If Not bFreeze Then CmdAcad = Replace(CmdAcad, "_f", "_t")

'Loop through layout entities
For Each aEntity In aLayout.Block
'if entity is a pviewport
If TypeOf aEntity Is AcadPViewport Then
Set aPViewport = aEntity
'Display the pviewport
aPViewport.Display (True)
ShowError
'Switch to model space
aDoc.MSpace = True
ShowError
'Activate the pviewport
aDoc.ActivePViewport = aPViewport
If Err = 0 Then
'Send the acad command vplayer
aDoc.SendCommand (CmdAcad)
End If
ShowError
'Update the pviewport
aPViewport.Update
ShowError
End If
Next
SubEnd:
'Restore previous active layout and active pviewport
aDoc.ActiveLayout = LastActiveLayout
aDoc.ActivePViewport = LastActivePViewport
End Sub

'Very simple ErrorHandler to be adapted if necessary
Sub ShowError()
If Err <> 0 Then
Call MsgBox(Err.Description, vbCritical + vbOKOnly)
Err.Clear
End If
End Sub

Function LayersExist(aAcadDocument As AcadDocument, LayerNames As String) As Boolean
Dim V As Variant
Dim I As Integer
Dim aLayer As AcadLayer

On Error Resume Next

'Initialise the return value (for lisibility only, false is the default value)
LayersExist = False
'If list not empty
If Trim(LayerNames) <> "" Then
'Split the layers list, layer names separated by commas
V = Split(LayerNames, ",")
For I = LBound(V) To UBound(V)
'Try to access the layer
Set aLayer = aAcadDocument.Layers(Trim(V(I)))
If Err <> 0 Then
Call MsgBox("Layer " & Trim(V(I)) & " doesn't exist in " & aAcadDocument.Name, _
vbExclamation + vbOKOnly)
'At least one layer is missing, so exit and return false.
Exit Function
End If
Next
'Accessing this line means all layers exist
LayersExist = True
End If
End Function