Gutne Morgen zusammen,
da wir im Büro immer mit dem DXF Export Probleme hatten, habe ich nun endlich eine Lösung bereit - damit auch andere davon profitieren können stelle ich Sie hier mit für alle bereit(-:
Was muss gemacht werden:
1. In der Stilbibliothek muss ein zusätzlicher Objectstandard (für Export) angelegt werden
2. In der Stilbibliothek müssen die AutoCad Layer definiert werden (AM_0 usw.)
3. ini Datei an passendem Ort abspeichern
4. Ein Ordner Exchange (wird vom Makro gebraucht) muss erstellt werden
5. Das folgende Makro muss eingefügt werden - und die darin angegebenen Pfade müssen angepasst werden - auch zur ini Datei
Was macht das Makro:
1. Es Exporttiert ein DXF mit angepassten Layern zum Ordner Exchange
2. Objektstandard in localer Stilbibliothek wird umgestellt auf die angepasste
3. DXF Translater wird geladen
4. Werte für Dateinamen werden überprüft
5. DXF wird erstellt
6. Bibliothek wird wieder zurück auf die Inventor gängige mit den Objecktstandards zurückgestellt
7. Fertig
Sub Export_DXF()
'Reference zum Aktiven Dokument erstellen
Dim oDocument As Document
Set oDocument = ThisApplication.ActiveDocument
Dim bErr As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FilesystemObject")
Dim ret As Variant
Set dDoc = ThisApplication.ActiveDocument
'Nachricht fall Dokument noch nicht gespeichert ist
If dDoc.FullFileName = "" Then
MsgBox "Bitte zuerst die Datei speichern... "
Exit Sub
End If
'Umstellung auf AutoCAD Export Layer
Dim oDrgStlMgr As DrawingStylesManager
Set oDrgStlMgr = oDocument.StylesManager
Dim oObjDfStl As ObjectDefaultsStylesEnumerator
Set oObjDfStl = oDrgStlMgr.ObjectDefaultsStyles
oDrgStlMgr.ActiveStandardStyle.ActiveObjectDefaults = oObjDfStl.Item("Objektstandards(DIN-AutoCad)")
'PXF translator Add-In ansprechen
Dim DXFAddIn As TranslatorAddIn
Set DXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism
'NameValueMap object erstellen
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
'DataMedium object erstellen
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
Dim oZeichNr As Inventor.Property
On Error GoTo ErrorHandler
Set oZeichNr = dDoc.PropertySets(4).Item("Zeichnungsnummer")
Dim oBlattNr As Inventor.Property
On Error GoTo ErrorHandler
Set oBlattNr = dDoc.PropertySets(4).Item("Blatt")
Dim oRevNr As Inventor.Property
On Error GoTo ErrorHandler
Set oRevNr = dDoc.PropertySets(4).Item("Index")
Dim oName As Inventor.Property
On Error GoTo ErrorHandler
Set oName = dDoc.PropertySets(4).Item("Bezeichnung1")
'SaveCopyAs' options einstellen
If DXFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
Dim strIniFile As String
strIniFile = "\\gainserver\GAIN\GAIN\Iface\Inventor\Templates\R16\VBA\DXF_Export\dxfini.ini"
'Dateinamen mit Pfad erstellen
If bErr = False Then
oDataMedium.fileName = "C:\GAIN\Exchange\" & "\" & oZeichNr.Value & "-" & oBlattNr.Value & "_" & oRevNr.Value & "-" & oName.Value & ".dxf"
Else
oDataMedium.fileName = "C:\GAIN\Exchange\" & NameSplit(oDocument.FullFileName) & ".dxf"
End If
'Dokument puplizieren
End If
Call DXFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
'Umstellung auf Standard Layer
Set oObjDfStl = oDrgStlMgr.ObjectDefaultsStyles
oDrgStlMgr.ActiveStandardStyle.ActiveObjectDefaults = oObjDfStl.Item("Objektstandards(DIN-ESM)")
MsgBox "DXF wurde unter -- C:\GAIN\Exchange -- gespeichert!!"
Exit Sub
ErrorHandler:
bErr = True
Resume Next
End Sub
Private Function NameSplit(ByVal sFilename As String) As String
Dim oArray() As String
oArray = Split(sFilename, "\")
NameSplit = Replace(oArray(UBound(oArray)), ".idw", "")
End Function
Ich hoffe das Programm hilft allen die sich mit diesem Thema rumärgern!
MFG
------------------
MFG
BlueJay
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
