Code:
Public Sub dwg()
If getMaterial = False Or DrawingFilloutCheck() = False Then
GoTo DWG_ENDE
End If
' Get the DWG translator Add-In.
Dim DWGAddIn As TranslatorAddIn
Set DWGAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}") 'Set a reference to the active document (the document to be published).
Dim oDocument As Document
Set oDocument = ThisApplication.ActiveDocument
Dim transObjs As TransientObjects
Set transObjs = ThisApplication.TransientObjects
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
Set oOptions = transObjs.CreateNameValueMap
' Create a DataMedium object
Dim oDataMedium As dataMedium
'Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium '1 Version dwg inventor
Set oDataMedium = transObjs.CreateDataMedium '2 Version dwg autocas 2000
' Check whether the translator has 'SaveCopyAs' options
'If DWGAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
'
' Dim strIniFile As String
' strIniFile = "C:\tempDWGOut.ini"
' ' Create the name-value that specifies the ini file to use.
' oOptions.Value("Export_Acad_IniFile") = strIniFile
' End If
Dim oDoc As Document
Dim Länge_Dateiname_mit_Pfad As Integer
Dim Name_Pfad As String
Dim Pfad_export As String
Dim Länge_String As Integer
Dim Dateiname_mit_Pfad As String
Set oDoc = ThisApplication.ActiveDocument
'____________________________________________________________________iProperties_______________________________________
' Get the PropertySets object.
Dim oPropSets As PropertySets
Set oPropSets = oDoc.PropertySets
' Get the design tracking property set.
Dim oPropSet As PropertySet
Set oPropSet = oPropSets.item("Design Tracking Properties")
' Get the drawing number iProperty.
'Dim status As Property
'Set status = oPropSet.Item("User Status")
'Get the ipt status iProperty
'Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Dim oReferencedDoc As Document
On Error GoTo 0
Dim myValue As Integer
NeuDurchlauf:
myValue = "1"
If oDrawDoc.ReferencedDocuments.Count > 1 Then
Dim input_string As String
Dim index1 As String
Dim index2 As String
index1 = oDrawDoc.ReferencedDocuments.item(1).PropertySets.item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").item("User Status").Value
index2 = oDrawDoc.ReferencedDocuments.item(2).PropertySets.item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").item("User Status").Value
input_string = "Wählen Sie von: " & Chr(13) & "1: " & GetFilenameFromPath(oDrawDoc.ReferencedDocuments.item(1).FullFileName) & " Index: " & index1 & Chr(13)
input_string = input_string & "2: " & GetFilenameFromPath(oDrawDoc.ReferencedDocuments.item(2).FullFileName) & " Index: " & index2 & Chr(13)
If oDrawDoc.ReferencedDocuments.Count > 2 Then '3 or more referenced documents
Dim index3 As String
index3 = oDrawDoc.ReferencedDocuments.item(3).PropertySets.item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").item("User Status").Value
input_string = input_string & "3: " & GetFilenameFromPath(oDrawDoc.ReferencedDocuments.item(3).FullFileName) & " Index: " & index3 & Chr(13)
End If
If oDrawDoc.ReferencedDocuments.Count > 3 Then '4 or more referenced documents
Dim index4 As String
index4 = oDrawDoc.ReferencedDocuments.item(4).PropertySets.item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").item("User Status").Value
input_string = input_string & "4: " & GetFilenameFromPath(oDrawDoc.ReferencedDocuments.item(4).FullFileName) & " Index: " & index4 & Chr(13)
End If
On Error GoTo DWG_ENDE
myValue = InputBox(input_string, "Referenzierung auswählen...")
If oDrawDoc.ReferencedDocuments.Count < myValue Then
GoTo NeuDurchlauf
End If
End If
On Error GoTo 0
'Set oReferencedDoc = oDrawDoc.ReferencedDocuments.item(myValue)
oReferencedDoc = SelectReferencedDoc(ThisApplication.ActiveDocument)
Debug.Print oReferencedDoc
Dim oPropValue As String
oPropValue = oReferencedDoc.PropertySets.item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").item("User Status").Value
Dim oRev As String
oRev = oReferencedDoc.PropertySets.item("{F29F85E0-4FF9-1068-AB91-08002B27B3D9}").item("Revision Number").Value
' Display the value.
'MsgBox "Status der Datei: " & oPropValue
'______________________________________________________________________iProperties__________________________________________
Dateiname_mit_Pfad = oDoc.FullFileName
If Dateiname_mit_Pfad = "" Then
MsgBox "Dokument wurde noch nicht gespeichert, export nicht möglich!", vbCritical, "Dokument nicht gespeicher!"
GoTo DWG_ENDE
End If
Länge_Dateiname_mit_Pfad = Len(Dateiname_mit_Pfad)
Dim endung As Integer
'Endung = 0 'mit .ipt usw.
endung = 4 ' ohne .ipt usw
Name_Pfad = Mid(Dateiname_mit_Pfad, 1, Länge_Dateiname_mit_Pfad - 4)
Länge_String = Len(Name_Pfad)
Dim i As Integer
i = 1
Do Until Mid(Name_Pfad, Länge_String - i, 1) = "\"
i = i + 1
Loop
'MsgBox i 'Anzahl der Buchstaben vom Dateinamen
Dateiname = Right(Name_Pfad, i)
If UserForm1.CheckBox_cut15 = False And Len(Dateiname) > 15 Then
Dim msgwert As Integer
msgwert = MsgBox("Dateiname länger als 15 Zeichen:" & vbNewLine & Dateiname & vbNewLine & "kürzen auf:" & vbNewLine & Mid(Dateiname, 1, 15) & " ?", vbYesNo, "Export")
'MsgBox "Dateiname Länge: " & Len(Dateiname) & " Inhalt: " & Dateiname
End If
If UserForm1.CheckBox_cut15 = True Or msgwert = 6 Then
Dateiname = Mid(Dateiname, 1, 15) 'Auf 15 Zeichen kürzen
'MsgBox "Gekürzt! Wert: " & msgwert & "Dateiname Länge: " & Len(Dateiname)
End If
'MsgBox Dateiname
Name_Pfad = Mid(Dateiname_mit_Pfad, 1, Länge_Dateiname_mit_Pfad - i - endung)
'MsgBox Name_Pfad
'MsgBox "Dateiname : " & Dateiname & Chr(10) & "Pfad : " & Name_Pfad & Chr(10) & "Laufwerk: " & destination & Pfad_export
'___________________________________________________DWG Form 2000/2004/...______________________________________________________________________
' Get the available options from the translator.
'Dim options As NameValueMap
'Set options = transObjs.CreateNameValueMap
If DWGAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
' Set the options for what types of data to write out.
oOptions.Value("Solid") = True ' Output solids.
oOptions.Value("Surface") = False ' Output surfaces.
oOptions.Value("Sketch") = False ' Output sketches.
oOptions.Value("USE TRANSMITTAL") = No
oOptions.Value("Use_Transmittal") = No
' Set the DWG version.
' 23 = ACAD 2000 - AC1015
' 25 = ACAD 2004 - AC1018
' 27 = ACAD 2007
' 29 = ACAD 2010 - AC1024
oOptions.Value("DwgVersion") = 25
End If
'___________________________________________________DWG Form 2000/2004/...______________________________________________________________________
'MsgBox Dateiname
'TheFolder$ = BrowseForFolder("Wählen Sie einen Ordner aus.")
Dim last_export_folder_dwg As String
last_export_folder_dwg = GetIniValue("IS-Tool (" & Environ$("Username") & ")", "last_dwg")
' Wenn nichts gefunden wird wird der Error ausgegeben
If last_export_folder_dwg = "!!!IniError!!!" Then
' Standard auf False gesetzt
MsgBox ("Auslesen des letzten Export-Ordner fehlgeschlagen")
Exit Sub
Else
' Wenn etwas gefunden wird wird der Wert True/False der Checkbox zugewiesen
'MsgBox "last_export_folder: " & vbNewLine & last_export_folder
last_export_folder_dwg = CutRight(last_export_folder_dwg, "\")
'MsgBox "CutRight: " & vbNewLine & TheFolder$
End If
If UserForm1.remember_folder.Value = True And UserForm1.ToggleButton_desk.Value = False And UserForm1.ToggleButton_massblatt.Value = False Then
msgwert = MsgBox("In letzten Ordner speichern?" & vbNewLine & "Pfad:" & vbNewLine & last_export_folder_dwg, vbYesNo, "Export")
If Not msgwert = 6 Then
MsgBox "Export abgebrochen!", vbCritical & vbOKOnly
Exit Sub
End If
TheFolder$ = last_export_folder_dwg
ElseIf UserForm1.ToggleButton_massblatt.Value = True Then
TheFolder$ = GetFolder("Wählen Sie einen Ordner aus um " & Dateiname & "_" & oPropValue & ".dwg" & " zu speichern", "\\infs\Dokumente\Maßblätter")
ElseIf UserForm1.ToggleButton_desk.Value = True Then
TheFolder$ = Environ("USERPROFILE") & "\Desktop"
Else
TheFolder$ = GetFolder("Wählen Sie einen Ordner aus um " & Dateiname & "_" & oPropValue & ".dwg" & " zu speichern", "\\INAPP\CAD")
End If
'Set the destination file name
If oPropValue = "" Then
oDataMedium.FileName = TheFolder$ & "\" & Dateiname & ".dwg"
Else
oDataMedium.FileName = TheFolder$ & "\" & Dateiname & "_" & oPropValue & ".dwg"
End If
'Set the destination file name
'oDataMedium.FileName = "c:\tempdwgout.dwg"
'Publish document.
'MsgBox oDataMedium.FileName
On Error GoTo ER_Ansichtfehler
If Not TheFolder$ = "" Then
Call DWGAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
If Not FileFolderExists(oDataMedium.FileName) Then
MsgBox "Fehler beim DWG Export, möglicherweise wurde .zip exportiert!", vbOKOnly, "DWG Fehler!"
Call open_folder(TheFolder$)
End If
If UserForm1.alert.Value = True Then
MsgBox "DWG Export abgeschlossen!", vbOKOnly, "DWG Erstellt!"
End If
If UserForm1.folder_open.Value = True Then
Call open_folder(TheFolder$)
End If
Call PutIniValue("IS-Tool (" & Environ$("Username") & ")", "last_dwg", oDataMedium.FileName)
'Call PutIniValue("IS-Tool (" & Environ$("Username") & ")", "startfolder_dwg", TheFolder$)
Call PutIniValue("IS-Tool (" & Environ$("Username") & ")", "rev_dwg", oRev)
Else
MsgBox "Export abgebrochen, kein Verzeichnis gewählt!"
Exit Sub
End If
' Aufruf des STEP EXPORT ---------------------------------------
If UserForm1.CheckBox_step_export = True Then
step (TheFolder$ & "\" & Dateiname & "_" & oPropValue)
End If
Exit Sub
ER_dokument:
MsgBox "Es wurde kein Dokument gefunden" & vbNewLine & "Error: ''" & Error & "''"
Exit Sub
ER_Ansichtfehler:
MsgBox "Nicht alle Ansichten sind erstellt!" & vbNewLine & "Error: ''" & Error & "''"
Exit Sub
DWG_ENDE:
MsgBox "Export abgebrochen!"
Exit Sub
End Sub
Foren auf CAD.de (alle Foren)
| 
danke für die hilfe hier nun der ganze code:
