---

Hallo.
Habe hier im Forum folgendes gefunden:

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

---

Damit funktioniert das abspeichern in pdf sehr gut.

Nun möchte ich aber dass er mich fragt ob der die Datei dort abspeichern darf.

Könnt ihr mir vielleicht sagen was ich wo einfügen muss damit diese Abfrage kommt?

Ist es auch möglich dass er zum Dateinamen noch das aktuelle Datum mit einfügt?

Vielen Dank Falko

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

---

Du willst das eine Meldung kommt wo steht:

"Darf ich das Dokument unter C:\Users\name\Desktop\dateiname.pdf speichern?" "Ja", "Nein"
Und du drückst dann ja oder nein oder wie? Ich glaube das ist nicht das was du mit der Frage bezwecken wolltest oder?^^

Das Datum kannst du natürlich auch rein nehmen
Date() => für das Datum
Now() => für Datum mit Uhrzeit

------------------
Grüße aus Wien
Philipp
http://black-evolution.de/

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

---

Hallo.
Nein einfach nur die Möglichkeit es woanders abzuspeichern.
Beim normalen exportieren kommt doch das Fenster mit "Speichern unter". Genau das meine ich.
Ich möchte noch die Möglichkeit geben, es woanders abzuspeichern und es wenn nötig noch umzubenennen.

Das Datum muss dann wo mit rein?

Falko

[Diese Nachricht wurde von kellerassel75 am 13. Feb. 2015 editiert.]

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

---

Hi,

vielleicht so?

Code:

---

Public Sub oPDF()

Dim oapp As Inventor.Application
Set oapp = ThisApplication
If oapp.ActiveDocument Is Nothing Then Exit Sub
If oapp.ActiveDocumentType <> kDrawingDocumentObject Then Exit Sub

Dim odoc As Inventor.DrawingDocument
Set odoc = oapp.ActiveDocument

    Dim oFileDlg As FileDialog
    Dim oPath As String
    Call ThisApplication.CreateFileDialog(oFileDlg)
    oFileDlg.ShowSave

Call odoc.SaveAs(oFileDlg.FileName, True)

End Sub

---

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

---

Hi.
Nicht schlecht. Leider fehlt die Bezeichnung und das es als PDF gespeichert werden soll.
Wichtig ist mir auch das alle Seiten gespeichert werden und ich nicht immer erst in den Optionen das Einstellen muss.

Falko

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

---

Hallo

Code:

---

Public Sub TestFileDialog()
    ' Create a new FileDialog object.
    Dim oFileDlg As FileDialog
    Call ThisApplication.CreateFileDialog(oFileDlg)

    oFileDlg.Filter = "PDF-File (*.pdf)|*.pdf|All Files (*.*)|*.*"
    oFileDlg.FilterIndex = 1

    oFileDlg.DialogTitle = "Save File Test"
    oFileDlg.InitialDirectory = "C:\Temp"

    oFileDlg.CancelError = True

    On Error Resume Next
    oFileDlg.ShowSave

    ' If an error was raised, the user clicked cancel, otherwise display the filename.
    If Err Then
        MsgBox "User cancelled out of dialog"
    ElseIf oFileDlg.FileName <> "" Then
        MsgBox "File " & oFileDlg.FileName & " was selected."
    End If
End Sub

---

Das alle Seiten gespeichert werden steht doch schon in deinem Code:

Code:

---

oOptions.Value("Sheet_Range") = kPrintAllSheets

---

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

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

---

Hallo.
OK. Der Code von euch funktioniert, aber ich möchte in meinem Code diese Abfrage ob er das speichern darf. Er soll es nicht automatisch speichern. Aber es sollen schon alle Eingaben von mir enthalten sein.
Das Datum habe ich nun mit eingefügt.

Code:

---

Sub Pdf_in_Änderungen_und_Datum()
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) & "\Änderungen\" & fso.GetBaseName(dDoc.FullFileName) & "-" & Date & ".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

---

Danke für eure Mühe.

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

---

Hallo

Du solltest mein Bespiel benutzen, um a) den Speichern unter Dialog zu sehen und b) auch darauf reagieren zu können ob überhaupt gespeichert werden soll. Dafür hat der Dialog einen Abbrechen-Button. 
Achja, das initiale Zielverzeichnis wird nicht auf seine Existienz oder fehlende Schreibrechte geprüft.

Code:

---

Option Explicit

Sub Pdf_in_Änderungen_und_Datum()
Dim oDoc As Document
Dim dDoc As DrawingDocument
Dim fso As Object
Dim ret As Variant
Dim outfile As String

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) & "\Änderungen\" & fso.GetBaseName(dDoc.FullFileName) & "-" & Date & ".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
 
            ' Create a new FileDialog object.
            Dim oFileDlg As Inventor.FileDialog ' FileDialog
            Call ThisApplication.CreateFileDialog(oFileDlg)

            oFileDlg.Filter = "PDF-File (*.pdf)|*.pdf|All Files (*.*)|*.*"
            oFileDlg.FilterIndex = 1

            oFileDlg.DialogTitle = "Save File Test"
            oFileDlg.InitialDirectory = "C:\Temp"
   
            oFileDlg.FileName = outfile
   
            oFileDlg.CancelError = True

            On Error Resume Next
            oFileDlg.ShowSave

            ' If an error was raised, the user clicked cancel, otherwise display the filename.
            If Err Then
                MsgBox "User cancelled out of dialog. Resuming next file."
            ElseIf oFileDlg.FileName <> "" Then
                oDataMedium.FileName = oFileDlg.FileName

                ' 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
    End If
Next

End Sub

---

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

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

---

Hallo.
Super!
Mit dem Zielverzeichnis und deren Existenz hast du recht. Wenn das auch noch rein kommt, das es erstellt wird wenn es nicht vorhanden ist, würde es perfekt sein.
Vielen Dank für deine Mühe.

Falko

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