---

Hallo Inventorgemeinde
Ich habe ein Makro, mit dem ich ein Pdf einer IDW erstelle.

Code:

---

Public Sub CreatePDF()
On Error Resume Next
If ThisApplication.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
Exit Sub
End If

Dim oDoc As Inventor.DrawingDocument
Set oDoc = ThisApplication.ActiveDocument
If oDoc.FullFileName = "" Then
MsgBox "Bitte zuerst die Zeichnung speichern..."
Exit Sub
End If
oDoc.SaveAs Replace(oDoc.FullFileName, Right(oDoc.FullFileName, 3), "pdf"), True

If Err.Number = 0 Then
MsgBox "Die Datei:" & vbCrLf & vbCrLf & Replace(oDoc.FullFileName, Right(oDoc.FullFileName, 3), "pdf") & vbCrLf & vbCrLf & "wurde erfolgreich gespeichert"
Else
MsgBox "Fehler: " & Err.Description
End If
End Sub

---

Was muss ich in diesen Code einfügen, um alle Blätter einer IDW in einer PDF-Datei zu kopieren?
Freue mich schon jetzt auf eure Unterstützung.

------------------
Didi

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

---

Hi

Nimm das Translator-AddIn.

Code:

---

Public Sub PublishPDF()
    ' Get the PDF translator Add-In.
    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 oDocument As Document
    Set oDocument = ThisApplication.ActiveDocument

    Dim oContext As TranslationContext
    Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
    oContext.Type = kFileBrowseIOMechanism

    ' Create a NameValueMap object
    Dim oOptions As NameValueMap
    Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

    ' Create a DataMedium object
    Dim oDataMedium As DataMedium
    Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium

    ' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then

        ' Options for drawings...

        oOptions.Value("All_Color_AS_Black") = 0

        'oOptions.Value("Remove_Line_Weights") = 0
        'oOptions.Value("Vector_Resolution") = 400
        oOptions.Value("Sheet_Range") = kPrintAllSheets '<------------ alle Blätter ins PDF drucken
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    End If

    'Set the destination file name
    oDataMedium.FileName = Replace(oDoc.FullFileName, Right(oDoc.FullFileName, 3), "pdf")

    'Publish document.
    Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
End Sub

---

------------------
MfG
Ralf

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

---

Hallo rkauskh

danke für die schnelle Antwort.
Bei mir klappt der code nicht. Der Debug bleibt an dieser Position hängen:

Code:

---

    'Set the destination file name
    oDataMedium.FileName = Replace(oDoc.FullFileName, Right(oDoc.FullFileName, 3), "pdf")

---

------------------
Didi

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

---

Hi

Na dann ersetz noch schnell 2x oDoc durch oDocument in der Zeile.

------------------
MfG
Ralf

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

---

Hallo Ralf

hat funktioniert, hätte ich auch selbst sehen können.
Besten Dank nochmal und frohe Festtage.

------------------
Didi

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

---

Moin,

was muss ich tun um diesen Code so anzupassen, dass er es in dem jeweiligen User Desktop unter dem Ordner "PDF" speichert statt am gleichen Ort, wo die IDW liegt?

Gruß Marcus

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

---

Hallo schattenbacke,

die Zeile

Code:

---

oDataMedium.FileName = Replace(oDoc.FullFileName, Right(oDoc.FullFileName, 3), "pdf")

---

wird ersetzt durch folgenden Code:
(wichtig: Verweis auf "Microsoft Scripting Runtime" unter Tools/References setzen)

Code:

---

