Code:
' "Optionen":
Const bAblagePfadZentral As Boolean = True
'True: alle DXF werden im gleichen Verz. gespeichert
'False: DXF wird in Pfad gespeichert, wie die geöffnete ipt
Const sAblagePfadZentral As String = "C:\temp\"
'hier Pfad einstellen, \ am Ende!
'hier landen die DXF, wenn bAblagePfadZentral = True (sonst bedeutungslos)
'Verzeichnis muss existieren!
Const bDateiAmEndeSchliessen As Boolean = False
'True: nach dem Export wird das aktive Dokument geschlossen (ohne Nachfrage bzgl. Speichern)
'False: Datei bleibt geöffnet
Const bSchlussmeldungAnzeigen As Boolean = True
'True: am Ende wird eine "Fertig"-Meldung angezeigt
'False: keine MeldungDim gsFertigMsg As String
Option Explicit
Public Sub ExportFace2DXF()
' Aufruf für das Sub unten
' hier steckt die Bildung des Dateinamen
'
' KraBBy 2022-05
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
'richtiger Dateityp geoeffnet?
If Not TypeOf oDoc Is PartDocument Then
MsgBox "Makro nur für Bauteile!", vbInformation + vbOKOnly, "Makro abgebrochen"
Exit Sub
End If
Dim oPrtDoc As PartDocument
Set oPrtDoc = oDoc
'Pfad
Dim sPfad As String
If bAblagePfadZentral Then 'Schalter siehe ganz oben im Modul
sPfad = sAblagePfadZentral
Else 'Speicherort der ipt verwenden
sPfad = getPathName(oPrtDoc.FullFileName)
End If
If "" = sPfad Then
MsgBox "Pfad ist leer." & vbCrLf & "Datei noch nicht gespeichert?", vbQuestion + vbOKOnly, "Makro abgebrochen"
Exit Sub
End If
'Text fuer Schlussmeldung vorbereiten
gsFertigMsg = "Im Verzeichnis " & vbCrLf & sPfad & vbCrLf _
& "wurde erstellt:" & vbCrLf & vbCrLf
'Dateiname
Dim sDateiName As String
sDateiName = GetFileName(oPrtDoc.FullFileName)
' (Dateiendung kommt spaeter)
If "" = sDateiName Then
MsgBox "Dateiname ist leer." & vbCrLf & "Datei noch nicht gespeichert?", vbQuestion + vbOKOnly, "Makro abgebrochen"
Exit Sub
End If
'Aufruf von Sub unten mit der eigentlichen Arbeit
Call ExportFaceToDXF(sPfad, sDateiName, oPrtDoc)
If bSchlussmeldungAnzeigen Then
MsgBox gsFertigMsg, vbOKOnly, "Fertig"
Else 'nix tun
End If
If bDateiAmEndeSchliessen Then
Call oPrtDoc.Close(SkipSave:=True)
Else 'nix tun
End If
'Aufraeumen
Set oDoc = Nothing
Set oPrtDoc = Nothing
End Sub
Private Sub ExportFaceToDXF(Optional sPfad As String, Optional sDatName As String, Optional oDoc As Document)
' User wählt eine Fläche aus, diese wird als dxf exportiert
' enstspricht dem Befehl "Fläche exportieren als..."
' keine Möglichkeit (bekannt) Layer etc. anzugeben
'
If "" = sPfad Then
sPfad = "C:\Temp\"
sDatName = "temptest"
End If
If oDoc Is Nothing Then 'wenn referenz nicht übergeben wird (weil optional)
Set oDoc = ThisApplication.ActiveDocument
End If
'Dateiname inkl. Pfad zusammensetzen
Dim sFile As String
sFile = sPfad & sDatName 'ohne Dateiendung!!!
'Prüfen, ob Datei bereits existiert
Dim ret
If Test_FileExists(sFile & ".dxf") Then
ret = MsgBox("Datei existiert bereits. Überschreiben?" & vbCrLf _
& sFile & ".dxf", vbYesNoCancel, "ExportFaceToDXF")
If vbYes = ret Then
'(bei vbYes muss nichts weiter gemacht werden -> Funktion überschreibt best. Datei)
ElseIf vbNo = ret Then
Dim iCount As Integer: iCount = 0
Do
sFile = sFile & "_" 'Dateiname ändern
sDatName = sDatName & "_" 'auch hier ändern damit gsFertigMsg passt
iCount = iCount + 1
If 5 < iCount Then 'Endlosschleife verhindern
MsgBox "Kein DXF erzeugt!" & vbCrLf & "es existieren bereits mehrere Dateien mit diesem Dateinamen (und angehängtem '_')" _
, vbCritical, "jetzt is aber mal gut!"
Exit Sub
End If
Loop Until "" = Dir(sFile & ".dxf")
Else 'Cancel gedrückt oder MsgBox geschlossen (oben rechts)
MsgBox "Abbruch durch Benutzer" & vbCrLf & "Kein DXF erzeugt!", vbOKOnly, "ExportFaceToDXF abgebrochen"
Exit Sub
End If
End If
sFile = sFile & ".dxf" 'jetzt mit Dateiendung
On Error GoTo ErrHnd
' eigentlicher Programm-Ablauf
'Dim oDoc As PartDocument
'Set oDoc = ThisApplication.ActiveDocument
Dim oBaseFace As Face
Set oBaseFace = ThisApplication.CommandManager.Pick(kPartFacePlanarFilter, "Pick a face")
If oBaseFace Is Nothing Then
MsgBox "Abbruch durch Benutzer", vbInformation, "nichts gewählt"
Exit Sub
End If
oDoc.SelectSet.Select oBaseFace
Dim oCtrlDef As ButtonDefinition
Set oCtrlDef = ThisApplication.CommandManager.ControlDefinitions.Item("GeomToDXFCommand")
ThisApplication.CommandManager.PostPrivateEvent kFileNameEvent, sFile
' sollte sich die Datei nicht überschr. lassen tritt eine IV-Fehlermeldung auf ~"Fehler beim DXF-Export" - im Grunde so OK
oCtrlDef.Execute
gsFertigMsg = gsFertigMsg & sDatName & ".dxf" & vbCrLf
'Aufräumen
Set oBaseFace = Nothing
Set oCtrlDef = Nothing
Exit Sub
ErrHnd:
MsgBox "Fehler in Sub 'ExportFaceToDXF': " & vbCrLf & vbCrLf & Err.Description, vbCritical, "Err.Number: " & Err.Number
End Sub
' ----- Hilfsfunktionen:
Public Function Test_FileExists(sFile As String) As Boolean
' existiert Datei?
' Rückgabewert True: Datei existiert
On Error GoTo err_handler
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(sFile) Then
'MsgBox "Datei existiert nicht", vbInformation, "Fehler in 'FileExists'"
Test_FileExists = True
Else
Test_FileExists = False
End If
Set fs = Nothing
Exit Function
err_handler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Fehler im Funktion 'FileExists'"
End Function
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 \
'
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
Public Function getPathName(sDatei_m_Pfad_u_Endung As String) As String
'liefert den Dateinamen ohne Pfad und Dateiendung
'ausgehend vom vollständigen Dateinamen (inkl. Pfad und ggf. Endung)
'rein text-basiert. keine Prüfung, ob Datei oder Pfad existiert oä.
'
' Sonderfälle:
' Eingabe "" -> Rückgabe ""
' kein \ enthalten -> Rückgabe ""
' wird bereits ein Pfad angegeben mit \ am Ende, wird dieser unverändert zurückgegeben
'
getPathName = "" 'Default-Rückgabewert
If sDatei_m_Pfad_u_Endung = "" Then Exit Function
Dim lSlash As Long
lSlash = InStrRev(sDatei_m_Pfad_u_Endung, "\") 'Index von dem letzten BackSlash
If 0 = lSlash Then Exit Function
Dim sReturn As String 'wird am Ende zurückgegeben
sReturn = Left$(sDatei_m_Pfad_u_Endung, lSlash)
'Slash am Ende ist enthalten!
getPathName = sReturn
End Function
Foren auf CAD.de (alle Foren)
| 
lesen gefährdet die Dummheit 
