Attribute VB_Name = "AP2XLS"
' Return the path of the input filename.
Public Function FilePath(ByVal fullFilename As String) As String
    ' Extract the path by getting everything up to and
    ' including the last backslash "\".
    FilePath = Left$(fullFilename, InStrRev(fullFilename, "\") - 1)
End Function


' Return the name of the file, without the path.
Public Function Filename(ByVal fullFilename As String) As String
    ' Extract the filename by getting everything to
    ' the right of the last backslash.
    Filename = Right$(fullFilename, Len(fullFilename), InStrRev(fullFilename, "\"))
End Function


' Return the base name of the input filename, without
' the path or the extension.
Public Function BaseFilename(ByVal fullFilename As String) As String
    ' Extract the filename by getting everttgubg to
    ' the right of the last backslash.
    Dim temp As String
    
    temp = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))

    ' Get the base filename by getting everything to
    ' the left of the last period ".".
    BaseFilename = Left$(temp, InStrRev(temp, ".") - 1)
End Function


' Return the extension of the input filename.
Public Function FileExtension(ByVal fullFilename As String) As String
    ' Extract the filename by getting everthing to
    ' the right of the last backslash.
    Dim temp As String
    temp = Right$(fullFilename, Len(fullFilename), InStrRev(fullFilename, "\"))

    ' Get the base filename by getting everything to
    ' the right of the last period ".".
    FileExtension = Right$(temp, Len(temp) - InStrRev(temp, ".") + 1)
End Function

Option Explicit
Public Sub AP_to_excel()

 If ThisApplication.Documents.Count = 0 Then
        MsgBox "Keine Dokumente geöffnet. Es muss ein Bauteil geöffnet sein."
        Exit Sub
    End If
    
    If ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
        MsgBox "Das geöffnete Dokument ist kein Bauteil. Es muss ein Bauteil geöffnet sein."
        Exit Sub
    End If
    
    Dim oPoint As Point
    Dim oWP As WorkPoint
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication
    Dim od As PartDocument
    Set od = ThisApplication.ActiveDocument
    Dim oCompDef As PartComponentDefinition
    Set oCompDef = od.ComponentDefinition
    Dim FName As String
    FName = BaseFilename(od.fullFilename)
    FPath = FilePath(od.fullFilename)
    
    FTemplate = FilePath(oApp.VBAProjects.Item(1).VBProject.Filename) ' Setzt voraus das 1. VBAProjekt das Anwendungsprojekt ist.
    
    
    Dim iRow As Long
    Dim i As Long
    Dim j As Long
    
    Dim OrX As Double
    Dim Ory As Double
    Dim OrZ As Double
    
    Dim XL As Object
    Dim xlWB As Object
    Dim xlWS As Object
    
    ' XLS-Datei öffen (temporär)
    Set XL = CreateObject("Excel.Application")
    Set xlWB = XL.Workbooks.Open(FTemplate + "\AP2XLS.XLSX")
    Set xlWS = xlWB.Worksheets(1)
   
    XL.Application.Visible = True
    iRow = 1
    xlWS.Cells(iRow, 1).Value = "NAME"
    xlWS.Cells(iRow, 2).Value = "X"
    xlWS.Cells(iRow, 3).Value = "Y"
    xlWS.Cells(iRow, 4).Value = "Z"
   
   j = 0
    For i = 1 To od.ComponentDefinition.WorkPoints.Count
    Set oWP = od.ComponentDefinition.WorkPoints.Item(i)
    Debug.Print oCompDef.WorkPoints.Item(i).Name
    Debug.Print oCompDef.WorkPoints.Item(i).Point.X
    Debug.Print oCompDef.WorkPoints.Item(i).Point.Y
    Debug.Print oCompDef.WorkPoints.Item(i).Point.Z

        'Filtern: NAme des AP beginnt mit "P"
        If (Left(oCompDef.WorkPoints.Item(i).Name, 1) = "P") Then
            j = j + 1
        
            ' 1. gültiger AP bestimmt Ursprung
            If (j = 1) Then
                OrX = oCompDef.WorkPoints.Item(i).Point.X * 10
                Ory = oCompDef.WorkPoints.Item(i).Point.Y * 10
                OrZ = oCompDef.WorkPoints.Item(i).Point.Z * 10
            End If
        
        
            'Zellinhalte nach XLS schreiben
            xlWS.Cells((j + 1), 1).Value = oCompDef.WorkPoints.Item(i).Name
            xlWS.Cells((j + 1), 2).Value = Round(oCompDef.WorkPoints.Item(i).Point.X * 10 - OrX, 2)
            xlWS.Cells((j + 1), 3).Value = Round(oCompDef.WorkPoints.Item(i).Point.Y * 10 - Ory, 2)
            xlWS.Cells((j + 1), 4).Value = Round(oCompDef.WorkPoints.Item(i).Point.Z * 10 - OrZ, 2)
        End If
     Next
     ' Passt Größe der Zeilen und Spalten an die Werte an
        xlWS.Cells(3, 6).Value = ""
        xlWS.Cells(4, 6).Value = ""
        xlWS.Cells(5, 6).Value = ""
        xlWS.Cells(6, 6).Value = ""
        xlWS.Cells(7, 6).Value = ""
        xlWS.Cells(8, 6).Value = ""
        xlWS.Cells(9, 6).Value = ""
        xlWS.Cells(10, 6).Value = ""
        xlWS.Cells(11, 6).Value = ""

        
        
        
        XL.Cells.Select
        XL.Cells.EntireColumn.AutoFit
        
        
        xlWS.Range("A1").Select
        
        'XLS-DAtei unter Namen der IV-Datei speichern
        xlWB.SaveAs FPath + "\" + FName + ".xlsx"
    
End Sub