Dim oWSH            As Object ' Windows scripting host
Dim sPfad As String
Dim s1 As String
Dim lx1 As Long
'---
Set oWSH = CreateObject("WScript.Shell")
sPfad = oWSH.SpecialFolders("Desktop") & "\pdf\"  ' der Pfad
s1 = ThisApplication.ActiveDocument.FullFileName
lx1 = InStrRev(s1, "\") ' Pos für Beginn Dateiname
s1 = Right(s1, Len(s1) - lx1) ' Name aus Fullfilename extrahieren
s1 = Left(s1, Len(s1) - 3) & "pdf"  ' PDF-Name draus machen, indem die letzten drei Zeichen ersetzt werden
'---
oDataMedium.FileName =  sPfad & s1

---

Wegen Erhalt der Übersichtlichkeit Code nicht zusammengekürzt.
Ohne Gewähr und ohne Überprüfung, ob Zielverzeichnis existiert.

Gruß Boris

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

---

Danke dir, aber das müsste ich dann auf jedem Rechner aktivieren? Das wäre ehrlich gesagt recht ungünstig...

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

---

Hallo Schattenbacke,
Versuch macht kluch...
Es könnte sein, dass die Verweise in der ivb abgespeichert werden - diese also beim Laden der ivb gesetzt werden.

Gruß Boris

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

---

Habe mal was gebastelt ...

Step - und PDF-Export in explizites Verzeichnis - leicht änderbar für andere Typen

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

---

Hallo Schattenbacke,
bisschen windig - momentan nicht nur draussen - auch dein Script.
Da muss ich mal bisschen meckern :
Weil: Man kann nicht voraussetzen, dass sich der Desktop als Unterverzeichnis im Userverzeichnis (Environ("USERPROFILE")) befindet.
Ich habe u.a. den Desktop auf ein anderes Laufwerk verschoben, weil der Platz der SSD auf C knapp wurde...

Desweiteren fehlt in deinem Script die Überprüfung auf ungespeicherte Datei - ...activedocument.filesavecounter>0 - das ist jedenfalls die saubere Lösung gegenüber dem Test auf ...activedocument.fullfilename<>"".

Warum für den Dateinamen eine extra custom iprop verwenden?
Mmh, der Dateiname steht doch sowieso in ...activedocument.fullfilename (spätestens nach dem ersten Speichern der Datei)
Ausserdem: Existiert dieses Iprop nicht, wird gnadenlos ein Fehler (err.number 91) geworfen...

Ich verwende für pdf/dxf/step/dwf die entsprechenden Translator-Addins (ist in den samples zu finden). Damit bekommt man dann die Optionen gleich mit im Griff...

Was der Automatisierung auch bisschen im Wege steht:
Die stp/pdf-Ausgabe sollte praktischerweise vorher prüfen, ob die zu schreibende Datei bereits vorhanden ist - und diese dann vor der Ausgabe kommentarlos löschen.
Erst dann, wenn das nicht gelingt (weil bspw. die pdf gerade offen ist oder anderweitig Schreibschutz besteht) sollte das Script die Hilfe des Users in Anspruch nehmen.

Und zu guter Letzt:
Da man nie weiß, unter welch widrigen Umständen die Subs aufgerufen werden, sollte man prüfen, ob im Inventor überhaupt eine Datei offen ist.
Das kann man mittels 'on error resume next' und dann die err.number nach der Zuweisung der Objektvariablen odoc machen oder aber man benutzt ThisApplication.Documents.VisibleDocuments.Count  - der sollte >0 sein.

Wie gesagt, nur bisschen Gemecker, gerade das Abfangen von Fehlern sollte man sich zu Herzen nehmen - denn garantiert wird der unbedarfte User es schon beim Erstkontakt mit dem Script schaffen, bis dato noch nie gesehene Fehlermeldungen zu produzieren. Noch besser ist es nur noch, wenn einem das bei der Vorführung des eigenen Scripts passiert...

Gruß Boris

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

---

Was ist mit iLogic (externe Regel)?

Code:

---

'
'PDF erstellen - alle Seiten einzeln
'

Dim oSheetName As String
Dim erste_Seite As String
Dim oDoc As DrawingDocument
Dim oSheets As Sheet
oDoc = ThisApplication.ActiveDocument
erste_Seite = ""

For Each oSheets In oDoc.Sheets

oSheets.Activate
oSheet = ActiveSheet
oFileName = ThisDoc.FileName(False) 'without extension
oRevNum = iProperties.Value("Project", "Revision Number")
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oDocument = ThisApplication.ActiveDocument
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium

oSheetName =  Right(oSheet.Name,1) 'Blattnummer

If oSheetName = "1" Then
erste_Seite = oSheet.Name
End If

If oPDFAddIn.HasSaveCopyAsOptions(oDataMedium, oContext, oOptions) Then
oOptions.Value("All_Color_AS_Black") = 0
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintCurrentsheet

End If

Dim WshShell As Object
WshShell = CreateObject("WScript.Shell")
oFolder = WshShell.SpecialFolders("Desktop") & "\pdf"
WshShell = Nothing

'Prüfen ob PDF Verzeichnis auf dem Desktop vorhanden ist,
'wenn nicht wird es erstellt
If Not System.IO.Directory.Exists(oFolder) Then
    System.IO.Directory.CreateDirectory(oFolder)
End If

oDataMedium.FileName = oFolder & "\" & oFileName & "_Blatt-" & oSheetName & ".pdf"
oPDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)

Next

ActiveSheet = ThisDrawing.Sheet(erste_Seite)

---

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

---

Hallo,

ich habe mal eine Frage zu dem Exportieren von PDFs mittels VBA.
Ich wollte keinen neuen Beitrag erstellen und verwende diesen. Ich hoffe das ist OK.
Leider kenne ich mich mit VBA nicht aus und habe das Makro mir per Copy&Paste gebastelt.
Soweit funktioniert es sehr zuverlässig.

Ich möchte das in dem Dateinamen die Revision erscheint.
Also so
<Zeichnungsnummer><Revision>_<Datum>.pdf

Das Problem ist das bei uns die Revison nur in den Modellen eingetragen werden.
In dem Zeichnungskopf wird dann die Revision aus dem Modell angezogen.

Geht das auch für ein Makro/VBA?

Mit:
Dim oDocRevision As Property
Set oDocRevision = oDocument.PropertySets.Item("Inventor Summary Information").Item("Revision Number")
komme ich nur an die Revision der IDW.

Hier mein aktuelles Makro:

Public Sub PDF_Export()
    ' Get the PDF translator Add-In.
    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 oDocument As Document
    Set oDocument = ThisApplication.ActiveDocument

    Dim oContext As TranslationContext
    Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
    oContext.Type = kFileBrowseIOMechanism

    ' Create a NameValueMap object
    Dim oOptions As NameValueMap
    Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

    ' Create a DataMedium object
    Dim oDataMedium As DataMedium
    Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium

    ' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then

        ' Options for drawings...

        oOptions.Value("All_Color_AS_Black") = 0
        oOptions.Value("Remove_Line_Weights") = 0
        oOptions.Value("Vector_Resolution") = 1200
        oOptions.Value("Sheet_Range") = kPrintAllSheets '<------------ alle Blätter ins PDF drucken
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    End If
   
    'Speicherort
    oDataMedium.FileName = "I:\Export\"
   
    'Zeichnungsnummer
    oDataMedium.FileName = oDataMedium.FileName & Left(oDocument.DisplayName, Len(oDocument.DisplayName) - 4)
   
    'Datum
    oDataMedium.FileName = oDataMedium.FileName & "_" & Year(Now) & "-" & Right("0" & Month(Now), 2) & "-" & Right("0" & Day(Now), 2)
   
    'Dateiendung
    oDataMedium.FileName = oDataMedium.FileName & ".pdf"
   
    'Publish document.
    Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
End Sub

Hat jemand eine Idee?

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

---

Hallo

Willkommen im Forum. 

Ein neuer Beitrag wäre besser gewesen, da deine Frage nicht wirklich mit der ursprünglichen zu tun hat. Egal, für deine Revisionsinfo musst du dir das referenzierte Dokument der IDW holen. Wenn die Empfehlung nicht mehrere 3D-Modelle in eine Zeichnung zu packen eingehalten wurde und das es mindestens eine Erstansicht gibt, dann so:

Code:

---

Dim oRefedDocument as Document
Set oRefedDocument = oDocument.ReferencedDocuments(1)

Dim oDocRevision As Property
Set oDocRevision = oRefedDocument.PropertySets.Item("Inventor Summary Information").Item("Revision Number")

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Code:

---

Sub test()
   
    'aktives document -> idw
    Dim oDocument As Document   'hier evtl. DrawingDocument verwenden, oder prüfen, ob das aktive Doc. auch Zg. ist
    Set oDocument = ThisApplication.ActiveDocument
   
    'Revision des aktiven Documents
    Dim oDocRevision As Property
    Set oDocRevision = oDocument.PropertySets.Item("Inventor Summary Information").Item("Revision Number")

    'Referenziertes Dokument -> Modell (iam oder ipt)
    Dim oRefDoc As Document
    Set oRefDoc = oDocument.ReferencedDocuments.Item(1)
    ' evtl. vorher noch prüfen, ob ReferencedDocuments.Count = 1
    ' sonst Fehler, wenn kein Modell referenziert wird
    ' evtl. auch problematisch, wenn mehrere Modelle, dann wird Rev. vom "ersten" genommen
   
    'Revision des refDoc
    Dim oRefDocRev As Property
    Set oRefDocRev = oRefDoc.PropertySets.Item("Inventor Summary Information").Item("Revision Number")

    'Ergebnis zum Vergleich
    MsgBox "oDoc: " & vbTab & oDocRevision.Value & vbCrLf _
        & "oRefDoc:" & vbTab & oRefDocRev.Value, vbOKOnly, "Revision"
   
End Sub

---

Edit: Ralf war schneller

------------------
Gruß KraBBy

[Diese Nachricht wurde von KraBBy am 16. Sep. 2022 editiert.]

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

---

Oh super!!!

Vielen dank es funktioniert.

Da wir die iPropertys aus dem ersten eingefügten Modell für den Schriftkopf benötigen rechne ich nicht mit problemen.

1000 Dank für die schnellen antworten.

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

---

Hallo nochmal,

ich habe jetzt folgendes Problem:

Das Skript nimmt nicht die Zeichnungsnummer aus dem zuerst eingefügten Modell sondern aus dem zuletzt eingefügten.
Wenn wir jetzt eine Zeichnung haben wo wir noch ein weiteres Modell einfügen wird immer dessen Zeichnungsnummer angezogen.

hier mein Skript:

Public Sub PDF_Export()
    ' Get the PDF translator Add-In.
    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 oDocument As Document
    Set oDocument = ThisApplication.ActiveDocument

    Dim oContext As TranslationContext
    Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
    oContext.Type = kFileBrowseIOMechanism

    ' Create a NameValueMap object
    Dim oOptions As NameValueMap
    Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

    ' Create a DataMedium object
    Dim oDataMedium As DataMedium
    Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
   
    ' Referenziertes Dokument einbinden
    Dim oRefedDocument As Document
    Set oRefedDocument = oDocument.ReferencedDocuments(1)
   
    ' Zeichnungsnummer aus .iam/.idw
    Dim oDocPartNumber As Property
    Set oDocPartNumber = oRefedDocument.PropertySets.Item("Design Tracking Properties").Item("Part Number")
       
    ' Revisionsnummer aus .iam/.idw
    Dim oDocRevision As Property
    Set oDocRevision = oRefedDocument.PropertySets.Item("Inventor Summary Information").Item("Revision Number")
   
    ' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then

        ' Options for drawings...

        oOptions.Value("All_Color_AS_Black") = 0
        oOptions.Value("Remove_Line_Weights") = 0
        oOptions.Value("Vector_Resolution") = 1200
        oOptions.Value("Sheet_Range") = kPrintAllSheets '<------------ alle Blätter ins PDF drucken
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    End If

    'Set the destination file name
    'oDataMedium.FileName = Replace(oDocument.FullFileName, Right(oDocument.FullFileName, 3), "pdf")
    'oDataMedium.FileName = "I:\Export\" & Left(oDocument.DisplayName, Len(oDocument.DisplayName) - 3) & "pdf"
    'oDataMedium.FileName = "I:\Export\" & Left(oDocument.DisplayName, Len(oDocument.DisplayName) - 4) & "_" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & ".pdf"
   
    'Speicherort
    oDataMedium.FileName = "I:\Export\"
   
    'Zeichnungsnummer
    'oDataMedium.FileName = oDataMedium.FileName & Left(oDocument.DisplayName, Len(oDocument.DisplayName) - 4)
    oDataMedium.FileName = oDataMedium.FileName & oDocPartNumber.Value
       
    'Revisionsnummer
    oDataMedium.FileName = oDataMedium.FileName & oDocRevision.Value
   
    'Datum
    oDataMedium.FileName = oDataMedium.FileName & "_" & Year(Now) & "-" & Right("0" & Month(Now), 2) & "-" & Right("0" & Day(Now), 2)
   
    'Dateiendung
    oDataMedium.FileName = oDataMedium.FileName & ".pdf"
   
    'Publish document.
    Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
End Sub

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

---

Hallo

Wenn die Empfehlung nicht mehrere 3D-Modelle in eine Zeichnung zu packen eingehalten wurde und das es mindestens eine Erstansicht gibt, dann so:

Habe ich doch extra drauf hingewiesen. Dann nimm die erste Ansicht auf dem ersten Zeichnungsblatt. Bringt natürlich auch nichts, wenn man nachträglich ein neues erstes Blatt einfügt.

Code:

---

Dim oRefedDocument as Document
Set oRefedDocument = oDocument.Sheets(1).DrawingViews(1).ReferencedDocumentDescriptor.ReferencedDocument

---

------------------
MfG
Ralf

RKW Solutions GmbH
www.RKW-Solutions.com

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

---

Super DANKE!!

Da hatte ich mich etwas ungeschickt ausgedrückt.

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