Public Sub CSV_erstellen()
Call Properties_hinzufügen(thisapplication.ActiveDocument.ComponentDefinition.Occurrences)
Call CSV_Struktur(thisapplication.ActiveDocument.ComponentDefinition.Occurrences)
End Sub

Private Function Properties_hinzufügen(Elemente As ComponentOccurrences)
  
    Dim oOcc As ComponentOccurrence
    Dim oPart As Document
    Dim iamnr, iptnr, unDefPart, Zähler As Integer
    iamnr = 1
    iptnr = 0
    unDefPart = 2
    Dim invCustomPropertyset As PropertySet
    Dim invPropertyBauteile, invPropertyVerknüpfung As Property
    Dim FileName As String
    Dim invDoc As Document
    Set invDoc = thisapplication.ActiveDocument
    FileName = invDoc.DisplayName
  
  For Each oOcc In Elemente
    'Wenn Ausgewähltes Element eine Baugruppe ist
    If oOcc.DefinitionDocumentType = kAssemblyDocumentObject Then
        Set oPart = oOcc.Definition.Document
        Set invCustomPropertyset = oPart.PropertySets.Item("Inventor User Defined Properties")
        'wenn Stücklistenstruktur = Normal
        If oOcc.BOMStructure = kNormalBOMStructure Then
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(iamnr, "iam_ipt Zahl")
        'wenn Stücklistenstruktur = Gekauft
        ElseIf oOcc.BOMStructure = kPurchasedBOMStructure Then
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(iptnr, "iam_ipt Zahl")
        'wenn Stücklistenstruktur = Unteilbar
        ElseIf oOcc.BOMStructure = kInseparableBOMStructure Then
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(iamnr, "iam_ipt Zahl")
        'wenn Stücklistenstruktur = alle anderen Definitionen
        Else
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(unDefPart, "iam_ipt Zahl")
        End If
    End If
           
    'Wenn ausgewähltes Element ein Bauteil ist
    If oOcc.DefinitionDocumentType = kPartDocumentObject Then
        Set oPart = oOcc.Definition.Document
        Set invCustomPropertyset = oPart.PropertySets.Item("Inventor User Defined Properties")
        'wenn Stücklistenstruktur = Normal
        If oOcc.BOMStructure = kNormalBOMStructure Or oOcc.BOMStructure = kPurchasedBOMStructure Or oOcc.BOMStructure = kInseparableBOMStructure Then
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(iptnr, "iam_ipt Zahl")
        'wenn Stücklistenstruktur = alle anderen Definitionen
        Else
            On Error Resume Next
            Set invPropertyBauteile = invCustomPropertyset.Add(unDefPart, "iam_ipt Zahl")
        End If
    End If
    Set invPropertyVerknüpfung = invCustomPropertyset.Add(FileName, "Verknüpfungsname")
Next
End Function

