Code:
Sub Stücklisten_Export_LN()
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 IfDim 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 = "u:\XXX\XXX\"
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)
If Err.Number = 0 Then
MsgBox "Die Exportdatei der Stückliste wurde im Verzeichnis U:\XXX\XXX\ gespeichert"
Else
MsgBox "Fehler: " & Err.Description
End If
End Sub