---

Hallo,

ich bin vor kurzem von AutoCAD 2009 auf AutoCAD 2011 umgestiegen.

Ich habe ein VBA-Makro, welches Geometrie in eine Datei speichert, diese dann
öffnet, einige Anpassungen vornimmt und die Datei als im DXF-Format abspeichert.

Dieser Code dient zum öffnen der Datei:

    ThisDrawing.Application.Documents.Open Dateiname

und genau an dieser Stelle bricht das Makro ab.

Kann mir hier jemand einen Tip geben, wieso der Code in AutoCAD 2011
nicht mehr funktioniert?

Leider gibt es in AutoCAD 2011 ja auch keine Hilfe für VBA mehr. Oder kann
ich diese separat installieren?

Freue mich über jeden Tipp.

Gruß
Stefan

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

---

Bisserl dürftig die Fragestellung um wirklich helfen zu können...

ein

Code:

---

Sub test()
Dim dateiname$

dateiname = "D:\ACAD\Zeichnungen\Zeichnung2.dwg"
ThisDrawing.Application.Documents.Open dateiname

End Sub

---

funktioniert auch unter ACAD 2011. Eben getestet.

Du bist dran: Was ist an Deinem code anders?

[rredit] ein Vögelchen zwitscherte mir das Stichwort SDI zu [/rredit]

VBA-Hilfe: Stell Dich im VBA-Modul auf ein Schlüsselwort und drück von dort aus auf F1, damit hast Du zuminest mal die Visual Basic Referenz oder nimm die alte Hilfe.

------------------
Gruß,
runkelruebe          Herr Kann-ich-nich wohnt in der Will-ich-nich-Straße...

[Diese Nachricht wurde von runkelruebe am 17. Feb. 2012 editiert.]

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

---

Hallo runkeruebe,

ja Du hast recht. Mit dem Codeschnipsel ist das Problem wohl nicht zu erkären/beheben.

Der Gesamtcode soll eine ausgewählter Geometrie aus einer DWG in eine neue Zeichnung speichern,
in diese Zeichnung die Positionsnummer reinschreiben, den erzeugten Text sprengen, ein Flatten Objects ausführen,
die Datei dann als DXF-Datei speichern und die DWG-Datei dann löschen.

Hier mal der Code (der so schon Jahrelang in AutoCAD 2009 funktioniert):

Private Sub btnWBlock_Click()
'Positionstext einfügen
    Dim textObj As AcadText
    Dim Positionsnummer As String
    Dim Zielverzeichnis As String
    Dim insertionPoint(0 To 2) As Double
    Dim height As Double
   
On Error GoTo 20

    Dim Layername As String
    Dim currLayer As AcadLayer
    Dim newLayer As AcadLayer
    'Aktuellen Layer erfragen
    Set currLayer = ThisDrawing.ActiveLayer
    Layername = "0"
    Set newLayer = ThisDrawing.Layers(Layername)
    ThisDrawing.ActiveLayer = newLayer

  'Erstellen des Textobjekts
    Zielverzeichnis = Me.txtZielverzeichnis.Value
    Positionsnummer = Me.txtPosNr.Value
    insertionPoint(0) = 0
    insertionPoint(1) = 0
    insertionPoint(2) = 0
    insertionPointUCS = ThisDrawing.Utility.TranslateCoordinates(insertionPoint, acUCS, acWorld, False)
    height = 30
    Set textObj = ThisDrawing.ModelSpace. _
        AddText(txtPositionsnummer, insertionPointUCS, height)
    textObj.Update
   
  'Text drehen
    Dim Textwinkel As Double
    Textwinkel = 45
    textObj.Rotate insertionPointUCS, Textwinkel
    textObj.Alignment = acAlignmentCenter
    textObj.TextAlignmentPoint = insertionPointUCS
    textObj.Update
    Dim Test As String

    Set ssetObj = ThisDrawing.SelectionSets.Add("Test")
   
   
    Dim Dateiname As String
   
    Dateiendung = ".dwg"
    Zielverzeichnis = Zielverzeichnis + "\"
    Dateiname = Zielverzeichnis + Positionsnummer
   
