---

Hallo,

ich möchte per VBA für alle Layer in einem Layout-Ansichtsfenster die Eigenschaft "Layer in Anischtsfenster frieren" auf getaut setzen - sprich nicht frieren.
Mit VBA ist das sehr umsändlich, da diese Eigenschaft im Layer-Objekt nicht enthalten ist und man einen Umweg über die XDaten machen muss.
Bis hierhin kein Problem, nur leider funktioniert der untenstehende Code nicht, d.h. es gibt keine Veränderung am Layerstatus.

Code:

---

Sub ThawAllLayInViewP() 'alle Layer in Ansichtsfenster tauen
Dim xType As Variant, xData As Variant

ThisDrawing.ActivePViewport.GetXData "ACAD", xType, xData

If xData(1) = "MVIEW" Then  'nur zur Sicherheit
  xType(30) = 1002
  xData(30) = "}"
  xType(31) = 1002
  xData(31) = "}"

  ReDim Preserve xType(31)
  ReDim Preserve xData(31)
 
  ThisDrawing.ActivePViewport.SetXData xType, xData
End If
End Sub

---

Kann mir jemand helfen bitte? Wo liegt der Fehler oder läuft es etwa sogar auf anderen Rechnern.

Ich habe auch schon ein Makro, das einzelne Layer im Ansichtsfenster friert. Gibt es zufäälig schon eine erweiterte Version, wo bestimmte Layer anhand einer Liste (optimalerweise mit Wildcards) oder eines Userforms im Ansichtsfenster gefroren werden können.

Vielen Dank

Stephan

[System: Win XP, ACAD 2005]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

ich sollte noch was zur Funktion das Makros schreiben:

in den XDaten stehen ab Feld 30 alle Layer, die im aktuellen Ansichtsfenster gefroren sind mit dem dazugehörenden Wert 1003, die letzten 2 Felder enthalten eine "}" und den Code 1002.
Also schreiben ich einfach in die Felder 30 und 31 die Werte für die letzten 2 Feldern, redimensioniere die Datenfelder und schreibe die XDaten

..soweit zur Theorie - die Praxis lässt sich davon leider noch nicht überzeugen 

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Stephan,

Zum Tauen von Layern im Ansichtsfenster findest du hier ein Beispiel.
Zum Frieren von Layern im Ansichtsfenster findest du hier ein Beispiel.

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke, genau das was ich gesucht habe!

Ich habe erst morgen Zeit, den Code zu testen, aber nach dem ersten Überfliegen ist es wohl so, dass die XDaten zum Schluss in ein neues Ansichtsfenster geschrieben werden müssen (das die Abmessungen des alten übernimmt).

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Vielleicht verstehe ich ja gerade etwas nicht, aber warum geht man den - in meinen Augen umständlichen Weg - über die XDaten?

Ein LayerObjekt in VBA kennt doch die Eigenschaft 'Freeze', welche man nur auf True oder False setzen muss.

Code:

---

    Dim oLayer As AcadLayer
   
    For Each Layer In ThisDrawing.Layers
   
        If Not Layer.Name = "0" Then
                Layer.Freeze = True
        End If
           
    Next

---

Viele Grüssle Lars

------------------

"Soll es funktionieren oder darf es auch etwas von Siemens sein?" ...

http://validator.w3.org/check?uri=http://ww3.cad.de/cgi-bin/ubb/Ultimate.cgi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Lars,

Stephan möchte die Layer im aktuellen Ansichtsfenster des Papierbreichs tauen. Dort kannst du nur über den Umweg Xdata rankommen. Schau die mal den Layermanager an, dort kannst du die Layer frieren und separat, wenn du in einem aktiven Ansichtsfenster bist, kannst für diese Fenster separate Einstellungen treffen. Und darum geht es hier.

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ist natürlich schlecht, wenn man damit noch nie gearbeitet hat und sich den Layermanager nur halbherzig anschaut.

Danke und Grüssle Lars

------------------

"Soll es funktionieren oder darf es auch etwas von Siemens sein?" ...

