Inventor 2017 VBA Makro: Zeichnung IDW Export (exportieren) als DWG, PDF, DXF

[Anonymous]

Hi zusammen,

ich würde gerne ein Makro schreiben, das eine vorhandene Zeichnung .idw per Knopfdruck in folgenden Exportdateien ausspielt. Benötigt wird dwg, pdf, und dxf.

Ich habe bereits ein Makro, dass nur nicht ganz nach meinen Bedürfnissen passt und ich daher abändern möchte. Da ich mich in Makro Programmierung nicht auskenne, bin ich auf eure Hilfe angewiesen.

Im Prinzip würde ich dieses vorhandene Makro umschreiben, sodass die Dateinamen der Exportdateien in ein bestimmtes Format ausgegeben werden.

Denn bisher schreibt dieses Makro im folgendem Format:

B70017223_a_001.dwg

B70017223_a_001.pdf

B70017223_a_DBR.dxf

Abändern würde ich dieses Makro jedoch, dass es die Exportdateien mit folgenden iProperties bzw. Texten ausgibt:

Benutzderdef. iPropertie = Zeichnungsnummer

Benutzderdef. iPropertie = SAP-Nummer

Benutzderdef. iPropertie = Bezeichnung DE

Benutzderdef. iPropertie = Revision

Text = ~

Text = 2DDWG

Text = Blatt

Und das im folgenden Format für DWG Dateien:

=Wenn(„Zeichnungsnummer“=WAHR; [Dann „Zeichnungsnummer“]; [Sonst Nix]) oder =Wenn(„SAP-Nummer“=WAHR; [Dann „SAP-Nummer“]; [Sonst Nix]) & „~“ & „2DDWG“ & „~“ & „Bezeichnung DE“ & „~“ & „Blatt“ & „~“ & „Blattanzahl“ & „~“ & „Revision“

Als Beispiel würde es dann für die DWG´s so aussehen:

B49267528~2DDWG~Schweißteil~Blatt_01~a.dwg

Für die PDF´s sollte es dann so aussehen:

B49267528~2DPDF~Schweißteil~Blatt~01~a.pdf

Für die DXF´s sollte es dann so aussehen:

B49267528~2DSBR~Schweißteil~Blatt~01~a.pdf

Ich würde mich auf eure Unterstützung sehr freuen.  Unten habe ich noch das bereits erstelle Makro angehängt. Und im Anhang habe ich noch eine Zeichnung als Beispiel mit den oben genannten iProperties.

Public Const Makropfad = "C:\Tresor-LT-CAD\Verwaltung\Konstruktionsdaten Stile\DWG-DXF\"
    
Public Sub Export_DWG_DXF_PDF()
    On Error GoTo err:
    
    If ThisApplication.ActiveDocumentType <> kDrawingDocumentObject Then
        MsgBox "Funktion kann nur in einer Zeichung ausgeführt werden!", vbCritical
        Exit Sub
    End If
    
    
     Dim filesystem As Object
     Set filesystem = CreateObject("Scripting.FilesystemObject")
    
    'exportdwg.ini erstellen
    'ini für DWG
    Dim strIniFile As String
    strIniFile = Makropfad & "exportdwg.ini"
    Call iniSchreiber(strIniFile)
    
    'ini für DXF
    Dim strIniFiledxf As String
    strIniFiledxf = Makropfad & "exportdxf.ini"
    Call iniSchreiberdxf(strIniFiledxf)
    
    Call Update_Zeichnung
    
    Dim Doc As DrawingDocument
    Set Doc = ThisApplication.ActiveDocument
    
    Dateiname = FUNC.Speicherpfad(Doc)
           