Me.Hide

    ssetObj.SelectOnScreen
    ThisDrawing.Wblock Dateiname, ssetObj
    ThisDrawing.Application.Documents.Open Dateiname
       
    Set newLayer = ThisDrawing.Layers.Add("Gravur")
    ThisDrawing.ActiveLayer = newLayer
    ThisDrawing.SendCommand "txtexp" & vbCr & "all" & vbCr & vbCr          'sprengt allen Text
   
    'Abfrage für drehen der Objekte
    If btnDrehen = False Then GoTo 30 Else
   
    Dim basePoint(0 To 2) As Double
    Dim rotationAngle As Double
   
    basePoint(0) = 0: basePoint(1) = 0: basePoint(2) = 0
    rotationAngle = 0.7853981 * 2 ' 90 degrees

    'Iterate through the model space collection and add
    'each item found to an array of objects
    ReDim objsInModelSpace(0 To ThisDrawing.ModelSpace.Count - 1) As AcadEntity
    Dim I As Integer
   
    For I = 0 To ThisDrawing.ModelSpace.Count - 1
    Set objsInModelSpace(I) = ThisDrawing.ModelSpace.Item(I)
    Next
   
    For I = 0 To ThisDrawing.ModelSpace.Count - 1
    objsInModelSpace(I).Rotate basePoint, rotationAngle
    objsInModelSpace(I).Update
    Next
   
    Dim ssetObj2 As AcadSelectionSet
    Set ssetObj2 = ThisDrawing.SelectionSets.Add("3")
    Dim mode As Integer
    mode = acSelectionSetAll
    ssetObj2.Select mode
   
    ThisDrawing.SendCommand "Flatten" & vbCr & "all" & vbCr & vbCr & vbCr  'führt Flatten Objects aus
    ThisDrawing.SendCommand "-Overkill" & " all" & " " & vbCr & vbCr  'löscht doppelte Elemente
    ThisDrawing.PurgeAll
    ThisDrawing.AuditInfo True
    ThisDrawing.SaveAs Dateiname, acR15_dxf
    'ThisDrawing.Export Dateiname, "DXF", ssetObj2
    ssetObj2.Delete
    GoTo 40
30:
   
    ThisDrawing.SendCommand "Flatten" & vbCr & "all" & vbCr & vbCr & vbCr  'führt Flatten Objects aus
    ThisDrawing.SendCommand "-Overkill" & " all" & " " & vbCr & vbCr  'löscht doppelte Elemente
    ThisDrawing.PurgeAll
    ThisDrawing.AuditInfo True
    ThisDrawing.SaveAs Dateiname, acR15_dxf
    'ThisDrawing.Export Dateiname, "DXF", ssetObj2
40:
    ThisDrawing.Close
   
   
    Kill Dateiname + ".dwg"
    Kill Dateiname + ".bak"
   
    'ssetObj.RemoveItems objsInModelSpace
   
20:

    'Clear the selection set
    ssetObj.Delete

10:
    ThisDrawing.ActiveLayer = currLayer
   
End Sub

Ich würde gerne mal wisse, wieso dass auf einmal in AutoCAD 2011 nicht mehr funktioniert.
Wie man an dem Code sieht, bin ich kein Programmierer. Ist wahrscheinlich viel zu umständlich...

Vielen Dank für weitere Tips

Gruß
Stefan

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

---

Problem gelöst!

Sorry ich habe das Problem selbst lösen können.

Früher hat VBA beim schreiben eines WBlocks die Dateiendung DWG automatisch
zum Dateinamen hinzugefügt. In AutoCAD 2011 wird die Endung nicht automatisch
hinzugefügt. Dadurch kann er die Datei nicht öffnen und bricht das Programm ab.
Ich hab den Code so ergänzt:

    Dim Dateiname As String
    Dim DWGDatei As String
    Zielverzeichnis = Zielverzeichnis + "\"
    Dateiname = Zielverzeichnis + Positionsnummer
    DWGDatei = Dateiname + ".dwg"
   
Me.Hide

    ssetObj.SelectOnScreen
    ThisDrawing.Wblock DWGDatei, ssetObj
    ThisDrawing.Application.Documents.Open DWGDatei

Trotzdem nochmal danke an runkelruebe für die schnelle Antwort.

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