---

Guten Abend.

Ich habe folgendes Makro:

Sub SaveAsPdf()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant

For Each oDoc In ThisApplication.Documents

    If oDoc.DocumentType = kDrawingDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        Set dDoc = ThisApplication.ActiveDocument
        If dDoc Is Nothing Then Exit Sub
            If Len(Trim(dDoc.FullFileName)) > 0 Then
                outFile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & ".pdf"
                dDoc.SaveAs outFile, True
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
Next

End Sub

und ich würde gerne das die daraus entstehenden PDFs in Schwarz/Weiß sind, doch habe ich keine Ahnung welche Befehle ich wo hin schreiben müsste. Daher bitte ich hier mal um Hilfe.
Vielleicht weiß ja jemand wie man das hin bekommt.

Freundliche Grüße

Chris

------------------
Rechtschreibfehler sind erwünscht und dienen der Unterhaltung des Lesers. 

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

---

Ungetest, aber vielleicht hilft dir dieses Makro als Anregung:
http://ww3.cad.de/foren/ubb/Forum258/HTML/001141.shtml

Code:

---

...
' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
        ' Options for drawings...
        oOptions.Value("All_Color_AS_Black") = 0
...

---

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

Udo Hübner
www.CAD-Huebner.de

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

---

Hallo

Die SaveAs-Methode in deinem Script bietet mW diese Möglichkeit nicht. Probier mal:

Code:

---

Sub SaveAsPdf()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant

For Each oDoc In ThisApplication.Documents

    If oDoc.DocumentType = kDrawingDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        Set dDoc = ThisApplication.ActiveDocument
        If dDoc Is Nothing Then Exit Sub
            If Len(Trim(dDoc.FullFileName)) > 0 Then
                outFile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & ".pdf"

' Get the PDF translator Add-In.
    Dim PDFAddIn As TranslatorAddIn
    Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")

    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(dDoc, 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
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    'Publish document.
    Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, outFile)
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
  End if
Next

End Sub

---

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

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

---

Hallo Udo

Bei diesem Code Stück weiß ich leider nicht recht wo ich es einfügen soll, daher habe ich ihn einfach mal zwischen jede kopiert und probiert und wenn es nicht ging halt in die nächste, doch als ich durch war funktionierte es leider immer noch nicht.

Hallo Ralf

Code:
Sub SaveAsPdf()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant
For Each oDoc In ThisApplication.Documents

    If oDoc.DocumentType = kDrawingDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        Set dDoc = ThisApplication.ActiveDocument
        If dDoc Is Nothing Then Exit Sub
            If Len(Trim(dDoc.FullFileName)) > 0 Then
                outFile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & ".pdf"

' Get the PDF translator Add-In.
    Dim PDFAddIn As TranslatorAddIn
    Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")

    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(dDoc, 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
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    'Publish document.
    Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, outFile)
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
  End if
Next

End Sub

In der fett gedruckten Zeile scheint es einen Fehler zu geben. Ich habe die Zeile mal gelöscht und nach oben und unten verschoben, doch das brachte alles nichts. Wenn ich den Code 1:1 benutze kommt die Fehlermeldung: current error "424" und ich kann entweder abbrechen, debuggen oder schweigend akzeptieren bzw. ok drücken.

Freundliche Grüße

Chris

------------------
Rechtschreibfehler sind erwünscht und dienen der Unterhaltung des Lesers. 

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

---

Hallo

Jupp, da fehlte noch eine Kleinigkeit. Der hier sollte funktionieren:

Code:

---

Sub SaveAsPdf()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant
For Each oDoc In ThisApplication.Documents

    If oDoc.DocumentType = kDrawingDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        Set dDoc = ThisApplication.ActiveDocument
        If dDoc Is Nothing Then Exit Sub
            If Len(Trim(dDoc.FullFileName)) > 0 Then
                outfile = fso.GetParentFolderName(dDoc.FullFileName) & "\" & fso.GetBaseName(dDoc.FullFileName) & ".pdf"

' Get the PDF translator Add-In.
    Dim PDFAddIn As TranslatorAddIn
    Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")

    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
   
    oDataMedium.Filename = outfile

    ' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(dDoc, 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
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4

    'Publish document.
    Call PDFAddIn.SaveCopyAs(dDoc, oContext, oOptions, oDataMedium)
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
  End If
Next

End Sub

---

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

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

---

Hallo Ralf

Funktioniert super. Doch sind die PDFs immer noch bunt und nicht in SW. 
Geht das überhaupt, dass man sie automatisch in SW speichern kann?

Freundliche Grüße

Chris

------------------
Rechtschreibfehler sind erwünscht und dienen der Unterhaltung des Lesers. 

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

---

Hallo

Ich bin ein Schussel. Ändere mal bitte

Code:

---

oOptions.Value("All_Color_AS_Black") = 0

---

in

Code:

---

oOptions.Value("All_Color_AS_Black") = 1

---

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

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

---

Hallo.

Funktioniert!
Super! Danke!

Freundliche Grüße
Chris

------------------
Rechtschreibfehler sind erwünscht und dienen der Unterhaltung des Lesers. 

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

---

Hallo noch mal.

Das ganze mit PDF, DXF und DWG Export funktioniert schon ganz super. Doch gib es eine Möglichkeit das ganze auf STEP um zu schreiben? Ich habe hier und da ein wenig rumprobiert.
Doch mir fehlt leider das "know how".

Kann mir hier vielleicht jemand helfen?

