Code:
Function GetRevision(oDoc As Document) As String
'Propertie Kategorie als Variable speichern
Dim oPropSet As PropertySet
Set oPropSet = oDoc.PropertySets("Inventor - Zusammenfassungsinformationen") 'Revsions-Wert an Funktion übergeben
GetRevision = oPropSet.Item("Revision Number").Value
End Function
Sub ExportAllOpenFileToPDF()
Dim I As Integer
For I = 1 To ThisApplication.Documents.VisibleDocuments.Count
'Dokument als PDF exportieren
Call ExportToPDF(ThisApplication.Documents.VisibleDocuments(I))
Next I
End Sub
Sub ExportOpenFileToPDF()
'Dokument als PDF exportieren
Call ExportToPDF(ThisApplication.ActiveDocument)
End Sub
Sub ExportToPDF(oDoc As Document)
'Wenn das Dokument keine 2D-Ableitung ist, dann Prozedur verlassen
If oDoc.DocumentType <> kDrawingDocumentObject Then Exit Sub
'Translater Add-In aufrufen
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
'Eigenschaften Erstellen
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
'Datenmedium-Objekt erstellen
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
' Set a reference to the DesignProjectManager object.
Dim oDesignProjectMgr As DesignProjectManager
Set oDesignProjectMgr = ThisApplication.DesignProjectManager
'Revision ermitteln
Dim oRev As String
oRev = basFunction.GetRevision(oDoc)
'aktuellen Workspace Pfad ermitteln
Dim sPath As String
sPath = oDesignProjectMgr.ActiveDesignProject.WorkspacePath & "\"
' 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 = "PDF speichern unter"
oFileDlg.SuppressResolutionWarnings = True
If oRev <> "" Then
oDataMedium.FileName = sPath & Replace(oDoc.DisplayName, ".idw", oRev & ".pdf")
Else
oDataMedium.FileName = sPath & Replace(oDoc.DisplayName, ".idw", ".pdf")
End If
oFileDlg.FileName = oDataMedium.FileName
oFileDlg.CancelError = True
On Error Resume Next
oFileDlg.ShowSave
'Wenn ein Fehler auftritt, oder Benutzer auf Abbrechen geklickt, andernfalls wird der Dateiname angezeigt
If Err Then
MsgBox "Aktion wurde vom Benutzer abgebrochen!!", vbExclamation, "@Copyright by meierjo"
Exit Sub
ElseIf oFileDlg.FileName <> "" Then
'Pfad und Dateiname anpassen, falls durch Benutzer geändert
oDataMedium.FileName = oFileDlg.FileName
'Prüfen ob der Translator die Option 'SaveCopyAs' unterstützt
If PDFAddIn.HasSaveCopyAsOptions(oDoc, oContext, oOptions) Then
'Export-Optionen festlegen
'* oOptions.Value("All_Color_AS_Black") = 0
'* oOptions.Value("Remove_Line_Weights") = 0
oOptions.Value("Vector_Resolution") = 4800
oOptions.Value("Sheet_Range") = kPrintAllSheets
'* oOptions.Value("Custom_Begin_Sheet") = 2
'* oOptions.Value("Custom_End_Sheet") = 4
Call PDFAddIn.SaveCopyAs(oDoc, oContext, oOptions, oDataMedium)
'wenn PDF in anderem Kontext geöffnet, gibt's hier eine Fehlermeldung
If Err Then Exit Sub
End If
End If
Err = 0
'MsgBox "PDF unter " & oDataMedium.FileName & " abgelegt!!", vbOKOnly, "@Copyright by meierjo"
'PDF mit dem Standard-Reader öffnen
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
'Chr(34) generiert ein Anführungszeichen vor und nach dem Dateipfad / Dateinamen, falls ein Leerschlag im Pfad vorkommt
WshShell.Run Chr(34) & oFileDlg.FileName & Chr(34)
Set WshShell = Nothing
'CreateObject("Wscript.Shell").Run oFileDlg.FileName
End Sub
Foren auf CAD.de (alle Foren)
| 