'   Alle Blätter der IDW durchlaufen
'   Wenn Blattname <> "DBR" dann
'    Export als DWG mit Dateiname =  <IDW_Name>_<Blattname>.dwg
'    Export als PDF mit Dateiname =  <IDW_Name>_<Blattname>.pdf
'
'   Wenn Blattname = DBR UND Ansicht auf Blatt vorhanden (also nicht leer) dann Export als DXF
    
     Dim blatt As Sheet
     Dim Dateiname_ohne_ext As String
     Dim Dateiname_mit_Blatt_ohne_ext As String
     

     
     Dateiname_ohne_ext = filesystem.GetParentFolderName(Dateiname) & "\" & filesystem.GetBaseName(Dateiname)
     
     For Each blatt In Doc.Sheets
             blatt.Activate
             Dateiname_mit_Blatt_ohne_ext = Dateiname_ohne_ext & "_" & Left(blatt.Name, 3)
                 If Left(blatt.Name, 3) <> "DBR" Then
                    'Export aktuelles Blatt DWG Dateiname <IDW_Name>_<Blattname>.dwg
                        Dim DWGAddIn As TranslatorAddIn
                        Set DWGAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}")
            
                        Dim oContext As TranslationContext
                        Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
                        oContext.Type = kFileBrowseIOMechanism
            
                        Dim oOptions As NameValueMap
                        Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
            
                        Dim oDataMedium As DataMedium
                        Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
            
                        If DWGAddIn.HasSaveCopyAsOptions(Doc, oContext, oOptions) Then
                            oOptions.Value("Export_Acad_IniFile") = strIniFile
                        End If
            
                        oDataMedium.Filename = Dateiname_mit_Blatt_ohne_ext & ".dwg"
            
                        Call DWGAddIn.SaveCopyAs(Doc, oContext, oOptions, oDataMedium)
                    'Export aktuelles Blatt PDF Dateiname <IDW_Name>_<Blattname>.pdf
                    
                        Dim PDFAddIn As TranslatorAddIn
                        Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
                    
                        'Set a reference to the active document (the document to be published).
                               
                        Dim oContextpdf As TranslationContext
                        Set oContextpdf = ThisApplication.TransientObjects.CreateTranslationContext
                        oContextpdf.Type = kFileBrowseIOMechanism
                    
                        ' Create a NameValueMap object
                        Dim oOptionspdf As NameValueMap
                        Set oOptionspdf = ThisApplication.TransientObjects.CreateNameValueMap
                    
                        ' Create a DataMedium object
                        Dim oDataMediumpdf As DataMedium
                        Set oDataMediumpdf = ThisApplication.TransientObjects.CreateDataMedium
                    
                        ' Check whether the translator has 'SaveCopyAs' options
                        If PDFAddIn.HasSaveCopyAsOptions(Doc, oContextpdf, oOptionspdf) Then
                    
                            ' Options for drawings...
                    
                            oOptionspdf.Value("All_Color_AS_Black") = 1
                    
                            'oOptions.Value("Remove_Line_Weights") = 0
                            oOptionspdf.Value("Vector_Resolution") = 400
                            oOptionspdf.Value("Sheet_Range") = kPrintCurrentSheet
                            'oOptions.Value("Custom_Begin_Sheet") = 2
                            'oOptions.Value("Custom_End_Sheet") = 4
                        End If
                    
                        'Set the destination file name
                        oDataMediumpdf.Filename = Dateiname_mit_Blatt_ohne_ext & ".pdf"
                    
                        'Publish document.
                        Call PDFAddIn.SaveCopyAs(Doc, oContextpdf, oOptionspdf, oDataMediumpdf)
    
         End If
     
             If Left(blatt.Name, 3) = "DBR" And blatt.DrawingViews.Count <> 0 Then
                'Export als DXF Dateiname <IDW_Name>.dxf
                Dim DXFAddIn As TranslatorAddIn
                Set DXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
        
                Dim oContextdxf As TranslationContext
                Set oContextdxf = ThisApplication.TransientObjects.CreateTranslationContext
                oContextdxf.Type = kFileBrowseIOMechanism
                
                Dim oOptionsdxf As NameValueMap
                Set oOptionsdxf = ThisApplication.TransientObjects.CreateNameValueMap
                
                Dim oDataMediumdxf As DataMedium
                Set oDataMediumdxf = ThisApplication.TransientObjects.CreateDataMedium
        
        
                If DXFAddIn.HasSaveCopyAsOptions(Doc, oContextdxf, oOptionsdxf) Then
                        
                    ' Create the name-value that specifies the ini file to use.
                    oOptionsdxf.Value("Export_Acad_IniFile") = strIniFiledxf
                End If
                
                oDataMediumdxf.Filename = Dateiname_mit_Blatt_ohne_ext & ".dxf"
                
                Call DXFAddIn.SaveCopyAs(Doc, oContextdxf, oOptionsdxf, oDataMediumdxf)
        
             End If
    
     Next
     
     '29.10.2015 Blatt 1 aktivieren
     Doc.Sheets.Item(1).Activate
GoTo ende
err:
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFile = fso.CreateTextFile(FUNC.Speicherpfad(ThisApplication.ActiveDocument) & ".FEHLER!")
    oFile.WriteLine "Es ist ein Problem aufgetreten"
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing
ende:
End Sub

Sub Update_Zeichnung()
On Error GoTo err:
Dim Doc As Document
Set Doc = ThisApplication.ActiveDocument
If FUNC.Doktyp(Doc) = "Zeichnung" Then

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    
    Call oDrawDoc.Update2(True)
    
    Dim osheet As Sheet
    Set osheet = oDrawDoc.ActiveSheet
    Dim oView As DrawingView
    For Each oView In osheet.DrawingViews
        oView.IsRasterView = False
    Next
    'oDrawdoc.Save2 (True)
End If
err:
End Sub

