---

Hallo zusammen,

ich hätte eine Frage bezüglich Makros:

Ich habe in Inventor die Zeichnung (.idw) geöffnet und unser Makro ist so programmiert, dass diese automatisch als PDF und DXF abgespeichert werden.
Das Problem das aber auftritt ist, das der Zielordner der DXF und PDF leider bei der Zeichnung sitzt.

Bekomm ich die Abspeicherung der PDF und DXF so hin, dass er mir diese am Desktop speichert?

Hier noch das Makro:

Sub drawing()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
Dim osource As String
Dim odest As String

If oapp.ActiveDocument Is Nothing Then
    Exit Sub
End If

If oapp.ActiveDocumentType <> kDrawingDocumentObject Then
    Exit Sub
End If

Set odoc = oapp.ActiveDocument
osource = odoc.FullFileName
odest = Left(osource, Len(osource) - 4)

Dim osheet As Inventor.Sheet
Dim counter As String

counter = 1

For Each osheet In odoc.Sheets
osheet.Activate
Call odoc.SaveAs(odest & "Blatt" & counter & ".dxf", True)
Call odoc.SaveAs(odest & "Blatt" & counter & ".pdf", True)
counter = counter + 1
Next

End Sub

Über eine Hilfe wäre ich sehr dankbar.

Etwaige Schreibfehler vorbehalten.  

---

Hallo

Ja, sollte so klappen

Sub drawing()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
Dim osource As String
Dim odest As String

If oapp.ActiveDocument Is Nothing Then
    Exit Sub
End If

If oapp.ActiveDocumentType <> kDrawingDocumentObject Then
    Exit Sub
End If

Set odoc = oapp.ActiveDocument
'osource = odoc.FullFileName
osource = Environ("userprofile") & "\Desktop\" & odoc.DisplayName
odest = Left(osource, Len(osource) - 4)

Dim osheet As Inventor.Sheet
Dim counter As String

counter = 1

For Each osheet In odoc.Sheets
osheet.Activate
Call odoc.SaveAs(odest & "Blatt" & counter & ".dxf", True)
Call odoc.SaveAs(odest & "Blatt" & counter & ".pdf", True)
counter = counter + 1
Next

End Sub

Gruss

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

CAD.jpg

Vielen Dank, das klappt gut.

Jetzt wäre für mich noch eine Frage offen:

Mit dem von Ihnen gesendeten Programm speichert es mir die PDF, DXF nicht mit der Dokumentennummer ab (siehe Anhang).
Wie geschieht dies oder was muss umgeschrieben werden?

Da ich leider wenig Ahnung vom programmieren habe, bitte um Hilfe.

Danke im voraus.

Mfg HADI

---

Zitat:

---

Original erstellt von :

Wie geschieht dies oder was muss umgeschrieben werden?

---

Ok, dann schaue Dir erst einmal Dateiname und Bauteilnumer an.... Was fehlt denn da, bzw. wie viele Zeichen fehlen?

Und dann schaue Dir die Zeile an, in der der Dateiname initialisiert wird:

Code:

---

odest = Left(osource, Len(osource) - 4)

---

Was da wohl passiert? Ich denke, da werden 4 Zeichen abgeschnitten. Wenn das man nicht die Zeichen sind, die Du vermisst.

Warum das jetzt passiert, und was Du ändern mußt, kannst Du jetzt ja vielleicht selber erkennen  

CU

------------------
Der vernünftige Mensch paßt sich der Welt an;
der unvernünftige besteht auf dem Versuch, die Welt sich anzupassen.

Deshalb hängt aller Fortschritt vom unvernünftigen Menschen ab.
(George Bernard Shaw)

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

das was da abgeschnitten wird (4 Zeichen am Ende) ist die Dateiendung ".idw"

Meierjo verwendet die Eigenschaft .DisplayName. Das ist die Benennung vom obersten Knoten im Modellbrowser und meist der Dateiname (ohne Pfad). Das lässt sich aber überschreiben! Liegt dieser Fall hier vor?

