Code:
Private Sub ExportBOMToCSV()If Not ThisApplication.ActiveDocument.DocumentType = kAssemblyDocumentObject Then
MsgBox "Funktion nur in Baugruppen möglich."
Exit Sub
End If
Dim sFileName As String
sFileName = "C:\Temp\Export.csv"
Dim oAssDoc As AssemblyDocument
Set oAssDoc = ThisApplication.ActiveDocument
Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM
Dim oBOMRow As BOMRow
Dim sParentDoc As String
Dim iCount As Integer
Dim sPartName As String
Dim oDoc As Document
Dim sLine As String
For Each oBOMRow In oBOM.BOMViews.Item("Strukturiert").BOMRows
Set oDoc = oBOMRow.ComponentDefinitions.Item(1).Document
iCount = oBOMRow.TotalQuantity
sPartName = oDoc.PropertySets.Item("Inventor User Defined Properties").Item("Bauteilnummer").Value
sParentDoc = oAssDoc.PropertySets.Item("Inventor User Defined Properties").Item("Bauteilnummer").Value
'Debug
'MsgBox iCount & " x " & sPartName & " in " & sParentDoc
sLine = iCount & ";" & sPartName & ";" & sParentDoc
TextFileAppendLine sFileName, sLine
If Not oBOMRow.ChildRows Is Nothing Then
Call processAllChildRows(oBOMRow, oDoc, sFileName)
End If
Next
Close #F
End Sub
Private Sub processAllChildRows(ByVal oBOMRow As BOMRow, ByVal oParentDoc As AssemblyDocument, ByRef sFileName As String)
Dim oChildBOMRow As BOMRow
Dim sLine As String
For Each oChildBOMRow In oBOMRow.ChildRows
Set oDoc = oChildBOMRow.ComponentDefinitions.Item(1).Document
iCount = oBOMRow.TotalQuantity
sPartName = oDoc.PropertySets.Item("Inventor User Defined Properties").Item("Bauteilnummer").Value
sParentDoc = oParentDoc.PropertySets.Item("Inventor User Defined Properties").Item("Bauteilnummer").Value
'Debug
'MsgBox iCount & " x " & sPartName & " in " & sParentDoc
sLine = iCount & ";" & sPartName & ";" & sParentDoc
TextFileAppendLine sFileName, sLine
If Not oChildBOMRow.ChildRows Is Nothing Then
Call processAllChildRows(oChildBOMRow, oDoc, sFileName)
End If
Next
End Sub
' Einzelne Zeile an eine Textdatei anhängen
' sFilename: vollständiger Name der Datei
' sLine : Inhalt, der gespeichert werden soll
' ===============================================
Public Sub TextFileAppendLine(ByVal sFileName As String, ByVal sLine As String)
Dim F As Integer
' Datei zum "Anhängen" von Daten öffnen
' und Textzeile ans Ende anfügen
F = FreeFile
Open sFileName For Append As #F
Print #F, sLine
Close #F
End Sub