---

Guten Morgen zusammen,
villeicht kann mir ja einer helfen - ich habe folgendes Problem, ich habe das folgenden Makro das mir ein PDF in ein vorgegebenes Verzeichnis aus einer idw exportiert. Leider tut es das nur wenn informationen wie Zeichnungsnumemr + Blatt + Index von unserem Datamanagementsystem in den iprops stehen. Bei nur lokal gespeicherten Dateien gibt es diese iprops nicht. Frage wie kann nich das Programm anpassen, das es mir auch ein pdf exportiert wenn diese info nich vorhanden ist?

Anbei der Code

Sub PDFExport()
'Set a reference to the active document (the document to be published).
    Dim oDocument As Document
    Set oDocument = ThisApplication.ActiveDocument
   
    Dim fso As Object
    Set fso = CreateObject("Scripting.FilesystemObject")

    Dim ret As Variant
    Set dDoc = ThisApplication.ActiveDocument
     
      If dDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Datei speichern...  "
        Exit Sub
    End If
   
  ' 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
   
    Dim oZeichNr As Inventor.Property
    On Error Resume Next
    Set oZeichNr = dDoc.PropertySets(4).Item("Zeichnungsnummer")

    Dim oBlattNr As Inventor.Property
    On Error Resume Next
    Set oBlattNr = dDoc.PropertySets(4).Item("Blatt")

    Dim oRevNr As Inventor.Property
    On Error Resume Next
    Set oRevNr = dDoc.PropertySets(4).Item("Index")

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

        '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
 
   
    'Set the destination file name
    oDataMedium.fileName = "C:\GAIN\Exchange\" & "\" & oZeichNr.Value & "-" & oBlattNr.Value & "_" & oRevNr.Value & ".pdf"
  End If    'Publish document.
  Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)

    MsgBox "PDF wurde unter  -- C:\GAIN\Exchange -- gespeichert!!"
 
End Sub

Über alle Hilfe bedanke ich mich jetzt schon

MFG

BlueJay

------------------
MFG

BlueJay

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

---

Hi, probier mal so:

Code:

---

Sub PDFExport()
'Set a reference to the active document (the document to be published).
    Dim oDocument As Document
    Set oDocument = ThisApplication.ActiveDocument
   
    Dim fso As Object
    Set fso = CreateObject("Scripting.FilesystemObject")

    Dim ret As Variant
    Dim dDoc As Document
    Set dDoc = ThisApplication.ActiveDocument
     
      If dDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Datei speichern...  "
        Exit Sub
    End If
   
  ' 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
   
    Dim oZeichNr As String
    On Error Resume Next
    oZeichNr = GetPropertyValue(dDoc, 4, "Zeichnungsnummer")

    Dim oBlattNr As String
    On Error Resume Next
    oBlattNr = GetPropertyValue(dDoc, 4, "Blatt")

    Dim oRevNr As String
    On Error Resume Next
    oRevNr = GetPropertyValue(dDoc, 4, "Index")

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

        '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
 
   
    'Set the destination file name
    If (oZeichNr = "" And oBlattNr = "" And oRevNr = "") Then
        oDataMedium.FileName = "C:\GAIN\Exchange\" & dDoc.DisplayName & ".pdf"
    Else
        oDataMedium.FileName = "C:\GAIN\Exchange\" & "\" & oZeichNr & "-" & oBlattNr & "_" & oRevNr & ".pdf"
    End If
  End If    'Publish document.
  Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)

    MsgBox "PDF wurde unter  -- C:\GAIN\Exchange -- gespeichert!!"
 
End Sub

Function GetPropertyValue(ByRef oDoc As Document, PropertyIndex As Integer, PropertyName As String) As String
    Dim sRet As String
    Err.Clear
    On Error Resume Next
    sRet = oDoc.PropertySets(PropertyIndex).Item(PropertyName).Value
   
    If Err.Number <> 0 Then
        GetPropertyValue = ""
    Else
        GetPropertyValue = sRet
    End If
       
End Function

---

------------------
Grüße Igor

FX64 Software Solutions - Inventor Tools
FX64 LambdaSpect - Lichtsimulation mit Autodesk Inventor

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

---

Hallo

Code:

---

Sub PDFExport()
'Set a reference to the active document (the document to be published).
    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
   
      If dDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Datei speichern...  "
        Exit Sub
    End If
 
  ' 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
 
    Dim oZeichNr As Inventor.Property
    On Error GoTo ErrorHandler
    Set oZeichNr = dDoc.PropertySets(4).Item("Zeichnungsnummer")

    Dim oBlattNr As Inventor.Property
    On Error GoTo ErrorHandler
    Set oBlattNr = dDoc.PropertySets(4).Item("Blatt")

    Dim oRevNr As Inventor.Property
    On Error GoTo ErrorHandler
    Set oRevNr = dDoc.PropertySets(4).Item("Index")

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

        '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

 
    'Set the destination file name
If bErr = False Then
    oDataMedium.FileName = "C:\GAIN\Exchange\" & "\" & oZeichNr.Value & "-" & oBlattNr.Value & "_" & oRevNr.Value & ".pdf"
Else
    oDataMedium.FileName = "C:\GAIN\Exchange\" & NameSplit(oDocument.FullFileName) & ".pdf"
End If
  End If    'Publish document.
  Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)

    MsgBox "PDF wurde unter  -- C:\GAIN\Exchange -- gespeichert!!"

Exit Sub

ErrorHandler:
bErr = True
Resume Next

End Sub

Private Function NameSplit(ByVal sFilename As String) As String

Dim oArray() As String
oArray = Split(sFilename, "\")

NameSplit = Replace(oArray(UBound(oArray)), ".idw", "")

End Function

---

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

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

---

Jetzt die beide zusammenlegen, ausmisten und gut 

------------------
Grüße Igor

FX64 Software Solutions - Inventor Tools
FX64 LambdaSpect - Lichtsimulation mit Autodesk Inventor

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

---

Guten Morgen,
vielen Dank für die gemeinsame Hilfe - Die Routine funktioniert wie sie es soll - echt Super - die Sache mit dem Error Handler hat mir mal wieder etwas beigebracht - Danke noch mal

MFG

------------------
MFG

BlueJay

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