wenn es vorher geklappt hat mit
  Set odoc = oapp.ActiveDocument
  osource = odoc.FullFileName
  odest = Left(osource, Len(osource) - 4)

dann klappt es evtl. auch mit

Code:

---

Set odoc = oapp.ActiveDocument
osource = odoc.fullFilename
osource = Mid(osource, InStrRev(osource, "\") + 1) 'Pfad entfernen (alles einschl. dem letzten "\")
osource = Environ("userprofile") & "\Desktop\" & osource 'Desktop vorne anhängen
odest = Left(osource, Len(osource) - 4) 'Dateiendung entf.

---

------------------
Gruß KraBBy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Sub DATA_EXPORT_DXF_PDF()

Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
Dim osource As String
Dim odest As String
Dim ofolder As String
Dim ofileName As String
Dim Respone As String

If oapp.ActiveDocument Is Nothing Then
    Response = MsgBox("No drawing document open", vbYes, "Export")
    Exit Sub
End If

If oapp.ActiveDocumentType <> kDrawingDocumentObject Then
    Response = MsgBox("No drawing document open", vbYes, "Export")
    Exit Sub
End If

Set odoc = oapp.ActiveDocument
osource = odoc.FullFileName
ofolder = Left(osource, Len(osource) - Len(odoc.DisplayName))
ofileName = Left(odoc.DisplayName, Len(odoc.DisplayName) - 4)

Dim osheet As Inventor.Sheet
Dim counter As String

counter = 1

For Each osheet In odoc.Sheets
osheet.Activate
Call odoc.SaveAs(ofolder & ofileName & ".dxf", True)
Call odoc.SaveAs(ofolder & ofileName & ".pdf", True)

counter = counter + 1

Next

Response = MsgBox("dxf & pdf created", vbYes, "Export")

End Sub

Sub DATA_EXPORT_STEP()

Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.PartDocument
Dim osource As String
Dim odest As String
Dim ofolder As String
Dim ofileName As String

Dim Response As String

If oapp.ActiveDocument Is Nothing Then
    Response = MsgBox("No part document open", vbYes, "Export")
    Exit Sub
End If

If oapp.ActiveDocumentType <> kPartDocumentObject Then
    Response = MsgBox("No part document open", vbYes, "Export")
    Exit Sub
End If

Set odoc = oapp.ActiveDocument
osource = odoc.FullFileName
ofolder = Left(osource, Len(osource) - Len(odoc.DisplayName))
ofileName = Left(odoc.DisplayName, Len(odoc.DisplayName) - 4)
Call odoc.SaveAs(ofolder & ofileName & ".step", True)

Response = MsgBox("step created", vbYes, "Export")

End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Vielen Dank für das sehr gute Makro!

Wir haben es verbessert, dass die erzeugten PDFs und DXF Dateien im originalen Ordnerpfad landen.

Des Weiteren haben wir ein zweites Makro erstellt, welches auf dem 3D Körper eine .STEP Datei erzeugt.

Viel Spaß damit.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zitat:

---

Original erstellt von Hasentöter42:
[...]
Set odoc = oapp.ActiveDocument
osource = odoc.FullFileName
ofolder = Left(osource, Len(osource) - Len(odoc.DisplayName))
[...]

---

Mir fällt auf dass .FullFileName (dann osource) UND .DisplayName genutzt werden. Das funktioniert nur, wenn zweiter nicht überschrieben ist. Das muss nicht so sein (schrieb ich schon, mein Post oben).

Im Sinne von "passt für mehr Anwender", schlage ich die Verwendung folgender beiden Functions vor

Code:

---

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

---

Code:

---

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
'
'KraBBy 19.01.2021

    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

---

Der Aufruf könnte dann so aussehen

Code:

---

oFolder = GetFileName(odoc.FullFileName)
oFileName = getPathName(odoc.FullFileName)

---

Ansonsten natürlich herzlichen Dank fürs Bereitstellen des Codes!

------------------
Gruß KraBBy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP