Sub Stückliste()
Dim oapp As Inventor.Application
Set oapp = ThisApplication
Dim odoc As Inventor.DrawingDocument
If oapp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Set odoc = oapp.ActiveDocument
Dim oOptions As NameValueMap
Dim oName, oStart, oTemplate, oFullFileName, oFileName, oXLSFileName As String
Dim oLength As String
Dim oFit As Boolean
Dim oProp As PropertySet
Dim oProp2 As PropertySet
Dim i As Property
Dim e As Property
Dim oDescription As String
Dim oTitle As String
Dim oPartNumber As String
Dim oRevision As String
Dim oCreationDate As String
Dim strFile As String

strFile = ThisApplication.ActiveDocument.FullDocumentName

'MsgBox strFile

Länge_strFile = Len(strFile)
                        Dim endung As Integer
                        'endung = 0 'mit .ipt usw.
                        endung = 4 ' ohne .ipt usw
                        Name_Pfad = Mid(strFile, 1, Länge_strFile - 4)
                        Länge_String = Len(Name_Pfad)
                        
                        Dim q As Integer
                        q = 1
                        Do Until Mid(Name_Pfad, Länge_String - q, 1) = "\"
                          q = q + 1
                        Loop
                        'MsgBox i 'Anzahl der Buchstaben vom Dateinamen
                        Dateiname = Right(Name_Pfad, q)
                        Name_Pfad = Mid(strFile, 1, Länge_strFile - q - endung)




Set oProp = odoc.PropertySets.Item("Design Tracking Properties")
Set oProp2 = odoc.PropertySets.Item("Inventor Summary Information")
For Each i In oProp
If i.DisplayName = "Bauteilnummer" Then
oPartNumber = i.Expression
ElseIf i.DisplayName = "Erstellungsdatum" Then
oCreationDate = i.Expression
End If
Next
For Each e In oProp2
If e.DisplayName = "Titel" Then
oTitle = e.Expression
End If
Next
oFileName = oPartNumber & "." & oTitle & ".xls"
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oXLSFileName = Name_Pfad
Dim oPropRev As PropertySet
Dim iRev As Property
Set oPropRev = odoc.PropertySets.Item("Inventor Summary Information")
For Each iRev In oPropRev
If iRev.DisplayName = "Revisionsnummer" Then
If iRev.Expression = "" Then
oName = "0"
Else
oName = iRev.Expression
End If
End If
Next
'oStart = Start- Zelle
oStart = "A5"
'oTemplate = Pfad zum xls- Template
oTemplate = "C:\Users\cahlers\Desktop\Programmiertest\Stücklistenvorlage.xls"
'oFit bewirkt, dass die Zellen eingepasst werden
'true - Zellen werden angepasst
'false - Zellen werden nicht angepasst
oFit = True
Call oOptions.Add("TableName", oName)
Call oOptions.Add("StartingCell", oStart)
Call oOptions.Add("Template", oTemplate)
Call oOptions.Add("AutoFitColumnWidth", oFit)
If odoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf odoc.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


'Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)


'************************* Ab hier der EXCEL- PART ****************
'Im Inventor VBA- Projekt auf Extras - Verweise und
'die Microsoft Excel Library hinzufügen
'******************************************************************
Dim oExl As New Excel.Application
On Error Resume Next
Set oExl = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
On Error Resume Next
Set oExl = CreateObject("Excel.Application")
If Err.Number Then
Err.Clear
MsgBox "Kann Excel nicht öffnen."
Exit Sub
End If
End If

'On Error Resume Next
oExl.Workbooks.Open (oXLSFileName)
If Err.Number Then
    Err.Clear
    Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
    oExl.Workbooks.Open (oXLSFileName)
Else
    Dim oExlSheet As Excel.WorkSheet
    For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
        If oExlSheet.Name = oName Then
            If oExl.ActiveWorkbook.Worksheets.Count = 1 Then
                oExl.ActiveWorkbook.Worksheets.Add
            End If
            oExl.DisplayAlerts = False
            oExlSheet.Delete
            oExl.DisplayAlerts = True
        End If
    Next
oExl.ActiveWorkbook.Close (True)
Call odoc.ActiveSheet.PartsLists.Item(1).Export(oXLSFileName, kMicrosoftExcel, oOptions)
oExl.Workbooks.Open (oXLSFileName)
End If

'Löscht alle Tabellenblätter, die mit "Tabelle" beginnen
For Each oExlSheet In oExl.ActiveWorkbook.Worksheets
    If Left(oExlSheet.Name, 7) = "Tabelle" Then
        oExlSheet.Delete
    End If
Next


With oExl.ActiveWorkbook
.Sheets(oName).Cells(2, 1) = oPartNumber
.Sheets(oName).Cells(2, 5) = oTitle
.Sheets(oName).Cells(2, 4) = oRevision
.Sheets(oName).Cells(4, 1) = oCreationDate
.Close 1
End With
End Sub