---

Moin Moin

Ich habe 2 Makros, die ich gerne zusammenführen möchte.
Das eine ist ein Makro um alle geöffneten Zeichnungen in PDF zu exportieren und das andere für DWG.

Ich habe leider so gut wie keine Ahnung was VBA angeht.
Folgendes habe ich mal probiert:

Option Explicit

Public Sub Komplett_Export()

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) & ".dwg"
                dDoc.SaveAs outfile, True
            Else
                MsgBox "Erst alles Speichern", vbInformation
               
        End If
Next

End Sub

Private Sub Komplett_Export()
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") = 1

        oOptions.Value("Remove_Line_Weights") = 0
        oOptions.Value("Vector_Resolution") = 1200
        oOptions.Value("Sheet_Range") = kPrintAllSheets
        oOptions.Value("Custom_Begin_Sheet") = 1
        oOptions.Value("Custom_End_Sheet") = 5

    '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

Wäre toll wenn wer helfen kann. 

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

Chris

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

---

Hallo Chris,

was genau meinst du denn mit "zusammenführen"?
Falls du beide nacheinander/gleichzeitig laufen lassen möchtest (also mit einem Klick auslösen), dann gibt es mehrere Möglichkeiten.

1.) Du schreibst eine neue Sub, in der du beide nacheinander aufrufst

Code:

---

Public Sub Aufrufen
Call Komplett_Export_DWG()
Call Komplett_Export_PDF()
End Sub

---

2.) Du entfernst einfach folgende Zeilen am Anfang des zweiten Sub:

Code:

---

End Sub

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

---

So würde der erste Sub einfach weiter laufen, wenn er aufgerufen wird.

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

Chris

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

---

Damit funktioniert es. 

Public Sub Komplett_Export()
Call Komplett_Export_DWG
Call Komplett_Export_PDF
End Sub

Private Sub Komplett_Export_DWG()
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) & ".dwg"
                dDoc.SaveAs outfile, True
            Else
                MsgBox "Erst alles Speichern", vbInformation
                Exit Sub
            End If
        End If
Next
End Sub

Private Sub Komplett_Export_PDF()
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") = 1

        oOptions.Value("Remove_Line_Weights") = 0
        oOptions.Value("Vector_Resolution") = 1200
        oOptions.Value("Sheet_Range") = kPrintAllSheets
        oOptions.Value("Custom_Begin_Sheet") = 1
        oOptions.Value("Custom_End_Sheet") = 5

    '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

Vielen Dank für die Hilfe! 

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

Chris

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