Public Function CSV_Struktur(Elemente As ComponentOccurrences)

    Dim invDoc As Document
    Set invDoc = thisapplication.ActiveDocument
    
    Dim oOcc As ComponentOccurrence
    Dim oPart As Document
    Dim f, i, x, y, z, p, ipt_ipt_Zahl As Integer
    Dim Arr1(), Arr2(), Arr3(), str1, str2, str3, str4, str5, str6, str7, str8, str9, str10, str11, sr11, strname1, strname2, überschrift, datensatz, sFileName As String
    Dim invDesignInfo, invCustomProperty As PropertySet
    Dim invTitleProperty, invPartNumberProperty, invPropertyLieferant, invPropertyMat, inviam_ipt_ZahlProperty, invPropertyVerknüpfung As Property
    
    i = 0
    'Zählen der Bauteilanzahl in der Baugruppe
    For Each oOcc In Elemente
        i = i + 1
    Next
       
    '1.Array mit der Länge der Bauteilanzahl(i) erstellen
    ReDim Arr1(i, 5)
    
    j = 0
    'Daten der Bauteile auslesen und in das 1.Array schreiben
    For Each oOcc In Elemente
        Set oPart = oOcc.Definition.Document
        Set invDesignInfo = oPart.PropertySets.Item("Inventor Summary Information")
        Set invTitleProperty = invDesignInfo.Item("Title")
        Arr1(j, 0) = invTitleProperty.Value
        Set invDesignInfo = oPart.PropertySets.Item("Design Tracking Properties")
        Set invPartNumberProperty = invDesignInfo.Item("Part Number")
        Arr1(j, 1) = invPartNumberProperty.Value
        Set invCustomProperty = oPart.PropertySets.Item("Inventor User Defined Properties")
        Set inviam_ipt_ZahlProperty = invCustomProperty.Item("iam_ipt Zahl")
        Arr1(j, 2) = inviam_ipt_ZahlProperty.Value
        Set invPropertyVerknüpfung = invCustomProperty.Item("Verknüpfungsname")
        Arr1(j, 3) = invPropertyVerknüpfung.Value
        Set invPropertyLieferant = invDesignInfo.Item("Vendor")
        Arr1(j, 4) = invPropertyLieferant.Value
        Set invPropertyMat = invDesignInfo.Item("Material")
        'wenn kein Material eingetragen dann wird - eingetragen
        If invPropertyMat.Value = "" Then
            Arr1(j, 5) = "-"
        Else
           Arr1(j, 5) = invPropertyMat.Value
        End If
        j = j + 1
    Next
    
    'CSV Strukturdaten erstellen
    überschrift = "Pos" & ";" & "Anzahl" & ";" & "Bezeichnung" & ";" & "Norm/Teilenummer" & ";" & "Lieferant" & ";" & "Material" & ";" & "iam_ipt Zahl" & ";" & "Verknüpfungsname"
        
    '2.Array mit der Länge der Bauteilanzahl(i) erstellen
    'hier werden alle Bauteile die ungleich dem 1.Datensatz des 1.Arrays sind hineingeschrieben
    ReDim Arr2(i, 5)
    
    p = 0
    x = 0
    z = 0
    
        
    For x = 0 To i - 1
        str1 = Arr1(x, 0) 'Titel
        str2 = Arr1(x, 1) 'Bauteilnummer
        str3 = Arr1(x, 2) 'iam_ipt Zahl
        str4 = Arr1(x, 3) 'Verknüpfungsname
        str5 = Arr1(x, 4) 'Lieferant
        str6 = Arr1(x, 5) 'Material
        strname1 = str1 & "; " & str2
        z2 = 0
        
        'Länge des 1.Arrays ermitteln
        For z2 = 0 To i - 1
            If Arr1(z2, 0) <> "" Then
                z2 = z2 + 1
            End If
        Next
        
        'Zweiten Datensatz des 1.Arrays ermitteln und in str schreiben
        y = x + 1
        For y = y To i
        str7 = Arr1(y, 0)
        str8 = Arr1(y, 1)
        str9 = Arr1(y, 2)
        str10 = Arr1(y, 3)
        str11 = Arr1(y, 4)
        str12 = Arr1(y, 5)
        strname2 = str7 & "; " & str8
            'Ersten Datensatz mit zweiten Datensatz vergleichen
            'wenn unterschiedlich, dann wird das zweite Array mit den Werten des ersten Arrays gefüllt
            If strname1 <> strname2 Then
                Arr2(z, 0) = str7
                Arr2(z, 1) = str8
                Arr2(z, 2) = str9
                Arr2(z, 3) = str10
                Arr2(z, 4) = str11
                Arr2(z, 5) = str12
                z = z + 1
            End If
        Next
        
        'Arr3 = Datensatzarray
        'Daten die Arr3 enthalten sollte:
        'Pos, Anzahl, Titel, Bauteilnummer, Lieferant, Material, iam_ipt Zahl, Verknüpfung
        '=================================================================================
        ReDim Arr3(x, 7)
        Arr3(x, 0) = x + 1 'Fortlaufende Nummer
        Arr3(x, 1) = (z2 - 1) - (z - 1) 'z - 1 'Anzahl
        Arr3(x, 2) = Arr1(x, 0) 'Titel
        Arr3(x, 3) = Arr1(x, 1) 'Bauteilnummer
        Arr3(x, 4) = Arr1(x, 4) 'Lieferant
        Arr3(x, 5) = Arr1(x, 5) 'Material
        Arr3(x, 6) = Arr1(x, 2) 'iam_ipt Zahl
        Arr3(x, 7) = Arr1(x, 3) 'Verknüpfung
        
        'Datensatz erstellen
        f = 0
        datensatz = ""
        
        For f = 0 To 7
            datensatz = datensatz & Arr3(x, f) & ";"
        Next
        
        sFileName = "G:\Inventor\Zukaufteile\MTP Förderbänder\12-1291 iCopy MTP Förderband APF60\test csv\testcsv.txt"
            
        ' Einzelne Zeile an eine Textdatei anhängen
        ' sFilename:  vollständiger Name der Datei
        ' datensatz:  Inhalt, der gespeichert werden soll
        ' ===============================================
        
        Dim C As Long
        C = FreeFile
        Open sFileName For Append As #C
            
        If p = 0 Then
            Print #C, überschrift
            p = 1
        End If
            
        If Len(datensatz) > 15 Then
            Print #C, datensatz
            Close #C
        Else
            Close #C
        End If

        'Array1 Datensätze löschen mit redim
        ReDim Arr1(i, 5)
        
        'Array2 in Array1 kopieren
        For k = 0 To z - 1
            Arr1(k + 1, 0) = Arr2(k, 0)
            Arr1(k + 1, 1) = Arr2(k, 1)
            Arr1(k + 1, 2) = Arr2(k, 2)
            Arr1(k + 1, 3) = Arr2(k, 3)
            Arr1(k + 1, 4) = Arr2(k, 4)
            Arr1(k + 1, 5) = Arr2(k, 5)
        Next
        
        'Array2 Datensätze löschen
        ReDim Arr2(i - 1, 5)
        z = 0
    Next
End Function