Code:
Public Class ThisRule
'verwendete Konstanten / "Einstellungen"
Const strIniFile As String = "C:\TEMP\DXF_Export.ini" 'darin: ALL SHEETS=No
Const strExportPath As String = "C:\TEMP\"
Const bShowFolder As Boolean = True 'am Ende Speicherort anzeigenSub Main
Dim oDoc As Inventor.DrawingDocument
oDoc = ThisApplication.ActiveDocument
'Dateiname
Dim strFName As String = oDoc.FullFileName
strFName = GetFileName(strFName)
'Aktives Blatt merken
Dim oSheetLastActive As Inventor.Sheet = oDoc.ActiveSheet
'Schleife durch alle Blätter
' wenn Blattname mit "dxf" beginnt (klein/GROSS egal)
' wird exportiert
Dim oSh As Inventor.Sheet
Dim strName As String
Dim i As Integer = 1
For Each oSh In oDoc.Sheets
If "DXF" = UCase(Left(oSh.Name,3))
oSh.Activate
strName = strFName & "_" & i
'hier wird nur eine laufende Nr. angehängt
Export_DXF(oDoc, strName)
i+=1
Else ' nix, zum nächsten Blatt
End If
Next
'gemerktes Blatt wieder aktivieren
oSheetLastActive.Activate
'Speicherort aufrufen
If bShowFolder Then ThisDoc.Launch(strExportPath)
End Sub
Private Sub Export_DXF(oDocument As Document, strDatName As String)
' Get the DXF translator Add-In.
Dim DXFAddIn As TranslatorAddIn
DXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
'Set a reference to the active document (the document to be published).
' Dim oDocument As Document
' oDocument = ThisApplication.ActiveDocument 'wird als Parameter übergeben
Dim oContext As TranslationContext
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
' Create a NameValueMap object
Dim oOptions As NameValueMap
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
' Create a DataMedium object
Dim oDataMedium As DataMedium
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
' Check whether the translator has 'SaveCopyAs' options
If DXFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
' Dim strIniFile As String
' strIniFile = "C:\VAULT_WORK\CDN_Vault\Templates\Inventor\Macros\DXF_Export.ini" ' "C:\temp\dxfout.ini"
'iniFile siehe Deklarationen auf KlassenEbene
' Create the name-value that specifies the ini file to use.
oOptions.Value("Export_Acad_IniFile") = strIniFile
End If
'Set the destination file name
'oDataMedium.FileName = ThisDoc.PathAndFileName(False) & ".dxf"
oDataMedium.FileName = strExportPath & strDatName & ".dxf"
'Publish document.
DXFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
'Launch the dxf file in whatever application Windows is set to open this document type with
' i = MessageBox.Show("Preview the DXF file?", "Title",MessageBoxButtons.YesNo,MessageBoxIcon.Question)
' If i = vbYes Then ThisDoc.Launch(oDataMedium.FileName)
End Sub
Public Function GetFileName(sDatei_m_Pfad_u_Endung As String) As String
'liefert den Dateinamen ohne Pfad und Dateiendung
'ausgehend vom vollständigen Dateinamen (inkl. Pfad und Endung)
'rein text-basiert. keine Prüfung, ob Dateiexistiert oä.
' Pfad muss nicht enthalten sein
' der Dateiname darf mehrere Punkte enthalten (es wird nur der Text samt dem letzten Punkt entfernt)
'
' Sonderfälle:
' Eingabe "" -> Rückgabe ""
' kein \ enthalten -> es wird die Dateiendung entfernt
' kein . enthalten -> es wird am Ende nichts entfernt
' kein . nach dem letzten \ aber vorher -> liefert alles nach dem letzten \
'
'KraBBy 08.01.2021
GetFileName = "" 'Default-Rückgabewert
If sDatei_m_Pfad_u_Endung = "" Then Exit Function
Dim s As String
s = sDatei_m_Pfad_u_Endung 'nur damit nicht der lange VarName mitgeschleppt werden muss
Dim lSlash As Long
lSlash = InStrRev(s, "\") 'Index von dem letzten BackSlash
'sollte keiner vorhanden sein, ist das im weiteren kein Problem (lSlash=0, später je +1)
Dim lDot As Long
lDot = InStrRev(s, ".") 'index vom letzten Punkt
Dim sReturn As String 'wird am Ende zurückgegeben
If lDot = 0 Then
'kein Punkt enthalten!
sReturn = Mid$(s, lSlash + 1) 'am Ende nichts entfernen
ElseIf lDot < lSlash Then
'Punkt VOR dem letzten Backslash (also im Pfad)
sReturn = Mid$(s, lSlash + 1) 'am Ende nichts entfernen
Else
'Standardfall: Punkt enthalten, nach dem letzten Backslash
sReturn = Mid$(s, lSlash + 1, lDot - lSlash - 1)
'+1: Slash soll nicht enthalten sein
'-1: Punkt soll nicht enthalten sein
End If
GetFileName = sReturn 'Rückgabewert der Function
End Function
End Class
Foren auf CAD.de (alle Foren)
| 