Sub iniSchreiber(iniPfad As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    If fso.FileExists(iniPfad) = False Then
        Set oFile = fso.CreateTextFile(iniPfad)
        '----------------------------------
        oFile.WriteLine "[EXPORT SELECT OPTIONS]"
        oFile.WriteLine "AUTOCAD VERSION=AutoCAD 2007"
        oFile.WriteLine "CREATE AUTOCAD MECHANICAL=No"
        oFile.WriteLine "USE TRANSMITTAL=No"
        oFile.WriteLine "USE CUSTOMIZE=No"
        oFile.WriteLine "CUSTOMIZE FILE=" & Makropfad & "FlatPattern.xml"
        oFile.WriteLine "CREATE LAYER GROUP=No"
        oFile.WriteLine "PARTS ONLY=No"
        oFile.WriteLine "REPLACE SPLINE=No"
        oFile.WriteLine "CHORD TOLERANCE=0.001000"
        oFile.WriteLine "[EXPORT PROPERTIES]"
        oFile.WriteLine "SELECTED PROPERTIES="
        oFile.WriteLine "[EXPORT DESTINATION]"
        oFile.WriteLine "SPACE=Model"
        oFile.WriteLine "SCALING=Geometry"
        oFile.WriteLine "ALL SHEETS=No"
        oFile.WriteLine "MAPPING=LooksBest"
        oFile.WriteLine "MODEL GEOMETRY ONLY=No"
        oFile.WriteLine "EXPLODE DIMENSIONS=No"
        oFile.WriteLine "SYMBOLS ARE BLOCKED=Yes"
        oFile.WriteLine "AUTOCAD TEMPLATE=" & Makropfad & "exportdwg.dwg"
        oFile.WriteLine "DESTINATION DXF=No"
        oFile.WriteLine "USE ACI FOR ENTITIES AND LAYERS=Yes"
        oFile.WriteLine "[EXPORT LINE TYPE & LINE SCALE]"
        oFile.WriteLine "LINE TYPE FILE=" & Makropfad & "InvDIN.lin"
        oFile.WriteLine "Continuous=Continuous;1."
        oFile.WriteLine "Dashed=DASHED;1."
        oFile.WriteLine "Dashed Space=DASHED_SPACE;1."
        oFile.WriteLine "Long Dash Dotted=LONG_DASH_DOTTED;1."
        oFile.WriteLine "Long Dash Double Dot=LONG_DASH_DOUBLE_DOT;1."
        oFile.WriteLine "Long Dash Triple Dot=LONG_DASH_TRIPLE_DOT;1."
        oFile.WriteLine "Dotted=DOTTED;1."
        oFile.WriteLine "Chain=CHAIN;1."
        oFile.WriteLine "Double Dash Chain=DOUBLE_DASH_CHAIN;1."
        oFile.WriteLine "Dash Dot=DASH_DOT;1."
        oFile.WriteLine "Double Dash Dot=DOUBLE_DASH_DOT;1."
        oFile.WriteLine "Double Dash Double Dot=DOUBLE_DASH_DOUBLE_DOT;1."
        oFile.WriteLine "Dash Triple Dot=DASH_TRIPLE_DOT;1."
        oFile.WriteLine "Double Dash Triple Dot=DOUBLE_DASH_TRIPLE_DOT;1."
        '----------------------------------
        oFile.Close
    End If
    Set fso = Nothing
    Set oFile = Nothing
End Sub

Sub iniSchreiberdxf(iniPfad As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    If fso.FileExists(iniPfad) = False Then
        Set oFile = fso.CreateTextFile(iniPfad)
        '----------------------------------
        oFile.WriteLine "[EXPORT SELECT OPTIONS]"
        oFile.WriteLine "AUTOCAD VERSION=AutoCAD 2000"
        oFile.WriteLine "CREATE AUTOCAD MECHANICAL=No"
        oFile.WriteLine "USE TRANSMITTAL=No"
        oFile.WriteLine "USE CUSTOMIZE=No"
        oFile.WriteLine "CUSTOMIZE FILE=" & Makropfad & "FlatPattern.xml"
        oFile.WriteLine "CREATE LAYER GROUP=No"
        oFile.WriteLine "PARTS ONLY=No"
        oFile.WriteLine "REPLACE SPLINE=No"
        oFile.WriteLine "CHORD TOLERANCE=0.001000"
        oFile.WriteLine "[EXPORT PROPERTIES]"
        oFile.WriteLine "SELECTED PROPERTIES="
        oFile.WriteLine "[EXPORT DESTINATION]"
        oFile.WriteLine "SPACE=Model"
        oFile.WriteLine "SCALING=Geometry"
        oFile.WriteLine "ALL SHEETS=No"
        oFile.WriteLine "MAPPING=LooksBest"
        oFile.WriteLine "MODEL GEOMETRY ONLY=No"
        oFile.WriteLine "EXPLODE DIMENSIONS=No"
        oFile.WriteLine "SYMBOLS ARE BLOCKED=Yes"
        oFile.WriteLine "AUTOCAD TEMPLATE="
        oFile.WriteLine "DESTINATION DXF=Yes"
        oFile.WriteLine "USE ACI FOR ENTITIES AND LAYERS=Yes"
        oFile.WriteLine "[EXPORT LINE TYPE & LINE SCALE]"
        oFile.WriteLine "LINE TYPE FILE=" & Makropfad & "InvDIN.lin"
        oFile.WriteLine "Continuous=Continuous;0."
        oFile.WriteLine "Dashed=DASHED;0."
        oFile.WriteLine "Dashed Space=DASHED_SPACE;0."
        oFile.WriteLine "Long Dash Dotted=LONG_DASH_DOTTED;0."
        oFile.WriteLine "Long Dash Double Dot=LONG_DASH_DOUBLE_DOT;0."
        oFile.WriteLine "Long Dash Triple Dot=LONG_DASH_TRIPLE_DOT;0."
        oFile.WriteLine "Dotted=DOTTED;0."
        oFile.WriteLine "Chain=CHAIN;0."
        oFile.WriteLine "Double Dash Chain=DOUBLE_DASH_CHAIN;0."
        oFile.WriteLine "Dash Dot=DASH_DOT;0."
        oFile.WriteLine "Double Dash Dot=DOUBLE_DASH_DOT;0."
        oFile.WriteLine "Double Dash Double Dot=DOUBLE_DASH_DOUBLE_DOT;0."
        oFile.WriteLine "Dash Triple Dot=DASH_TRIPLE_DOT;0."
        oFile.WriteLine "Double Dash Triple Dot=DOUBLE_DASH_TRIPLE_DOT;0."
        '----------------------------------
        oFile.Close
    End If
    Set fso = Nothing
    Set oFile = Nothing
End Sub

[Dennis.Ossadnik]

Hallo @Anonymous,

um einen kleine Start in dieses Projekt zu geben, habe ich Dir mal einen kleinen Code erstellt, die die iProperties abfragt.

Sub FileNameExport()

Dim oApp As Application
Set oApp = ThisApplication

Dim oProps As PropertySet
Set oProps = ThisApplication.ActiveDocument.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")

Dim sDrawingNr As String
Dim sSapNr As String
Dim sTitleDe As String
Dim sRevisionNr As String

Dim oProp As Property
For Each oProp In oProps
    
    If oProp.Name = "Zeichnungsnummer" Then
        sDrawingNr = oProp.Value
    End If
    
    If oProp.Name = "SAP-Nummer" Then
        sSapNr = oProp.Value
    End If
    
    If oProp.Name = "Bezeichnung DE" Then
        sTitleDe = oProp.Value
    End If
    
    If oProp.Name = "Revision" Then
        sRevisionNr = oProp.Value
    End If
    
Next

MsgBox ("Zeichnungsnummer: " & sDrawingNr & vbCrLf & _
        "SAP-Nummer: " & sSapNr & vbCrLf & _
        "Bezeichnung DE: " & sTitleDe & vbCrLf & _
        "Revision: " & sRevisionNr)
End Sub

Das Ergebnis würde für Deine Zeichnung, die Du angehängt hast, dann so aussehen:

Damit hättest du dann schon mal die Properties in Variablen gespeichert, die Du dann nach Deinen Vorgaben zusammenstellen könntest.

Hilft Dir das schon mal ein Stückchen weiter?

---

Bitte nutzt den "Als Lösung akzeptieren"-Button, wenn ein Beitrag euer Problem oder eure Frage löst. Für hilfreiche Posts könnt ihr auch gerne Kudos vergeben.

[Anonymous]

Hi @Dennis.Ossadnik,

vielen Dank für dein Script. Somit hätten wir nun wie die iProperties ausgelesen werden können.

Für mich ist nur die Schwierigkeit, dies nun in meinem vorhanden Makro an der richtigen Stelle zu integrieren!?!  

Ich wäre grießig Dankbar, wenn du mir hier auch helfen könntest.

Gruß,

Markus

[Martin-Winkler-Consulting]

Hallo Markus @Anonymous

und wo wären dann die Stellen an denen du die iProperties einfügen willst. Ich finde dein Skript etwas unübersichtlich für jemanden der die Details nicht kennt. Vielleicht kannst du das im Skript markieren.

Gruß Martin

[Anonymous]

Hi Martin @Martin-Winkler-Consulting,

danke das du dieses Thema angeschaut hast. Entschuldige die Unübersichtlichkeit. 

Das Script wurde auch nicht von mir erstellt. Dies habe ich von meinem Vorgänger übernommen und würde dies nun nach neuen Anforderungen anpassen.

Leider bin ich aber nicht fit in VBA. Daher kann ich selbst keine Einschätzungen vornehmen, an welcher Stelle die Anpassung hineinkommen sollte.

Im Prinzip, sollten die ausgelesenen iProperties dann in den exportierten Dateinamen geschrieben werden.

Wenn du mir hier helfen könntest, wäre ich dir überaus Dankbar. 

Gerne stehe ich für weitere Fragen zur Verfügung.

Gruß,

Markus

[Martin-Winkler-Consulting]

@Anonymous

Alles klar , verstehe. ich schaue mir das dann morgen an. Ich denke den Code kann man deutlich einkürzen.

[Anonymous]

Mega 😉
Das freut mich das du mir helfen möchtest. Gerne kannst du auch das Script kürzen, Kommentare hinzufügen, oder vereinfachen. Ganz nach deinem Stil.

Danke schon mal vorab.

Gruß,
Markus

[Martin-Winkler-Consulting]

@Anonymous

Hallo Markus,

ich bräuchte noch die ini Dateien:

 'exportdwg.ini erstellen
    'ini für DWG
    Dim strIniFile As String
    strIniFile = Makropfad & "exportdwg.ini"
    Call iniSchreiber(strIniFile)
    
    'ini für DXF
    Dim strIniFiledxf As String
    strIniFiledxf = Makropfad & "exportdxf.ini"
    Call iniSchreiberdxf(strIniFiledxf)

Die müssten in eurem Makropfad abgelegt sein.

Und falls du es heraus bekommen kannst was das ist:

FUNC.Speicherpfad(oDoc)

Sieht mir nach einer selbstgestrickten VBA Klasse aus. Die müsste dann im VBA in dem Baum unter Klassen Module (Class Modules) drin stehen.

Gruss Martin

[Martin-Winkler-Consulting]

@Anonymous

Vergiss meinen Post vorher...die ini Dateien werden ja durch den ini Schreiber erzeugt...

[Martin-Winkler-Consulting]

@Anonymous

Es gibt bei deinem Formatierungswunsch ein Problem. In dem ursprünglichen Dateinamen steckt die Revision _a bereits mit drin:

Dateiname_ohne_ext = "E:\3DCS\CAE\Forum\PDF-DWG-DXF_Export\B49267528_a"

Wenn das zuverlässig immer so ist, könnte man die letzen beiden Stellen abschneiden.

Du willst das ja später so haben:  B49267528~2DDWG~Schweißteil~Blatt_01~a.dwg

Also Revision am Ende. Ich würde auch nicht das Zeichen ~ verwenden sondern - oder _

Gruß Martin

[Anonymous]

Hi Martin, @Martin-Winkler-Consulting

geht in Ordnung. Gerne können wir auch das Zeichen "-" als Trennzeichen verwenden. 

Die B4926758 bitte lieber aus der iPropertie = SAP-Nummer entnehmen. Dieses iPropertie ist immer zuverlässig ausgefüllt, ohne "_a". Der Dateinamen von den Inventordateien wird in Zukunft ganz anders heißen und könnte demnach leider nicht für die Formatierung genutzt werden.

Danke vorab für deine Mühe.

Gruß,

Markus

[Martin-Winkler-Consulting · Accepted solution]

@Anonymous

Hallo Markus, so sollte das dann bei euch auch funktionieren:

Public Const Makropfad = "C:\Tresor-LT-CAD\Verwaltung\Konstruktionsdaten Stile\DWG-DXF\"
Public Sub Export_DWG_DXF_PDF()
    On Error GoTo err:
    
    If ThisApplication.ActiveDocumentType <> kDrawingDocumentObject Then
        MsgBox "Funktion kann nur in einer Zeichung ausgeführt werden!", vbCritical
        Exit Sub
    End If
    
    
     Dim fso As Object
     Set fso = CreateObject("Scripting.FilesystemObject")
    
    'exportdwg.ini erstellen
    'ini für DWG
    Dim strIniFile As String
    strIniFile = Makropfad & "exportdwg.ini"
    Call iniSchreiber(strIniFile)
    
    'ini für DXF
    Dim strIniFiledxf As String
    strIniFiledxf = Makropfad & "exportdxf.ini"
    Call iniSchreiberdxf(strIniFiledxf)
    
    Call Update_Zeichnung
    
    Dim oDoc As DrawingDocument
    Set oDoc = ThisApplication.ActiveDocument
    
    Dim sOutputPath As String
    sOutputPath = fso.GetParentFolderName(oDoc.FullFilename) & "\"
    
    'Beginn iProperties auslesen
    Dim oProps As PropertySet
    Set oProps = ThisApplication.ActiveDocument.PropertySets.item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
    Dim sDrawingNr As String
    Dim sSapNr As String
    Dim sTitleDe As String
    Dim sRevisionNr As String
    Dim oProp As Property
    For Each oProp In oProps
        If oProp.Name = "Zeichnungsnummer" Then
            sDrawingNr = oProp.Value
        End If
        
        If oProp.Name = "SAP-Nummer" Then
            sSapNr = oProp.Value
        End If
        
        If oProp.Name = "Bezeichnung DE" Then
            sTitleDe = oProp.Value
        End If
        
        If oProp.Name = "Revision" Then
            sRevisionNr = oProp.Value
        End If
    Next
    'Ende iProperties auslesen
           
'   Alle Blätter der IDW durchlaufen
'   Wenn Blattname <> "DBR" dann
'    Export als DWG mit Dateiname =  <IDW_Name>_<Blattname>.dwg
'    Export als PDF mit Dateiname =  <IDW_Name>_<Blattname>.pdf
'
'   Wenn Blattname = DBR UND Ansicht auf Blatt vorhanden (also nicht leer) dann Export als DXF
    
     Dim blatt As Sheet
     For Each blatt In oDoc.Sheets
             blatt.Activate
             'Dateiname = sSapNr & "_" & Left(blatt.Name, 3)
                 If Left(blatt.Name, 3) <> "DBR" Then
                    'Export aktuelles Blatt DWG Dateiname <IDW_Name>_<Blattname>.dwg
                        Dim DWGAddIn As TranslatorAddIn
                        Set DWGAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}")
            
                        Dim oContext As TranslationContext
                        Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
                        oContext.Type = kFileBrowseIOMechanism
            
                        Dim oOptions As NameValueMap
                        Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
            
                        Dim oDataMedium As DataMedium
                        Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
            
                        If DWGAddIn.HasSaveCopyAsOptions(oDoc, oContext, oOptions) Then
                            oOptions.Value("Export_Acad_IniFile") = strIniFile
                        End If
                
                        'Dateinamen für dwg erstellen
                        oDataMedium.FileName = sOutputPath & sSapNr & "-2DDWG-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".dwg"
                        Call DWGAddIn.SaveCopyAs(oDoc, oContext, oOptions, oDataMedium)
                        
                        'Export aktuelles Blatt PDF Dateiname <IDW_Name>_<Blattname>.pdf
                        Dim PDFAddIn As TranslatorAddIn
                        Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
                    
                        'Set a reference to the active document (the document to be published).
                        Dim oContextpdf As TranslationContext
                        Set oContextpdf = ThisApplication.TransientObjects.CreateTranslationContext
                        oContextpdf.Type = kFileBrowseIOMechanism
                    
                        ' Create a NameValueMap object
                        Dim oOptionspdf As NameValueMap
                        Set oOptionspdf = ThisApplication.TransientObjects.CreateNameValueMap
                    
                        ' Create a DataMedium object
                        Dim oDataMediumpdf As DataMedium
                        Set oDataMediumpdf = ThisApplication.TransientObjects.CreateDataMedium
                    
                        ' Check whether the translator has 'SaveCopyAs' options
                        If PDFAddIn.HasSaveCopyAsOptions(oDoc, oContextpdf, oOptionspdf) Then
                            ' Options for drawings...
                            oOptionspdf.Value("All_Color_AS_Black") = 1
                            'oOptions.Value("Remove_Line_Weights") = 0
                            oOptionspdf.Value("Vector_Resolution") = 400
                            oOptionspdf.Value("Sheet_Range") = kPrintCurrentSheet
                            'oOptions.Value("Custom_Begin_Sheet") = 2
                            'oOptions.Value("Custom_End_Sheet") = 4
                        End If
                    
                        'Set the destination file name
                        oDataMediumpdf.FileName = sOutputPath & sSapNr & "-2DPDF-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".pdf"
                    
                        'Publish document.
                        Call PDFAddIn.SaveCopyAs(oDoc, oContextpdf, oOptionspdf, oDataMediumpdf)
    
         End If
     
             If Left(blatt.Name, 3) = "DBR" And blatt.DrawingViews.Count <> 0 Then
                'Export als DXF Dateiname <IDW_Name>.dxf
                Dim DXFAddIn As TranslatorAddIn
                Set DXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
        
                Dim oContextdxf As TranslationContext
                Set oContextdxf = ThisApplication.TransientObjects.CreateTranslationContext
                oContextdxf.Type = kFileBrowseIOMechanism
                
                Dim oOptionsdxf As NameValueMap
                Set oOptionsdxf = ThisApplication.TransientObjects.CreateNameValueMap
                
                Dim oDataMediumdxf As DataMedium
                Set oDataMediumdxf = ThisApplication.TransientObjects.CreateDataMedium
        
        
                If DXFAddIn.HasSaveCopyAsOptions(oDoc, oContextdxf, oOptionsdxf) Then
                    ' Create the name-value that specifies the ini file to use.
                    oOptionsdxf.Value("Export_Acad_IniFile") = strIniFiledxf
                End If
                
                'dxf Namen zusammenstellen
                oDataMediumdxf.FileName = sOutputPath & sSapNr & "-2DSBR-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".dxf"
                
                Call DXFAddIn.SaveCopyAs(oDoc, oContextdxf, oOptionsdxf, oDataMediumdxf)
             End If
     Next
     '29.10.2015 Blatt 1 aktivieren
     oDoc.Sheets.item(1).Activate
Exit Sub
err:
    Set oFile = fso.CreateTextFile(FUNC.Speicherpfad(ThisApplication.ActiveDocument) & ".FEHLER!")
    oFile.WriteLine "Es ist ein Problem aufgetreten"
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing
End Sub
Sub Update_Zeichnung()
On Error GoTo err:
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
If oDoc.DocumentType = kDrawingDocumentObject Then
    Call oDoc.Update2(True)
    Dim osheet As Sheet
    Set osheet = oDoc.ActiveSheet
    Dim oView As DrawingView
    For Each oView In osheet.DrawingViews
        oView.IsRasterView = False
    Next
Else
 MsgBox "falscher Dokumententyp", vbCritical, "Update Zeichnung"
End If
Exit Sub
err:
  MsgBox "Fehler in Update Zeichnung", vbCritical, "Update Zeichnung"
End Sub
Sub iniSchreiber(iniPfad As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    If fso.FileExists(iniPfad) = False Then
        Set oFile = fso.CreateTextFile(iniPfad)
        '----------------------------------
        oFile.WriteLine "[EXPORT SELECT OPTIONS]"
        oFile.WriteLine "AUTOCAD VERSION=AutoCAD 2007"
        oFile.WriteLine "CREATE AUTOCAD MECHANICAL=No"
        oFile.WriteLine "USE TRANSMITTAL=No"
        oFile.WriteLine "USE CUSTOMIZE=No"
        oFile.WriteLine "CUSTOMIZE FILE=" & Makropfad & "FlatPattern.xml"
        oFile.WriteLine "CREATE LAYER GROUP=No"
        oFile.WriteLine "PARTS ONLY=No"
        oFile.WriteLine "REPLACE SPLINE=No"
        oFile.WriteLine "CHORD TOLERANCE=0.001000"
        oFile.WriteLine "[EXPORT PROPERTIES]"
        oFile.WriteLine "SELECTED PROPERTIES="
        oFile.WriteLine "[EXPORT DESTINATION]"
        oFile.WriteLine "SPACE=Model"
        oFile.WriteLine "SCALING=Geometry"
        oFile.WriteLine "ALL SHEETS=No"
        oFile.WriteLine "MAPPING=LooksBest"
        oFile.WriteLine "MODEL GEOMETRY ONLY=No"
        oFile.WriteLine "EXPLODE DIMENSIONS=No"
        oFile.WriteLine "SYMBOLS ARE BLOCKED=Yes"
        oFile.WriteLine "AUTOCAD TEMPLATE=" & Makropfad & "exportdwg.dwg"
        oFile.WriteLine "DESTINATION DXF=No"
        oFile.WriteLine "USE ACI FOR ENTITIES AND LAYERS=Yes"
        oFile.WriteLine "[EXPORT LINE TYPE & LINE SCALE]"
        oFile.WriteLine "LINE TYPE FILE=" & Makropfad & "InvDIN.lin"
        oFile.WriteLine "Continuous=Continuous;1."
        oFile.WriteLine "Dashed=DASHED;1."
        oFile.WriteLine "Dashed Space=DASHED_SPACE;1."
        oFile.WriteLine "Long Dash Dotted=LONG_DASH_DOTTED;1."
        oFile.WriteLine "Long Dash Double Dot=LONG_DASH_DOUBLE_DOT;1."
        oFile.WriteLine "Long Dash Triple Dot=LONG_DASH_TRIPLE_DOT;1."
        oFile.WriteLine "Dotted=DOTTED;1."
        oFile.WriteLine "Chain=CHAIN;1."
        oFile.WriteLine "Double Dash Chain=DOUBLE_DASH_CHAIN;1."
        oFile.WriteLine "Dash Dot=DASH_DOT;1."
        oFile.WriteLine "Double Dash Dot=DOUBLE_DASH_DOT;1."
        oFile.WriteLine "Double Dash Double Dot=DOUBLE_DASH_DOUBLE_DOT;1."
        oFile.WriteLine "Dash Triple Dot=DASH_TRIPLE_DOT;1."
        oFile.WriteLine "Double Dash Triple Dot=DOUBLE_DASH_TRIPLE_DOT;1."
        '----------------------------------
        oFile.Close
    End If
    Set fso = Nothing
    Set oFile = Nothing
End Sub

Sub iniSchreiberdxf(iniPfad As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    If fso.FileExists(iniPfad) = False Then
        Set oFile = fso.CreateTextFile(iniPfad)
        '----------------------------------
        oFile.WriteLine "[EXPORT SELECT OPTIONS]"
        oFile.WriteLine "AUTOCAD VERSION=AutoCAD 2000"
        oFile.WriteLine "CREATE AUTOCAD MECHANICAL=No"
        oFile.WriteLine "USE TRANSMITTAL=No"
        oFile.WriteLine "USE CUSTOMIZE=No"
        oFile.WriteLine "CUSTOMIZE FILE=" & Makropfad & "FlatPattern.xml"
        oFile.WriteLine "CREATE LAYER GROUP=No"
        oFile.WriteLine "PARTS ONLY=No"
        oFile.WriteLine "REPLACE SPLINE=No"
        oFile.WriteLine "CHORD TOLERANCE=0.001000"
        oFile.WriteLine "[EXPORT PROPERTIES]"
        oFile.WriteLine "SELECTED PROPERTIES="
        oFile.WriteLine "[EXPORT DESTINATION]"
        oFile.WriteLine "SPACE=Model"
        oFile.WriteLine "SCALING=Geometry"
        oFile.WriteLine "ALL SHEETS=No"
        oFile.WriteLine "MAPPING=LooksBest"
        oFile.WriteLine "MODEL GEOMETRY ONLY=No"
        oFile.WriteLine "EXPLODE DIMENSIONS=No"
        oFile.WriteLine "SYMBOLS ARE BLOCKED=Yes"
        oFile.WriteLine "AUTOCAD TEMPLATE="
        oFile.WriteLine "DESTINATION DXF=Yes"
        oFile.WriteLine "USE ACI FOR ENTITIES AND LAYERS=Yes"
        oFile.WriteLine "[EXPORT LINE TYPE & LINE SCALE]"
        oFile.WriteLine "LINE TYPE FILE=" & Makropfad & "InvDIN.lin"
        oFile.WriteLine "Continuous=Continuous;0."
        oFile.WriteLine "Dashed=DASHED;0."
        oFile.WriteLine "Dashed Space=DASHED_SPACE;0."
        oFile.WriteLine "Long Dash Dotted=LONG_DASH_DOTTED;0."
        oFile.WriteLine "Long Dash Double Dot=LONG_DASH_DOUBLE_DOT;0."
        oFile.WriteLine "Long Dash Triple Dot=LONG_DASH_TRIPLE_DOT;0."
        oFile.WriteLine "Dotted=DOTTED;0."
        oFile.WriteLine "Chain=CHAIN;0."
        oFile.WriteLine "Double Dash Chain=DOUBLE_DASH_CHAIN;0."
        oFile.WriteLine "Dash Dot=DASH_DOT;0."
        oFile.WriteLine "Double Dash Dot=DOUBLE_DASH_DOT;0."
        oFile.WriteLine "Double Dash Double Dot=DOUBLE_DASH_DOUBLE_DOT;0."
        oFile.WriteLine "Dash Triple Dot=DASH_TRIPLE_DOT;0."
        oFile.WriteLine "Double Dash Triple Dot=DOUBLE_DASH_TRIPLE_DOT;0."
        '----------------------------------
        oFile.Close
    End If
    Set fso = Nothing
    Set oFile = Nothing
End Sub

Kannst ja mal nachvollziehen was ich da gemacht habe und beim nächsten Mal klappts dann alleine. Ansonsten gibt es Leute die einem sowas beibringen können

Grüße Martin

[Anonymous]

Hi Martin, @Martin-Winkler-Consulting

super. Freut mich auch das du mir helfen konntest. Klappt ganz gut.

Du hast auch recht, dass lernen VBA programmieren mir ganz gut tun würde. Dich als Lehrer wäre klarre 

Nun möchte ich im Script noch eine Kleinigkeit anpassen.

Ich versuche gerade dies einzubinden, wenn eine Zeichnungsnummer vorhanden ist, das er diese am Anfang auch schreibt.

............ sDrawingNr & "-" & ............

z.B. so:

LA.126183.20.02-B49267528-2DDWG-Schweißteil-Blatt-1-a.idw

Jedoch habe ich die Schwierigkeit die Logik zu schreiben, was er machen sollte wenn keine Zeichnungsnummer vorhanden ist?

Er sollte dann nicht bei fehlender Zeichnungsnummer das ganze so schreiben. Das ein "-" am Anfang steht. Das wäre unschön.

z.B. so:

-B49267528-2DDWG-Schweißteil-Blatt-1-a.idw

Meinst du kannst mir hier nochmal kurz helfen?

Danke dir vorab.

Gruß,

Markus

                        'Dateinamen für dwg erstellen
                        oDataMedium.Filename = sOutputPath & sDrawingNr & "-" & sSapNr & "-2DDWG-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".dwg"
                        Call DWGAddIn.SaveCopyAs(oDoc, oContext, oOptions, oDataMedium)

[Martin-Winkler-Consulting · Accepted solution]

@Anonymous

Hallo Markus, freut mich das es funktioniert.

Das mit der zusätzlichen Zeichnungsnummer würde ich über eine IF Bedingung einbauen:

If sDrawingNr = "" Then
oDataMedium.Filename = sOutputPath & sSapNr & "-2DDWG-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".dwg"
Else
oDataMedium.Filename = sOutputPath & sDrawingNr & "-" & sSapNr & "-2DDWG-" & sTitleDe & "-Blatt-" _
                        & Left(blatt.Name, 3) & "-" & sRevisionNr & ".dwg"
End If

Grüße Martin

[Anonymous]

Suuuuuuuuper 

Funktioniert perfekt. Ich bin überaus Dankbar.

Hat mich sehr gefreut mit deiner kompetenten Unterstützung. Gerne wieder. 

Gruß,

Markus