Code:
Public Sub dwg()
' 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
On Error GoTo ER_dokument
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
If Not TypeOf oDrawDoc Is DrawingDocument Then
MsgBox "Funktion nur in einer .idw möglich!"
Exit Sub
End If
Dim oReferencedDoc As Document
Set oReferencedDoc = oDrawDoc.ReferencedDocuments.item(1)
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)
Dateiname = Mid(Dateiname, 1, 15)
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.")
If UserForm1.ToggleButton_massblatt.Value = True Then
TheFolder$ = GetFolder("Wählen Sie einen Ordner aus.", "\\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.", "\\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 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!"
End If
Exit Sub
ER_dokument:
MsgBox "Es wurde kein Dokument gefunden"
Exit Sub
ER_Ansichtfehler:
MsgBox "Nicht alle Ansichten sind erstellt!"
Exit Sub
DWG_ENDE:
End Sub
Foren auf CAD.de (alle Foren)
| 
