---

Ansichten-in-Layouts.zip

Guten Tag,  

ich habe ein Problem, mit dem ich zur Zeit nicht weiterkomme.

Unzwar bekomme ich oft Dateien, wo die einzelnen Seiten als benannte Ansichten im Modelbereich gezeichnet sind.
Nun muss ich diese Seiten in Layouts umwandeln. Also erstelle ich ein Layout mit dem jeweiligen Blattnahmen, dann ein Ansichtsfenster im Layout und zu guter Letzt stelle ich im verschiebaren Modelbereich die zum Blatt passende benannte Ansicht wieder her. Das ist ab 20 Blättern nicht mehr ganz so prickelnd. Darum wollte ich die ganze Sache vollautomatisch mit einem VBA-Makro erschlagen      . Hänge jetzt aber an einer Stelle fest, wo mir nix mehr einfällt. Muss aber dazu sagen, ich bin auch kein Profi-VBA-Programmierer.

Eine DWG-Datei, in der Art wie ich sie bearbeiten muss ist im Anhang. Nachstehend habe ich den Quellcode aufgelistet, mit dem ich mich herumplage.
Über kleine Denkanstöße wäre ich sehr dankbar.     

Sub Ansichten()

'Deklarationen für benannte Ansichten
Dim ViewList As New Collection
Dim View As AcadView
Dim i As Long 'Zähler
Dim ViewName As String
Dim ViewportObj As AcadViewport
Dim Viewports As AcadViewports

ThisDrawing.ActiveSpace = acModelSpace

Set ViewportObj = ThisDrawing.ActiveViewport

Set Viewports = ThisDrawing.Viewports

'Deklarationen für Layouts
Dim Layout As AcadLayout
Dim Layouts As AcadLayouts
Dim NewLayout As AcadLayout

'Deklarationen für Ansichtsfenster in den Layouts
Dim pviewportObj As AcadPViewport
Dim center(0 To 2) As Double
Dim width As Double
Dim height As Double

'Ansichtsfenster für DIN A4 erstellen
    center(0) = 3: center(1) = 3: center(2) = 0
    width = 287
    height = 200

' Listet alle benannten Ausschnitte dieser Zeichnung auf
For Each View In ThisDrawing.Views
    ViewList.Add View
Next

For i = 1 To ViewList.Count
   
    ViewName = ViewList(i).Name
    Set NewLayout = ThisDrawing.Layouts.Add(ViewName)
   
Next

Set Layouts = ThisDrawing.Layouts

For Each Layout In Layouts

    If Layout.Name = "Model" Or Layout.Name = "Layout1" Or Layout.Name = "Layout2" Then
        GoTo Z1
    End If
   
    ThisDrawing.ActiveSpace = acPaperSpace
    ThisDrawing.ActiveLayout = Layout
       
    Set pviewportObj = ThisDrawing.PaperSpace.AddPViewport(center, width, height)
    pviewportObj.Display True
    ThisDrawing.MSpace = True
   
    Set View = ThisDrawing.Views(Layout.Name)
    ViewportObj.SetView View

    ThisDrawing.ActiveViewport = ViewportObj 'Ab geht's nicht weiter

    ThisDrawing.MSpace = False
    ThisDrawing.Regen acAllViewports
Z1: Next
   
End Sub

[Diese Nachricht wurde von Netwurm am 09. Sep. 2009 editiert.]

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

---

Hi,

>> Hänge jetzt aber an einer Stelle fest, wo mir nix mehr einfällt

...und die Stelle wäre?
Ich möchte nicht immer erst probieren müssen um auf die eigentliche Frage zu kommen. 

Der Rest mit Code und Zeichnung als Beispiel ist schon top  , aber eben der 'Punkt' dazu geht mir ab.

- alfred -

------------------
www.hollaus.at

---

Die Stelle ist :

ThisDrawing.ActiveViewport = ViewportObj 'Ab geht's nicht weiter

Steht kurz vorm Ende des Quellcodes.

[Diese Nachricht wurde von Netwurm am 09. Sep. 2009 editiert.]

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

---

Hi,

>> Die Stelle ist ...

nun, was soll ich dazu sagen? Hast es ja reingeschrieben und ich war nur zu oberflächlich beim Lesen.  
Eine bessere Ausrede von mir wäre gewesen: Ich lese nur in Verträgen Kleingedrucktes  

Hier die Änderung, hoffe es entspricht Deinem Wunsch (dass das Zoomen gefehlt hat). Tausche die Schleife aus und was darunter in Deinem Code ist, kannst Du entfernen, denn es wird jetzt bis hin zum Zoomen in dieser Schleife durchgemacht.

Code:

---

   For i = 1 To ViewList.Count
     
       ViewName = ViewList(i).Name
       Set NewLayout = ThisDrawing.Layouts.Add(ViewName)
      
         'und neu:
         ThisDrawing.ActiveLayout = NewLayout  'um eine stelle hinaufgeschoben, sonst geht '...ActiveSpace setzen nicht, wenn Du noch im Modelbereich stehst
         ThisDrawing.ActiveSpace = acPaperSpace

         'viewport erzeugen
         Set pviewportObj = ThisDrawing.PaperSpace.AddPViewport(center, width, height)
         pviewportObj.Display True
         ThisDrawing.MSpace = True

         'im ansichtsfenster zoomen, dazu mal die fensterkoordinaten aus View herausholen
         Dim tPnt1 As Variant
         tPnt1 = ViewList(i).center
         tPnt1(0) = tPnt1(0) - ViewList(i).width / 2#
         tPnt1(1) = tPnt1(1) - ViewList(i).height / 2#
         ReDim Preserve tPnt1(2)   'damit wird array of 3 doubles sichergestellt
         Dim tPnt2(2) As Double
         tPnt2(0) = tPnt1(0) + ViewList(i).width
         tPnt2(1) = tPnt1(1) + ViewList(i).height

         'und mit diesen Koordinaten jetzt zoomen
         Call ThisDrawing.Application.ZoomWindow(tPnt1, tPnt2)
        
         ThisDrawing.MSpace = False
         ThisDrawing.Regen acAllViewports
   Next

---

Keine Fehlerprüfung eingebaut!! Also solltest Du z.B. vorher noch testen, ob in der Zeichnung nicht schon ein Layout mit Deinem Zielnamen existiert.

HTH, - alfred -

------------------
www.hollaus.at

[Diese Nachricht wurde von a.n. am 09. Sep. 2009 editiert.]

---

      Es funktioniert super     

Vielen, vielen Dank für die schnelle Hilfe, auch von meinen Kollegen.   
Du hast uns eine Menge Arbeit abgenommen.
Danke auch für die Zoomfunktion, die Du netterweise eingebaut hast. Das wäre währscheinlich mein nächstes Problem gewesen.

Viele Grüße Netwurm

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