Export Bill Of Materials to Excel with thumbnails

This macro exports Bill of Materials to Excel with thumbnails. You definitely need this one if you are on SOLIDWORKS 2018 or older. When you run the macro, a new session is Excel is opened, the BOM is copied there and a thumbnail preview is created for each of the visible components. You must have Microsoft Office Excel installed to able to use this macro. Be aware that it only works on parts-only BOMs.

To use this macro:

• Open SOLIDWORKS and load a drawing that contains a drawing with a Bill of Materials. Make sure it’s the active document.
• Go To Tools > Macro > New …
• Save this macro to a place of your choice.
• In the VBE, clear up the text area and copy paste the code below.
• In SOLIDWORKS, make sure the Bill of Materials feature is selected and nothing else.
• Click on the green play button to start.
• If a dialog pops up asking you to choose which subroutine to run, select main
• Click on Run.
• The macro will get the bill of Materials and copy it to Excel with thumbnails.

'All rights reserved  - amen@bluebyte.biz
'Blue Byte Systems, Inc does not provide any warranties for macros.
'SOLIDWORKS Export bill of materials to Excel
'Pre-conditions: BOM pre-selected.
'Results: BOM created in Excel with thumbnail preview
'define the width and height of the thumbnail
Dim Width As Long 'in pixels
Dim Height As Long 'in pixels
Dim swApp As Object
Dim swModel As Object
Dim swTableAnnotation As Object
Dim exApp As Object
Dim exWorkbook As Object
Dim exWorkSheet As Object
Dim swSelectionManager As Object
Public Enum swDocumentTypes_e
swDocDRAWING = 3
End Enum
Public Enum xlTextAlignment
xlCenter = -4108
End Enum
Public Enum swTableHeaderPosition_e
swTableHeader_Top = 1
swTableHeader_Bottom = 2
swTableHeader_None = 0
End Enum
Public Enum swSelectType_e
swSelBOMS = 97
End Enum
Sub Main()
Width = 21
Height = 60
'get pointer to the solidworks application
Set swApp = Application.SldWorks
'get active document
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
swApp.SendMsgToUser "There is no active document"
End
End If
Set swSelectionManager = swModel.SelectionManager
'get the count of selected objects
Dim Count As Long
Count = swSelectionManager.GetSelectedObjectCount2(-1)
'if the user has made no selection then exit
If Count = 0 Then
swApp.SendMsgToUser "You have not selected any bill of materials!"
Exit Sub
End If
'traverse the selection and process all selected bill of materials
For i = 1 To Count
If swSelectionManager.GetSelectedObjectType3(i, -1) = SwConst.swSelectType_e.swSelANNOTATIONTABLES Then
Set swTableAnnotation = swSelectionManager.GetSelectedObject6(i, -1)
Dim Ret As String
Ret = SaveBOMInExcelWithThumbNail(swTableAnnotation)
If Ret = "" Then
Debug.Print "Success: " & swTableAnnotation.GetAnnotation.GetName
swApp.SendMsgToUser "The selected BOM has been exported with thumbnail preview to Excel."
Else
swApp.SendMsgToUser "Macro failed to export!"
End If
End If
Next i
End Sub
Public Function SaveBOMInExcelWithThumbNail(ByRef swTableAnnotation As Object) As String
Set exApp = CreateObject("Excel.Application")
If exApp Is Nothing Then
SaveBOMInExcelWithThumbNail = "Unable to initialize the Excel application"
Exit Function
End If
exApp.Visible = True
Set exWorkbook = exApp.Workbooks.Add
Set exWorkSheet = exWorkbook.ActiveSheet
If exWorkSheet Is Nothing Then
SaveBOMInExcelWithThumbNail = "Unable to get the active sheet"
Exit Function
End If
If swTableAnnotation.RowCount = 0 Then
SaveBOMInExcelWithThumbNail = "BOM has no rows!"
End If
Dim swBOMTableAnnotation As BomTableAnnotation
Set swBOMTableAnnotation = swTableAnnotation
'set column width
exWorkSheet.Columns(1).ColumnWidth = Width
Dim HeaderRowIndex As Long
Dim swHeaderIndex As Integer
swHeaderTable = swTableAnnotation.GetHeaderStyle
If swHeaderTable = swTableHeaderPosition_e.swTableHeader_Bottom Then
swHeaderIndex = swTableAnnotation.RowCount
Else
swHeaderIndex = 1
End If
Skipper:
For i = 0 To swTableAnnotation.RowCount - 1
If swTableAnnotation.RowHidden(i) Then
GoTo Skipper
End If
'add preview image
Dim swComponents As Variant
swComponents = swBOMTableAnnotation.GetComponents(i)
If Not IsEmpty(swComponents) Then
Dim swComponent As Object
Set swComponent2 = swComponents(0)
Dim swComponentModel As Object
Set swComponentModel = swComponent2.GetModelDoc2
If Not swComponentModel Is Nothing Then
swComponentModel.Visible = True
Dim imagePath As String
imagePath = Environ("TEMP") + "tempBitmap.jpg"
swComponentModel.ViewZoomtofit2
Dim saveRet As Boolean
Dim er As Long
Dim wr As Long
saveRet = swComponentModel.Extension.SaveAs(imagePath, 0, 0, Nothing, er, wr)
If er + wr <> 0 Then
SaveBOMInExcelWithThumbNail = "An error has occured while trying to save the thumbnail of " & swModel.GetTitle & " to the local temp folder. The macro will exit now."
End If
swComponentModel.Visible = False
exWorkSheet.Rows(i + 1).RowHeight = Height
InsertPictureInRange exWorkSheet, imagePath, exWorkSheet.Range("A" & i + 1 & ":A" & i + 1)
End If
End If
For j = 0 To swTableAnnotation.ColumnCount - 1
If swTableAnnotation.ColumnHidden(j) Then
GoTo Skipper
End If
exWorkSheet.Cells(i + 1, j + 2).Value = swTableAnnotation.DisplayedText(i, j)
Next j
Next i
'add header row to bold
For j = 2 To swTableAnnotation.ColumnCount + 1
exWorkSheet.Cells(swHeaderIndex, j).Font.Bold = True
Next j
Dim r As Object
Set r = exWorkSheet.Range(exWorkSheet.Cells(1, 2), exWorkSheet.Cells(swTableAnnotation.RowCount + 1, swTableAnnotation.ColumnCount + 1))
r.Columns.AutoFit
r.HorizontalAlignment = xlTextAlignment.xlCenter
r.VerticalAlignment = xlTextAlignment.xlCenter
End Function
Sub InsertPictureInRange(ActiveSheet As Object, PictureFileName As String, TargetCells As Object)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

Problems running the macro? Report a bug here

This macro has limitations. It cannot process large assemblies. xlBOM with thumbnails has to the ability to process large assemblies and more.