Message 1 of 5
Not applicable
02-12-2019
05:21 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello,
I have found an makro and edited it so far. But now I need to save all levels of structured BOM into an excel sheet.
But the makro won't work with "all levels".
Can someone tell me why? And maybe have a solution?
Public Sub BOM_Export()
'generate bom test
'set variables
Dim oTemplate As String: oTemplate = "c:\BOM-Template.xlsx"
Dim oStartRow As Integer: oStartRow = 3
' set last column for array, array starts at 0 so its -1 quantity comes straight out of bom so we dont need to store it
Dim lastCol As Integer: lastCol = 9
'set individual columns for excel, use a number no letter
Dim nrCol As Long: nrCol = 1
Dim categoryCol As Long: categoryCol = 2
Dim stocknoCol As Long: stocknoCol = 3
Dim titleCol As Long: titleCol = 4
Dim partnoCol As Long: partnoCol = 5
Dim widthCol As Long: widthCol = 6
Dim lengthCol As Long: lengthCol = 7
Dim massCol As Long: massCol = 8
Dim quantityCol As Long: quantityCol = 10
'set assembly
Dim asm As AssemblyDocument
Set asm = ThisApplication.ActiveDocument
' set reference to referenced documents
Dim rds As DocumentsEnumerator
Set rds = asm.AllReferencedDocuments
' define bom
Dim oBOM As BOM
Set oBOM = asm.ComponentDefinition.BOM
' Make sure that the structured view is enabled.
oBOM.StructuredViewEnabled = True
' set the parts only view
Dim oBOMView As BOMView
Set oBOMView = oBOM.BOMViews("Structured")
' Set the structured view to 'all levels'
oBOM.StructuredViewFirstLevelOnly = False
'set the properties we want to print
Dim oDescripProperty As Property
Dim oTitleProperty As Property
Dim oStockNoProperty As Property
Dim oCommentsProperty As Property
' store the columns in an array for easier printing
Dim oArray() As String
ReDim oArray(oBOMView.BOMRows.Count - 1, lastCol) As String
Dim a As Double: a = 0
' iterate trough bom rows
Dim oBOMrow As BOMRow
For Each oBOMrow In oBOMView.BOMRows
' setthe component definition
Dim oCompDef As ComponentDefinition
Set oCompDef = oBOMrow.ComponentDefinitions.Item(1)
'Get the file property that contains the "Description"
Set oDescripProperty = oCompDef.Document.PropertySets _
.Item("Design Tracking Properties").Item("Description")
' set the title property
Set oTitleProperty = oCompDef.Document.PropertySets _
.Item("Inventor Summary Information").Item("Title")
' set the category property
Set oCategoryProperty = oCompDef.Document.PropertySets _
.Item("Inventor Document Summary Information").Item("Category")
' set the stock number property
Set oStockNoProperty = oCompDef.Document.PropertySets _
.Item("Design Tracking Properties").Item("Stock Number")
' set the part number property
Set oPartNoProperty = oCompDef.Document.PropertySets _
.Item("Design Tracking Properties").Item("Part Number")
' set the width property
Set oPartNoProperty = oCompDef.Document.PropertySets _
.Item("Design Tracking Properties").Item("Part Number")
' fill array
oArray(a, 0) = (a + 1)
oArray(a, 1) = oCategoryProperty.Value
oArray(a, 2) = oStockNoProperty.Value
oArray(a, 3) = oTitleProperty.Value
oArray(a, 4) = oPartNoProperty.Value
oArray(a, 9) = oBOMrow.ItemQuantity
a = a + 1
Next
' set excel app and add worksheet
Dim xlApp As Object
Dim xlwb As Object
Dim xlws As Object
Set xlApp = CreateObject("Excel.Application")
Set xlwb = xlApp.workbooks.Open(oTemplate)
'Set xlwb = xlApp.workbooks.Add
Set xlws = xlwb.Worksheets(1)
xlApp.Visible = True
' write more stuff
xlws.cells(1, 2) = asm.DisplayName
xlws.cells(1, 4) = "Nr: " & asm.PropertySets.Item(3).Item(2).Value
xlws.name = asm.PropertySets.Item(3).Item(2).Value
' print the array
Dim b As Double: b = 0
For b = 1 To oBOMView.BOMRows.Count
' print array
xlws.cells(oStartRow + b, nrCol) = oArray(b - 1, 0)
xlws.cells(oStartRow + b, categoryCol) = oArray(b - 1, 1)
xlws.cells(oStartRow + b, stocknoCol) = oArray(b - 1, 2)
xlws.cells(oStartRow + b, titleCol) = oArray(b - 1, 3)
xlws.cells(oStartRow + b, partnoCol) = oArray(b - 1, 4)
xlws.cells(oStartRow + b, quantityCol) = oArray(b - 1, 9)
Next
' save and close the document
xlwb.SaveAs ("full string + doc name.xlsx")
' close the document
Call xlwb.Close
End Sub
This is my edit so far. Some cols missing at the moment. But think first of all the all levels export shoudl work.
Solved! Go to Solution.
