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") = 1

        '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