Public Sub DWG_1()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    Dim dwgname As String
    dwgname = Mid(oDrawDoc.FullFileName, 1, Len(oDrawDoc.FullFileName) - 4)

'Stop
    'Aufruf der Funktion "Export2DWG" - Zeichnungsname ohne .dwg
    Call Export2DWG(dwgname, "E:\IV9 Daten\Einstellungen\idw 2 dwg1.ini")

End Sub

Public Sub DWG_2()
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    Dim dwgname As String
    dwgname = Mid(oDrawDoc.FullFileName, 1, Len(oDrawDoc.FullFileName) - 4)

    'Aufruf der Funktion "Export2DWG" - Zeichnungsname ohne .dwg
    Call Export2DWG(dwgname, "E:\IV9 Daten\Einstellungen\idw 2 dwg2.ini")

End Sub



Public Function Export2DWG(ByVal strFP As String, ByVal strFP1 As String)

    Dim oApp As Application
    Set oApp = ThisApplication

    Dim oDoc As DrawingDocument
    Set oDoc = ThisApplication.ActiveDocument

    Dim bSaveAsCopyOptions As Boolean
    Dim oAppAddIns As ApplicationAddIns
    Dim oDataMedium As DataMedium
    Dim oDWGTransl As TranslatorAddIn
    Dim oTransObjs As TransientObjects
    Dim oTranslCntxt As TranslationContext
    Dim oNameValMap As NameValueMap
    Dim intIndex As Integer

    Set oAppAddIns = oApp.ApplicationAddIns


    For intIndex = 1 To oAppAddIns.Count
        If oAppAddIns(intIndex).ShortDisplayName = "Autodesk DWG-Translator" Then
            Set oDWGTransl = oAppAddIns.Item(intIndex)
            Exit For
        End If
    Next intIndex

    'Translation Objekte setzen

    Set oTransObjs = oApp.TransientObjects
    Set oNameValMap = oTransObjs.CreateNameValueMap
    Set oTranslCntxt = oTransObjs.CreateTranslationContext
    Set oDataMedium = oTransObjs.CreateDataMedium

    oTranslCntxt.Type = kFileBrowseIOMechanism

    bSaveAsCopyOptions = oDWGTransl.HasSaveCopyAsOptions(oDataMedium, oTranslCntxt, oNameValMap)

    oDataMedium.FileName = strFP & ".dwg"


    'Hier Pfad und Dateiname angeben wo die .ini Datei sich befindet!!!
    oNameValMap.Value("Export_Acad_IniFile") = strFP1

    oDWGTransl.SaveCopyAs oDoc, oTranslCntxt, oNameValMap, oDataMedium

    Set oAppAddIns = Nothing
    Set oDataMedium = Nothing
    Set oDWGTransl = Nothing
    Set oTransObjs = Nothing
    Set oTranslCntxt = Nothing
    Set oNameValMap = Nothing

End Function