http://validator.w3.org/check?uri=http://ww3.cad.de/cgi-bin/ubb/Ultimate.cgi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,
da ich oft mit den Expresstools in Asichtsfenstern Layer isoliere (sie werden dabei nur gefroren nicht ausgeschaltet) um Einzelteilprofile zu erzeugen, interessiert mich dieses Thema sehr.
Das Tool auf das Carsten verwiesen hatte, macht auf meinem Rechner gar nichts (der Status aller Layer bleibt unverändert.
Wie ist denn der Stand der Dinge?
MfG
Paul

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

bei mir läuft es ohne Probleme:

Nochmal zum Verständnis - es geht darum, im Modellbereich eines Layout einzelne Layer zu frieren/tauen (also "im Anichtsfenster").
Du muss also ins Anischtsfenster wechslen und dort das Makro "selectVPobjectsToFreeze()" starten, anschließend Objekte auf den zu frierenden Layern auswählen und schwupps sind sie weg.

Bist du wirklich im Ansichtsfenster, wenn du das Makro startest? Gibt es irgendwelche Fehlermeldungen? Setz doch zur Not mal einen Breakpoint und geht das Makro zeilenweise durch.

Was ich anfangs übersehen hatte, ist dass du das Ansichtsfenster aktualisieren musst. Zitat aus dem Quelltext:

Zitat:

---

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

---

.. aber ViewPortUpdate() wird im Makro ja normalerweise auch aufgerufen...

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

das "Frieren-Makro" habe ich nicht getestet, das funktioniert, wie gesagt, mit den Express-Tools "layiso" ohne Probleme. Nur das tauen aller Layer explizit  für das gewählte Fenster im Layout wäre schön.

MfG
Paul

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,
inzwischen habe ich ein wenig ein wenig probiert und den CODE so umgestrickt, das die Layer nacheinander getaut werden, so lange ich auf den Fensterrahmen klicke. Hat jemand eine Idee das zu verbessern.
Aber Vorsicht wenn VPort.Delete aus der äußeren For-Next-Schleife genommen wird, werden so viel übereinander liegende Ansichtsfenter wie Layer erzeugt.

Sub VpLayerTauen()
    Dim strLayer As String
    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
    Dim LayerListe As AcadLayers
    Dim LayerObj As AcadLayer
    Dim objPViewport As AcadPViewport
    Dim strPrompt As String
    Set LayerListe = ThisDrawing.Layers
    If LayerListe.Count = 0 Then Exit Sub
    If ThisDrawing.ActiveSpace = acModelSpace Then
        MsgBox "Bitte in den Papierbereich wechseln und nochmal versuchen", vbCritical
        Exit Sub
    End If
    ThisDrawing.MSpace = False
    For Each LayerObj In LayerListe
        strLayer = LayerObj.Name
        ThisDrawing.Utility.GetEntity objPViewport, PT1, "Select ViewPort:"
        objPViewport.GetXData "ACAD", XdataType, XdataValue
        For I = LBound(XdataType) To UBound(XdataType)
            If XdataType(I) = 1003 Then
                Counter = I + 1
                If UCase(XdataValue(I)) = UCase(strLayer) Then Exit For
            End If
        Next
        If Counter = 0 Then Exit Sub
        dblWidth = objPViewport.Width
        dblHeight = objPViewport.Height
        varCenter = objPViewport.Center
        newXdataType = XdataType
        newXdataValue = XdataValue
        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
        Set objViewPortNew = ThisDrawing.PaperSpace.AddPViewport(varCenter, dblWidth, dblHeight)
        objViewPortNew.SetXData newXdataType, newXdataValue
        objViewPortNew.Layer = objPViewport.Layer
        ThisDrawing.MSpace = False
        objViewPortNew.Display (False)
        objViewPortNew.Display (True)
        ThisDrawing.Utility.Prompt ("Done!" & vbCr)
        objPViewport.Delete
    Next
End Sub

MfG
Paul

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Würde nicht vielleicht ein

Code:

---

Sub AFLayerTauen()
  ThisDrawing.SendCommand ("_VPLAYER" & vbCr & "_Thaw" & vbCr & "*" _
  & vbCr & "_Current" & vbCr & vbCr)
End Sub

---

reichen ?

------------------
Mit freundlichem Gruß

Udo Hübner

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

ja das reicht mir für meine Zwecke vollkommen.

Vielen Dank

MfG

Paul

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP