Anbei ein Code zum Anpassen: Speichert aus der Zeichnung an vorgebenen Pfad
Sub Export_PDF_DXF_Step()
Call Export_PDF
Call Export_Step
MsgBox "PDF/Step wurde unter -- C:\Collaboration\Exchange -- gespeichert!!"
End Sub
Sub Export_PDF()
'Reference zum Aktiven Dokument erstellen
Dim oDocument As Document
Set oDocument = ThisApplication.ActiveDocument
Dim bErr As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
Dim ret As Variant
Set ddoc = ThisApplication.ActiveDocument
'Nachricht fall Dokument noch nicht gespeichert ist
If ddoc.FullFileName = "" Then
MsgBox "Bitte zuerst die Datei speichern... "
Exit Sub
End If
'PDF translator Add-In ansprechen
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
'NameValueMap object erstellen
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
'DataMedium object erstellen
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
'Iprops lesen
'Dim oDiName As Inventor.Property
'On Error GoTo ErrorHandler
'Set oDiName = ddoc.PropertySets(4).Item("ET-Listen Nr.")
Dim oDiName1 As Inventor.Property
On Error GoTo ErrorHandler
Set oDiName1 = ddoc.PropertySets(4).Item("Zeichnungsnummer")
Dim oDiName2 As Inventor.Property
On Error GoTo ErrorHandler
Set oDiName2 = ddoc.PropertySets(4).Item("Revision")
'Dim oDiName3 As Inventor.Property
'On Error GoTo ErrorHandler
'Set oDiName3 = ddoc.PropertySets(4).Item("Bezeichnung1")
'SaveCopyAs' options einstellen
If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
oOptions.Value("All_Color_AS_Black") = False
oOptions.Value("Remove_Line_Weights") = False
oOptions.Value("Vector_Resolution") = 4800
oOptions.Value("Sheet_Range") = kPrintAllSheets
'oOptions.Value("Custom_Begin_Sheet") = 2
'oOptions.Value("Custom_End_Sheet") = 4
'Dateinamen mit Pfad erstellen
If bErr = False Then
'FileName = "C:\Collaboration\Exchange\" & oDiName.Value & "_" & oDiName2.Value & ".pdf"
filename = "C:\Collaboration\Exchange\" & Replace(oDiName1.Value, ".", ".") & "_" & oDiName2.Value & ".pdf"
'filename = "C:\Collaboration\Exchange\" & oDiName.Value & ".pdf"
oDataMedium.filename = Strings.Replace(filename, "/", "_")
Else
oDataMedium.filename = "C:\Collaboration\Exchange\" & NameSplit(oDocument.FullFileName) & ".pdf"
End If
'Dokument puplizieren
End If
Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
Exit Sub
ErrorHandler:
bErr = True
Resume Next
End Sub
Sub Export_Step()
'Referenz zu Aktiven Dokument setzen
Dim oDoc As Inventor.Document
Set oDoc = ThisApplication.ActiveDocument
Set oDef = oDoc.ReferencedDocuments.Item(1)
'Iprops lesen
Dim oProp As Property
Dim sPropValue As String
For Each oProp In oDef.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
If oProp.Name = "Artikel-Nr." Then
'If oProp.Name = "Anzeigename" Then
'sPropValue1 = Left(oProp.Value, 12)
sPropValue1 = oProp.Value
End If
Next
For Each oProp In oDef.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
Dim sPropValue2 As String
If oProp.Name = "Index" Then
sPropValue2 = oProp.Value
End If
Next
'STEP translator Add-In setzen
Dim oSTEPTranslator As TranslatorAddIn
Set oSTEPTranslator = ThisApplication.ApplicationAddIns.ItemById("{90AF7F40-0C01-11D5-8E83-0010B541CD80}")
If oSTEPTranslator Is Nothing Then
MsgBox "STEP Translater nicht aufrufbar."
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(oDef, oContext, oOptions) Then
'Optionen Export Step setzen
' 2 = AP 203 - Configuration Controlled Design
' 3 = AP 214 - Automotive Design
oOptions.Value("ApplicationProtocolType") = 3
oContext.Type = kFileBrowseIOMechanism
Dim oData As DataMedium
Set oData = ThisApplication.TransientObjects.CreateDataMedium
'oData.filename = "C:\Collaboration\Exchange\" & sPropValue1 & ".stp"
oData.filename = "C:\Collaboration\Exchange\" & sPropValue1 & "_" & sPropValue2 & ".stp"
'Bestehende Versionen im Pfad l�schen
Dim sFileName As String
sFileName = Dir("C:\Collaboration\Exchange\" & sPropValue1 & "_" & "*.stp")
Do While sFileName <> ""
Kill "C:\Collaboration\Exchange\" & sFileName
sFileName = Dir
Loop
Call oSTEPTranslator.SaveCopyAs(oDef, oContext, oOptions, oData)
End If
End Sub
------------------
MFG
BlueJay
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP