---

Hallo zusammen,
mal wieder eine Frage wie man eine Stückliste aus einer Zeichnung mittels VBA exportieren kann. Ich habe schon sämtliche Codes hier aus dem Forum kopiert und angepasst... liegt wahrscheinlich am Benutzer...

Mir würde es reichen wenn die Stückliste in ein bestimmtes Verzeichnis "W:\000000_Transfer\CAD-Miclas X" exportiert wird. Diese soll nicht sortiert oder formatiert werden.

Verwendet wir Inventor 2024

Bei Fragen stehe ich euch gerne zur Verfügung.

Schönen Gruß aus dem Westerwald
Sergej

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

---

Hi,

PartsList.Export Method
das tut nicht?

Zugriff über ActiveDocument.ActiveSheet.PartsLists.item(1)

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

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

---

Leider kann ich kein VBA programmieren. Ich kann mir mal mit anderen Codes behelfen indem ich hin und her kopiere bis es geht.

Wie könnte der Code aussehen?

Vielen Dank

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

---

Ich habe ein Code gefunden der fast genau das macht was ich haben möchte.

Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If

Dim oDrawDoc As Inventor.DrawingDocument
Set oDrawDoc = oapp.ActiveDocument

Dim sAuthor, sPath, sFileName, sTXTFileName As String
Dim oPropSet As PropertySet
Dim iProp As Property

'Pfad anpassen
sPath = "C:\Temp\"

If oDrawDoc.ActiveSheet.PartsLists.Count = 0 Then
    MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
    Exit Sub
ElseIf oDrawDoc.ActiveSheet.PartsLists.Count > 1 Then
    MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If

Dim oPartslist As PartsList
Set oPartslist = oDrawDoc.ActiveSheet.PartsLists.Item(1)

Dim oRefedDoc As Document
Set oRefedDoc = oPartslist.ReferencedDocumentDescriptor.ReferencedDocument

sAuthor = oRefedDoc.PropertySets(1)("Author").Value

If sAuthor = "" Then
    MsgBox "iProp Author in Datei " & vbclf & oRefedDoc.FullDocumentName & vbCrLf & " ist leer. Abbruch", vbCritical, "leeres iProp"
    Exit Sub
End If

sFileName = sAuthor & ".txt"
sTXTFileName = sPath & sFileName

Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sPath) Then MkDir sPath

Call oDrawDoc.ActiveSheet.PartsLists.Item(1).Export(sTXTFileName, kTextFileTabDelimited)

End Sub

Die Stückliste müsste jetzt nur noch in Excel gespeichert werden und der Dateiname sollte aus den Benutzerdefinierten Felder kommen.

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

---

etwas angepasst:

Code:

---

Option Explicit
Sub Stückliste()
   
    Dim oapp As Inventor.Application
    Set oapp = ThisApplication
    If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
        MsgBox "Funktion ist nur in Zeichnungen zulässig"
        Exit Sub
    End If
   
    Dim oDrawDoc As Inventor.DrawingDocument
    Set oDrawDoc = oapp.ActiveDocument
   
    Dim sAuthor, sPath, sFileName, sTXTFileName As String
    Dim oPropSet As PropertySet
    Dim iProp As Property
   
    'Pfad anpassen
    sPath = "C:\Temp\"
'    sPath = "W:\000000_Transfer\CAD-Miclas X\"    'wenn diese Zeile nicht mehr auskommentiert ist, sollte es passen!
   
    If oDrawDoc.ActiveSheet.PartsLists.Count = 0 Then
        MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
        Exit Sub
    ElseIf oDrawDoc.ActiveSheet.PartsLists.Count > 1 Then
        MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
    End If
   
    Dim oPartslist As PartsList
    Set oPartslist = oDrawDoc.ActiveSheet.PartsLists.Item(1)
   
    Dim oRefedDoc As Document
    Set oRefedDoc = oPartslist.ReferencedDocumentDescriptor.ReferencedDocument
   
    sAuthor = oRefedDoc.PropertySets(1)("Author").Value
   
    If sAuthor = "" Then
        MsgBox "iProp Author in Datei " & vbCrLf & oRefedDoc.FullDocumentName & vbCrLf & " ist leer. Abbruch", vbCritical, "leeres iProp"
        Exit Sub
    End If
   
    sFileName = sAuthor & ".txt"
    sFileName = sAuthor & ".xlsx"  'Dateiendung angepasst
    sTXTFileName = sPath & sFileName
   
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not fs.FolderExists(sPath) Then MkDir sPath
   
   
    Call oPartslist.Export(sTXTFileName, kMicrosoftExcel)  'geändert auf Excel (und Variable oPartslist benutzt)

End Sub

---

Das hat bei mir (in 1 Testlauf) geklappt.

Der Dateiname ist aus dem iProperty "Author". Was wäre Dein Wunsch? bzw. welche benutzerdefinierten Felder meinst Du?

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

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

---

Guten Morgen,

bei mir werden die msgboxen angemeckert.
Fehler beim Kompelieren: Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer Eigenschaft.

Wenn ich die auskommentiere, läuft das Makro durch.

Dateiname: Wenn ich mir schon was wünschen darf ;-) , der Dateiname soll sich aus der Z_Artikel Nr. und der Z_Bezeichnung1 zusammensetzen.

Beim PDF Export habe ich das hinbekommen jedoch funktionieren diese Zeilen nicht in diesem Code.

Vielen Dank und einen schönen Start in den Dienstag.

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

---

Deinen Fehler bei den Messageboxen konnte ich nicht nachvollziehen. Ich habe die entsprechenden Zeilen im Sub test_MsgBoxen zusammenkopiert. Das lief ... 

Der Dateiname wird nun aus den beiden Benutzer-iProp. zusammengesetzt. Bitte bei den Namen nochmal genau hinschauen, ob die passen!

Ich habe noch eine Function clear_DatName ergänzt. Die habe ich schon so im Einsatz. Sie soll verhindern, dass verbotene Zeichen im Dateinamen landen (wie \ oder : ). Auch Leerzeichen u.a. nehme ich raus. Kann gut sein, dass Dir das zu weit geht. Ggf. einfach die entsprechende Zeile auskommentieren!

Code:

---

Option Explicit

Sub Stückliste()
 
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
    If oApp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
        MsgBox "Funktion ist nur in Zeichnungen zulässig"
        Exit Sub
    End If
 
    Dim oDrawDoc As Inventor.DrawingDocument
    Set oDrawDoc = oApp.ActiveDocument
 
    Dim sPath As String, sFileName As String, sTXTFileName As String
 
    'Pfad anpassen
    sPath = "C:\Temp\"
'    sPath = "W:\000000_Transfer\CAD-Miclas X\"    'wenn diese Zeile nicht mehr auskommentiert ist, sollte es passen!
 
    If oDrawDoc.ActiveSheet.PartsLists.Count = 0 Then
        MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
        Exit Sub
    ElseIf oDrawDoc.ActiveSheet.PartsLists.Count > 1 Then
        MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
    End If
 
    Dim oPartslist As PartsList
    Set oPartslist = oDrawDoc.ActiveSheet.PartsLists.Item(1)
 
    Dim oRefedDoc As Document
    Set oRefedDoc = oPartslist.ReferencedDocumentDescriptor.ReferencedDocument
 
 
  Dim vArtikel As Variant, vBezeichnung As Variant
  vArtikel = ReadCustomiProperty(oRefedDoc, "Z_Artikel Nr.")      ' ### ggf. Name anpassen!
  vBezeichnung = ReadCustomiProperty(oRefedDoc, "Z_Bezeichnung1")
    If IsNull(vArtikel) Or IsNull(vBezeichnung) Then
        MsgBox "iProp 'Z_Artikel Nr.' und/oder 'Z_Bezeichnung1' existiert nicht!", vbInformation + vbOKOnly, "leeres iProp - Abbruch"
        Exit Sub
    End If
 
    sFileName = vArtikel & "_" & vBezeichnung & ".xlsx"  'Trennzeichen ggf. anpassen
    sFileName = clear_DatName(sFileName)    'Function unten, Konformität f. Dateiname herstellen
    sTXTFileName = sPath & sFileName
 
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not fs.FolderExists(sPath) Then MkDir sPath
 
 
    Call oPartslist.Export(sTXTFileName, kMicrosoftExcel)  'geändert auf Excel (und Variable oPartslist benutzt)

End Sub

Private Sub test_MsgBoxen()

    MsgBox "Funktion ist nur in Zeichnungen zulässig"
    MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
    MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
    MsgBox "iProp Author in Datei " & vbCrLf & "oRefedDoc.FullDocumentName" & vbCrLf & " ist leer. Abbruch", vbCritical, "leeres iProp"
End Sub

Public Function ReadCustomiProperty(ByRef doc As Document, _
ByRef PropertyName As String, _
Optional forceStringReturn As Boolean = False) As Variant
'Wert aus iProp lesen
' forceStringReturn: gibt "" zurück, (statt Null) auch wenn Prop. nicht existiert
   
    'Default-Rückgabewert (wenn Prop nicht existiert)
    If forceStringReturn Then ReadCustomiProperty = "" Else ReadCustomiProperty = Null
   
    'raus, wenn doc nicht gesetzt ist
    If doc Is Nothing Then Exit Function
        'Rueckgabe mit Defaultwert
   
    ' Get the custom property set.
    Dim customPropSet As PropertySet
'    Set customPropSet = doc.PropertySets.Item("Inventor User Defined Properties")
    Set customPropSet = doc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'internalName

    ' Get the existing property, if it exists.
    Dim prop As Property
    On Error Resume Next
    Set prop = customPropSet.Item(PropertyName)

    ' Check to see if the above call failed.  If it failed
    ' then the property doesn't exist.
    If Err.Number <> 0 Then
    ' Failed to get the existing property
        If False = forceStringReturn Then ' keine Meldung bei forceStringReturn
'            MsgBox "iProperty existiert nicht!" & vbCrLf _
'                & PropertyName, vbCritical, "Fkt. ReadCustomiProperty"
        End If
    Else
        'Prop existiert, Wert lesen
        ReadCustomiProperty = prop.Value
    End If
   
    On Error GoTo 0
End Function

Function clear_DatName(str As String) As String
    ' wandelt einen gegebenen Text in einen "konformen Text"
    ' dieser neue Wert wird zurückgegeben
   
    ' ### nach Wunsch anpassen
    '      Zeilen auskommentieren, wenn ein Zeichen nicht ersetzt werden soll
   
    Dim name_alt As String
    Dim name_neu As String
   
    name_alt = str
    name_neu = str
   
    name_neu = Replace(name_neu, " ", "_")      'alle Leerz. ersetzen
    'name_neu = Replace(name_neu, "-", "_")      'Bindestriche ersetzen
   
    name_neu = Replace(name_neu, ",", "_")
    name_neu = Replace(name_neu, "ä", "ae")    'Umlaute...
    name_neu = Replace(name_neu, "Ä", "Ae")
    name_neu = Replace(name_neu, "ö", "oe")
    name_neu = Replace(name_neu, "Ö", "Oe")
    name_neu = Replace(name_neu, "ü", "ue")
    name_neu = Replace(name_neu, "Ü", "Ue")
    name_neu = Replace(name_neu, "ß", "ss")
   
    name_neu = Replace(name_neu, "^", "_")
    name_neu = Replace(name_neu, "°", "_")
    name_neu = Replace(name_neu, """", "_")    'Anführungszeichen (")
    'name_neu = Replace(name_neu, "§", "_")
    'name_neu = Replace(name_neu, "$", "_")
    'name_neu = Replace(name_neu, "%", "_")
    'name_neu = Replace(name_neu, "&", "_")
    name_neu = Replace(name_neu, "/", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, "\", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, "=", "_")
    name_neu = Replace(name_neu, "?", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, "*", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, "~", "_")
    name_neu = Replace(name_neu, "<", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, ">", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, "|", "_")  ' nicht für Dateinamen zugelassen
    name_neu = Replace(name_neu, ":", "_")  ' nicht für Dateinamen zugelassen
   
    'name_neu = Replace(name_neu, "[", "(")
    'name_neu = Replace(name_neu, "]", ")")
   

    dErsetzen name_neu 'Sub, doppelte __ ersetzen, rekursiv
   
    'Rückgabewert
    clear_DatName = name_neu
   
End Function

Private Sub dErsetzen(ByRef txt)
' doppelte Unterstriche "__" werden durch einfache "_" ersetzt
' rekursiv
    If Not (0 = InStr(txt, "__")) Then
        txt = Replace(txt, "__", "_")  'doppelte __ ersetzen
    End If
    If Not (0 = InStr(txt, "__")) Then dErsetzen txt 'Rekursion
End Sub

---

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

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

---

Puh das ist auf jeden Fall mehr als ich haben wollte 

Vielen Dank

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