PS: Klar gibt es Makros für den STEP-Export! Doch ich möchte das durch das Makro wieder alle geöffneten Dateien konvertiert werden. So wie bei dem PDFMakro

------------------
Mit freundlichen Grüßen

Chris

[Diese Nachricht wurde von Kizz am 28. Nov. 2012 editiert.]

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

---

Hallo

Probier mal:

Code:

---

Sub SaveAsSTP()
Dim oDoc As Document
Dim fso As Object
Dim ret As Variant

For Each oDoc In ThisApplication.Documents

    If oDoc.DocumentType = kAssemblyDocumentObject Or kPartDocumentObject Then
        Set fso = CreateObject("Scripting.FilesystemObject")
        Call oDoc.Activate
        If oDoc Is Nothing Then Exit Sub
        If Len(Trim(oDoc.FullFileName)) > 0 Then
            outfile = fso.GetParentFolderName(oDoc.FullFileName) & "\" & fso.GetBaseName(oDoc.FullFileName) & ".stp"
                   
            ' Get the STP translator Add-In.
            Dim oSTEPTranslator As TranslatorAddIn
            Set oSTEPTranslator = ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}")

            If oSTEPTranslator Is Nothing Then
                MsgBox "Could not access STEP translator."
                Exit Sub
            End If

            Dim oContext As TranslationContext
            Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
   
            Dim oOptions As NameValueMap
            Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
            If oSTEPTranslator.HasSaveCopyAsOptions(ThisApplication.ActiveDocument, oContext, oOptions) Then
                ' Set application protocol.
                ' 2 = AP 203 - Configuration Controlled Design
                ' 3 = AP 214 - Automotive Design
                oOptions.Value("ApplicationProtocolType") = 3

                ' Other options...
                'oOptions.Value("Author") = ""
                'oOptions.Value("Authorization") = ""
                'oOptions.Value("Description") = ""
                'oOptions.Value("Organization") = ""

                oContext.Type = kFileBrowseIOMechanism

                Dim oDataMedium As DataMedium
                Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
                oData.Filename = outfile

                Call oSTEPTranslator.SaveCopyAs(oDoc, oContext, oOptions, oDataMedium)
            End If
        Else
            MsgBox "Erst alles Speichern", vbInformation
            Exit Sub
        End If
    End If
Next

End Sub

---

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

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

---

Hallo  Ralf. Danke für die schnelle Antwort!

Bei der Zeile mit oData.FileName = outfile hat er ein Run-time error '424': Object required.
Ich habe mal versucht die Zeile zu löschen, aber das hat nichts gebracht.

------------------
Mit freundlichen Grüßen

Chris

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

---

Hi

Sorry, das ist ein Fehler von mir. Mach aus der Zeile bitte:

Code:

---

oDataMedium.Filename = outfile

---

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

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

---

Ich habe mich einmal ein wenig mit der iLogic Funkion von Inventor beschäftigt und dachte mir das man das PDF-Makro mit einem Dialogfeld vor Kopie Speichern unter schieben könnte.

Soll hießen: Wenn ich meine aktive Zeichnung per "Kopie speichern unter" als PDF abspeichern möchte, soll ein Dialogfeld mit der Nachricht "Wollen Sie alle geöffneten Zeichnungen konvertieren?" und mit den 3 Buttons Ja, Nein und Abbrechen erscheinen, die wie gehabt funktionieren.

Ich schätze es wird sich jetzt sicher der eine oder andere ins Fäustchen lachen, doch das habe ich bis jetzt:

i = MessageBox.Show("Wollen Sie alle geöffneten Zeichnungen konvertieren?", "PDF-Stapelexport", MessageBoxButtons.YesNoCancel, MessageBoxIcon.Question, MessageBoxDefaultButton.Button1)

If ,MessageBoxDefaultButton.Button1 Then InventorVb.RunMacro("Projekte2013", "Module1", "PDF_Export")

Woraufhin die Fehlermeldung: Zeile 3 : Ausdruck erwartet. erscheint.

Kann man damit was unter iLogic anfangen?

------------------
Mit freundlichen Grüßen

Chris

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

---

Hallo

Wenn, dann prüfe in deiner If-Anweisung den Inhalt von i.
6 = Ja
7 = Nein
2 = Abbrechen

Wo ist der Unterschied zwischen Nein und Abbrechen? Die iLogic-Regel mußt du dann aber in deine Zeichnungsvorlage packen, damit sie in jeder neuen IDW drin ist. Aber willst du wirklich bei jedem Speichern diesen Dialog sehen? Ich sehe in iLogic keine Unterscheidungsmöglichkeit zwischen Speichern, Speichern unter und Kopie speichern unter.

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

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

---

Zitat:

---

Wo ist der Unterschied zwischen Nein und Abbrechen?

---

Na wenn ich per Kopie speichern unter --> PDF das Dialogfeld mit "Wollen sie alle geöffneten Zeichnungen als PDF spiechern?" bekomme, wird genau das bei "Ja" passieren. Bei "Nein" soll nur das aktuelle Blatt als PDF exportiert werden und bei "Abbrechen" wird gar nichts gespeichert.

Ist es überhaupt möglich ein Dialogfeld nur dann zu bekommen wenn man als PDF oder DWG speichern möchte, aber bei anderen Formaten nicht?

Das ich keinen blassen Schimmer von VBA habe ist denke ich mal klar. Ich hoffe meine Unwissenheit sorgt wenigstens für ein paar Lacher.  

MFG
Chris

------------------
Mit freundlichen Grüßen

Chris

[Diese Nachricht wurde von Kizz am 06. Mrz. 2013 editiert.]

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