how to export Bom with purchased, normal and inseparble to different Excel files by iLogic

[王承之pmhker]

hi ,guys.

The assembly includes normal parts purchasedparts and inseparble parts, etc. How to use ilogic to export the BOM of different structure types to different excel files

[Ralf_Krieg]

Hello

Afaik the export method in Inventor itself has no options for filter. But you can do it afterwards in Excel. The code is far away from perfect, but should show the way.

'Modify the strings to your language version
Private Const sBOMStructureType As String = "BOMstructuretype" ' Name of the column (column header) in BOM for structure type (Normal, Purchased, Inseparable)
Private Const sNormal As String = "Normal"
Private Const sPurchased As String = "Purchased"
Private Const sInseparable As String = "Inseparable"

Private Const sPath As String = "C:\Temp\" 'Path to save the exported BOM's to
Private Const sFilename As String = "PartsOnly_" 'static part of filename

Private Sub BOMExport()

'Makro assumes:
'- an assemblydocument is open
'- the part type column is NOT excluded in parts only view

Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oAssDoc As AssemblyDocument
Set oAssDoc = oApp.ActiveDocument

Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM

oBOM.PartsOnlyViewEnabled = True

Dim oBOMview As BOMView
For Each oBOMview In oBOM.BOMViews
    If oBOMview.ViewType = kPartsOnlyBOMViewType Then
        Exit For
    End If
Next

If oBOMview Is Nothing Then
    MsgBox ("Can't get Parts only BOM view")
    Exit Sub
End If

If Dir(sPath & sFilename & sNormal & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sPurchased & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sInseparable & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
End If

Call oBOMview.Export(sPath & sFilename & sNormal & ".xls", kMicrosoftExcelFormat, sNormal)
Call oBOMview.Export(sPath & sFilename & sPurchased & ".xls", kMicrosoftExcelFormat, sPurchased)
Call oBOMview.Export(sPath & sFilename & sInseparable & ".xls", kMicrosoftExcelFormat, sInseparable)


Dim oExcelApp As excel.Application
Set oExcelApp = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If


Dim oWB As Workbook
Set oWB = oExcelApp.Workbooks.Open(sPath & sFilename & sNormal & ".xls")
If Not oWB Is Nothing Then
    Set oWB = Filter(oExcelApp, oWB, sNormal)
    If Not oWB Is Nothing Then
        oWB.Save
    End If
End If

Dim oWB2 As Workbook
Set oWB2 = oExcelApp.Workbooks.Open(sPath & sFilename & sPurchased & ".xls")
If Not oWB2 Is Nothing Then
    Set oWB2 = Filter(oExcelApp, oWB2, sPurchased)
    If Not oWB2 Is Nothing Then
        oWB2.Save
    End If
End If

Dim oWB3 As Workbook
Set oWB3 = oExcelApp.Workbooks.Open(sPath & sFilename & sInseparable & ".xls")
If Not oWB3 Is Nothing Then
    Set oWB3 = Filter(oExcelApp, oWB3, sInseparable)
    If Not oWB3 Is Nothing Then
        oWB3.Save
    End If
End If

Dim Result As VbMsgBoxResult
Result = MsgBox("Export done. View files in Excel?", vbYesNo, "ExportBOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub


Private Function Filter(ByVal oExcelApp As excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook
    Dim lLastRow As Long
    Dim t As Long
    lLastRow = oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1).End(xlUp).Rows.Row
    
    Dim s As Long
    s = FindColumn(oExcelApp, oWB)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For t = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(t, s).Value = sName Then
            oWB.ActiveSheet.Rows(t).Delete Shift:=xlUp
        End If
    Next t
    
    Set Filter = oWB
End Function


Private Function FindColumn(ByVal oExcelApp As excel.Application, ByVal oWB As Workbook) As Long
    Dim lLastColumn As Long
    lLastColumn = oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count).End(xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As Range
    For s = lLastColumn To 1 Step -1
        Set rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sBOMStructureType Then
            FindColumn = s
            Exit For
        End If
    Next s
End Function

[王承之pmhker]

Thank you for your code, but i don't know how to run the code, it seems not an ilogic rule code. how can i do for it ?

Looking forward to your reply， thanks 

[王承之pmhker]

When i run it in VBA ， it print a compile error: User-defined type not defined on line (Private Function Filter(ByVal oExcelApp As excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook)

[Ralf_Krieg]

Hello

Yes, it's VBA Code. I think you have to add the a reference to Excel. In VBA Editor goto menu "Tools" --> "References". Search for the entry "Microsoft Excel xx.0 Object Library" amd activate it.

[Ralf_Krieg · Accepted solution]

... and a version that should work for iLogic

Option Explicit On
AddReference "microsoft.office.interop.excel.dll"
Imports XL = Microsoft.Office.Interop.Excel

Class BOMExport
'Modify the strings to your language version
Private Const sBOMStructureType As String = "BOMstructuretype" ' Name of the column (column header) in BOM for structure type (Normal, Purchased, Inseparable)
Private Const sNormal As String = "Normal"
Private Const sPurchased As String = "Purchased"
Private Const sInseparable As String = "Inseparable"

Private Const sPath As String = "C:\Temp\" 'Path to save the exported BOM's to
Private Const sFilename As String = "PartsOnly_" 'static part of filename

Private Sub Main()

'Makro assumes:
'- an assemblydocument is open
'- the part type column is NOT excluded in parts only view

Dim oApp As Inventor.Application = ThisApplication
Dim oAssdoc As AssemblyDocument = oApp.ActiveDocument
Dim oBOM As BOM = oAssdoc.ComponentDefinition.BOM
Dim oBOMview As BOMView
Dim oExcelApp As XL.Application = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If

oBOM.PartsOnlyViewEnabled = True

For Each oBOMview In oBOM.BOMViews
    If oBOMview.ViewType = kPartsOnlyBOMViewType Then
        Exit For
    End If
Next

If oBOMview Is Nothing Then
    MsgBox ("Can't get Parts only BOM view")
    Exit Sub
End If

If Dir(sPath & sFilename & sNormal & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
	oExcelApp.Quit
    Exit Sub
ElseIf Dir(sPath & sFilename & sPurchased & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
	oExcelApp.Quit
    Exit Sub
ElseIf Dir(sPath & sFilename & sInseparable & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
	oExcelApp.Quit
    Exit Sub
End If

Call oBOMview.Export(sPath & sFilename & sNormal & ".xls", kMicrosoftExcelFormat, sNormal)
Call oBOMview.Export(sPath & sFilename & sPurchased & ".xls", kMicrosoftExcelFormat, sPurchased)
Call oBOMview.Export(sPath & sFilename & sInseparable & ".xls", kMicrosoftExcelFormat, sInseparable)

Dim oWB As xl.Workbook  = oExcelApp.Workbooks.Open(sPath & sFilename & sNormal & ".xls")
If Not oWB Is Nothing Then
    oWB = Filter(oExcelApp, oWB, sNormal)
    If Not oWB Is Nothing Then
        oWB.Save
    End If
End If

Dim oWB2 As xl.Workbook = oExcelApp.Workbooks.Open(sPath & sFilename & sPurchased & ".xls")
If Not oWB2 Is Nothing Then
    oWB2 = Filter(oExcelApp, oWB2, sPurchased)
    If Not oWB2 Is Nothing Then
        oWB2.Save
    End If
End If

Dim oWB3 As xl.Workbook  = oExcelApp.Workbooks.Open(sPath & sFilename & sInseparable & ".xls")
If Not oWB3 Is Nothing Then
    oWB3 = Filter(oExcelApp, oWB3, sInseparable)
    If Not oWB3 Is Nothing Then
        oWB3.Save
    End If
End If

Dim Result As MsgBoxResult
Result = MsgBox("Export done. View files in Excel?", vbYesNo, "ExportBOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub


Private Function Filter(ByVal oExcelApp As xl.Application , ByVal oWB As xl.Workbook, ByVal sName As String) As xl.Workbook
    Dim oRange As xl.Range
	Dim lLastRow As Long
    Dim t As Long
	oRange=oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1)
    lLastRow = oRange.End(xl.XlDirection.xlUp ).Rows.Row
	
    Dim s As Long
    s = FindColumn(oExcelApp, oWB)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For t = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(t, s).Value = sName Then
            Call oWB.ActiveSheet.Rows(t).Delete( Shift:=xl.XlDirection.xlUp)
        End If
    Next t
    
    Return oWB
End Function


Private Function FindColumn(ByVal oExcelApp As xl.Application , ByVal oWB As xl.Workbook) As Long
    Dim oRange As xl.Range
	Dim lLastColumn As Long
	oRange=oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count)
    lLastColumn = oRange.End(xl.XlDirection.xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As xl.Range 
    For s = lLastColumn To 1 Step -1
        rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sBOMStructureType Then
            Return s
            Exit For
        End If
    Next s
End Function

End Class

[王承之pmhker]

The ilogic code is run successful in inventor 2022,  but failed in inventor 2018 by msg: Error on line 35: "kpartsonlybomviewtype" is undefine. It may not be accessible because of its level of protection.

[Ralf_Krieg · Accepted solution]

Hello

Can you try to change

    If oBOMview.ViewType = kPartsOnlyBOMViewType Then

to

    If oBOMview.ViewType = BOMViewTypeEnum.kPartsOnlyBOMViewType Then

[王承之pmhker]

Great，Thank you very much for your help

[checkcheck_master]

Hi Krieg,

How could it be otherwise you would almost think but I once again came across a nice piece of code from you that I would like to use.
Unfortunately I can't get it to work, neither in VBA nor in iLogic.
With both it gives problems when the xls files have to be opened from the code. When I open the files 'separately' I get the same message regarding security(VBA Run-time error '-2147021892 (80070bbc)). Also all images on the BOM, except for the last one, are compressed/out of proportion. I also have this behavior when I manually export a BOM to xls. When I choose xlsx I don't have that problem. Of course I have implemented this change in the code, the macro/rule runs without errors, only the filtering on the columns is not performed. I end up with three identical files. I 'see' the macro/rule opens the xlsx files invisible, and save them but without the desired result. What I said, I've tried to get it done in both VBA and iLogic. I'm running on IV2022 and use an NL-language Office/Excel. I tried to find the typical Excel commands in the code in the hope that the addition 'FormulaLocal' would offer some solace. Unfortunately, I couldn't only find a 'Delete' command where adding 'FormulaLocal' has no success. Also I've tried variant 'If oBOMview.ViewType = BOMViewTypeEnum.kPartsOnlyBOMViewType Then' it doesn't seem to be either. I'm sure the column header is correct as well as the terms 'Normal' and 'Purchased', 'Inseparable' did not appear in my test.
What I find remarkable is that variable 'LastRow' remains at 1 while the Excel document has 130 lines. Perhaps 'FormulaLocal' has something to add here?

The column 'Bom Structure' is normally found only then there is only 1 compare due to the lastrow value.

Perhaps this is the crux?

I'd love to hear about it.

[Ralf_Krieg]

Hello

The export creates Excel 97-2003 file type. Can you check in your office options if file block settings prevent opening this file type? Refer to this article how to check. I think your office blocks opening the files, so filtering is also not possible. That's why you get three identical files and opening after export fails.

The BOM structure types have localized names. The BOM structure types (see picture) need to be translated at the top of the script. Also the column header of the BOM structure type column in the Excel file needs to be translated at the top of the script. This is needed to find the right column to filter by BOM structure type.

I've added a little sub to scale thumbnails to original size and fit columnwidth and rowheight to thumbnail size.

Option Explicit

'Modify the strings to your language version
Private Const sBOMStructureType As String = "BOMstructuretype" ' Name of the column (column header) in exported BOM Excelfile (for structure type (Normal, Purchased, Inseparable)
Private Const sNormal As String = "Normal"
Private Const sPurchased As String = "Purchased"
Private Const sInseparable As String = "Inseparable"

'localized german names
'Private Const sBOMStructureType As String = "Stücklistenstruktur" ' Spaltenname in der exportierten Stückliste (Exceldatei) für die Stücklistenstruktur
'Private Const sNormal As String = "Normal"
'Private Const sPurchased As String = "Gekauft"
'Private Const sInseparable As String = "Unteilbar"

Private Const sPath As String = "C:\Temp\" 'Path to save the exported BOM's to
Private Const sFilename As String = "PartsOnly_" 'static part of filename

Private Sub BOMExport()

'Makro assumes:
'- an assemblydocument is open
'- the part type column is NOT excluded in parts only view

Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oAssDoc As AssemblyDocument
Set oAssDoc = oApp.ActiveDocument

Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM

oBOM.PartsOnlyViewEnabled = True

Dim oBOMview As BOMView
For Each oBOMview In oBOM.BOMViews
    If oBOMview.ViewType = kPartsOnlyBOMViewType Then
        Exit For
    End If
Next

If oBOMview Is Nothing Then
    MsgBox ("Can't get Parts only BOM view")
    Exit Sub
End If

If Dir(sPath & sFilename & sNormal & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sPurchased & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sInseparable & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
End If

Call oBOMview.Export(sPath & sFilename & sNormal & ".xls", kMicrosoftExcelFormat, sNormal)
Call oBOMview.Export(sPath & sFilename & sPurchased & ".xls", kMicrosoftExcelFormat, sPurchased)
Call oBOMview.Export(sPath & sFilename & sInseparable & ".xls", kMicrosoftExcelFormat, sInseparable)


Dim oExcelApp As Excel.Application
Set oExcelApp = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If


Dim oWB As Workbook
Set oWB = oExcelApp.Workbooks.Open(sPath & sFilename & sNormal & ".xls")
If Not oWB Is Nothing Then
    Set oWB = Filter(oExcelApp, oWB, sNormal)
    If Not oWB Is Nothing Then
        Call ResetPictureSize(oWB)
        oWB.Save
    End If
End If

Dim oWB2 As Workbook
Set oWB2 = oExcelApp.Workbooks.Open(sPath & sFilename & sPurchased & ".xls")
If Not oWB2 Is Nothing Then
    Set oWB2 = Filter(oExcelApp, oWB2, sPurchased)
    If Not oWB2 Is Nothing Then
        Call ResetPictureSize(oWB2)
        oWB2.Save
    End If
End If

Dim oWB3 As Workbook
Set oWB3 = oExcelApp.Workbooks.Open(sPath & sFilename & sInseparable & ".xls")
If Not oWB3 Is Nothing Then
    Set oWB3 = Filter(oExcelApp, oWB3, sInseparable)
    If Not oWB3 Is Nothing Then
        Call ResetPictureSize(oWB3)
        oWB3.Save
    End If
End If

Dim Result As VbMsgBoxResult
Result = MsgBox("Export done. View files in Excel?", vbYesNo, "ExportBOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub


Private Function Filter(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook
    Dim lLastRow As Long
    Dim t As Long
    lLastRow = oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1).End(xlUp).Rows.Row
    
    Dim s As Long
    s = FindColumn(oExcelApp, oWB)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For t = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(t, s).Value = sName Then
            oWB.ActiveSheet.Rows(t).Delete Shift:=xlUp
        End If
    Next t
    
    Set Filter = oWB
End Function


Private Function FindColumn(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook) As Long
    Dim lLastColumn As Long
    lLastColumn = oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count).End(xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As Range
    For s = lLastColumn To 1 Step -1
        Set rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sBOMStructureType Then
            FindColumn = s
            Exit For
        End If
    Next s
End Function

Private Sub ResetPictureSize(ByVal oWB As Workbook)
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet
    
    Dim oShape As Excel.Shape
    For Each oShape In oWS.Shapes
        With oShape
            If .Type = msoPicture Then
                .ScaleHeight 1, True, msoScaleFromTopLeft
                .ScaleWidth 1, True, msoScaleFromTopLeft
                .Placement = xlMove
                .TopLeftCell.ColumnWidth = .TopLeftCell.ColumnWidth / .TopLeftCell.Width * 90
                .TopLeftCell.RowHeight = 90
            End If
        End With
    Next
    
End Sub

[checkcheck_master]

Thank you Krieg for your message and assistance.

I tried to set Excel to open xls files normally. This turns out to be less simple than initially thought. I assumed it would be the rights I have on my office computer, but my home PC doesn't think it's such a good idea either. When I open the files through File Explorer, I also keep getting a message, but the files do open, from VBA I keep getting the RunTimeError. I also noticed that on both xls and xlsx the action on the images produces strange results. The pictures appear next to the column. As mentioned I had no problems with the images with xlsx.

I dug into lLastRow again and set that value to 150. The filtering just takes place neatly and delivers the files that are intended, as said before, the test files have 130 lines. Although I don't know how to solve it for now, that's where the problem is. I'm trying to find it on the internet but can't figure it out yet. I suggested earlier that it might have to do with the NL version Office, I try to look further and meanwhile hope that you might come up with a solution.

[checkcheck_master]

I had a lucky shot Krieg, see picture attached.
I don't have the knowledge to explain why this works.
Can you assess whether this can be a sufficiently robust solution?

[Ralf_Krieg]

Hello

I think your version is not less stable than mine. If this variant is working for you, use it. 😉

Is the export now working or fails it on opening? If you don't want to change file block settings, you can change the file extension in macro to xlsx. I could not see any difference in further using this file. Another possible way could bo to create an extra folder for the BOM export (e.g. C:\BOMExports) and add this folder in Trust center to Trusted locations. The file type should not matter this way.

I realized that when exporting thumbnails, they will not be deleted when rows are filtered. I've added some lines to do this.

Option Explicit

'Modify the strings to your language version
'Private Const sBOMStructureType As String = "BOMstructuretype" ' Name of the column (column header) in exported BOM Excelfile (for structure type (Normal, Purchased, Inseparable)
'Private Const sThumbnail As String = "Thumbnail"
'Private Const sNormal As String = "Normal"
'Private Const sPurchased As String = "Purchased"
'Private Const sInseparable As String = "Inseparable"

'localized german names
Private Const sBOMStructureType As String = "Stücklistenstruktur" ' Spaltenname in der exportierten Stückliste (Exceldatei) für die Stücklistenstruktur
Private Const sThumbnail As String = "Thumbnail"
Private Const sNormal As String = "Normal"
Private Const sPurchased As String = "Gekauft"
Private Const sInseparable As String = "Unteilbar"

Private Const sPath As String = "C:\BOMExports\" 'Path to save the exported BOM's to
Private Const sFilename As String = "PartsOnly_" 'static part of filename

Private Sub BOMExport()

'Makro assumes:
'- an assemblydocument is open
'- the part type column is NOT excluded in parts only view

Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oAssDoc As AssemblyDocument
Set oAssDoc = oApp.ActiveDocument

Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM

oBOM.PartsOnlyViewEnabled = True

Dim oBOMview As BOMView
For Each oBOMview In oBOM.BOMViews
    If oBOMview.ViewType = kPartsOnlyBOMViewType Then
        Exit For
    End If
Next

If oBOMview Is Nothing Then
    MsgBox ("Can't get Parts only BOM view")
    Exit Sub
End If

If Dir(sPath & sFilename & sNormal & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sPurchased & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
ElseIf Dir(sPath & sFilename & sInseparable & ".xls") <> "" Then
    Call MsgBox("File " & sPath & sFilename & sNormal & ".xls already exist.", vbCritical, "ExportBOM")
    Exit Sub
End If

Call oBOMview.Export(sPath & sFilename & sNormal & ".xls", kMicrosoftExcelFormat, sNormal)
Call oBOMview.Export(sPath & sFilename & sPurchased & ".xls", kMicrosoftExcelFormat, sPurchased)
Call oBOMview.Export(sPath & sFilename & sInseparable & ".xls", kMicrosoftExcelFormat, sInseparable)


Dim oExcelApp As Excel.Application
Set oExcelApp = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If


Dim oWB As Workbook
On Error Resume Next
Set oWB = oExcelApp.Workbooks.Open(sPath & sFilename & sNormal & ".xls")
If Not oWB Is Nothing Then
    Set oWB = Filter(oExcelApp, oWB, sNormal)
    If Not oWB Is Nothing Then
        Call ResetPictureSize(oWB)
        oWB.Save
    End If
End If

Dim oWB2 As Workbook
Set oWB2 = oExcelApp.Workbooks.Open(sPath & sFilename & sPurchased & ".xls")
If Not oWB2 Is Nothing Then
    Set oWB2 = Filter(oExcelApp, oWB2, sPurchased)
    If Not oWB2 Is Nothing Then
        Call ResetPictureSize(oWB2)
        oWB2.Save
    End If
End If

Dim oWB3 As Workbook
Set oWB3 = oExcelApp.Workbooks.Open(sPath & sFilename & sInseparable & ".xls")
If Not oWB3 Is Nothing Then
    Set oWB3 = Filter(oExcelApp, oWB3, sInseparable)
    If Not oWB3 Is Nothing Then
        Call ResetPictureSize(oWB3)
        oWB3.Save
    End If
End If
On Error GoTo 0

Dim Result As VbMsgBoxResult
Result = MsgBox("Export done. View files in Excel?", vbYesNo, "ExportBOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub


Private Function Filter(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook
    
    Dim lLastRow As Long
    lLastRow = oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1).End(xlUp).Rows.Row
    ' alternativ way to find last row
    'lLastRow = oWB.ActiveSheet.UsedRange.Rows.Count
    
    Dim s As Long
    Dim t As Long
    Dim u As Long
    s = FindColumn(oExcelApp, oWB, sBOMStructureType)
    t = FindColumn(oExcelApp, oWB, sThumbnail)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For u = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(u, s).Value = sName Then
            Dim oShape As Excel.Shape
            For Each oShape In oWB.ActiveSheet.Shapes
                With oShape
                    If .Type = msoPicture Then
                        If .TopLeftCell.Row = u Then
                            oShape.Delete
                        End If
                    End If
                End With
            Next
            oWB.ActiveSheet.Rows(u).Delete Shift:=xlUp
        End If
    Next u
    
    Set Filter = oWB
End Function


Private Function FindColumn(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal sColumnName As String) As Long
    Dim lLastColumn As Long
    lLastColumn = oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count).End(xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As Range
    For s = lLastColumn To 1 Step -1
        Set rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sColumnName Then
            FindColumn = s
            Exit For
        End If
    Next s
End Function

Private Sub ResetPictureSize(ByVal oWB As Workbook)
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet
    
    oWS.Cells.EntireColumn.AutoFit
    
    Dim oShape As Excel.Shape
    For Each oShape In oWS.Shapes
        With oShape
            If .Type = msoPicture Then
                .ScaleHeight 1, True, msoScaleFromTopLeft
                .ScaleWidth 1, True, msoScaleFromTopLeft
                .Placement = xlMove
                .TopLeftCell.ColumnWidth = .TopLeftCell.ColumnWidth / .TopLeftCell.Width * 90
                .TopLeftCell.RowHeight = 90
            End If
        End With
    Next
    
End Sub

[checkcheck_master]

Great Krieg, thank you again!
Everything seems to work as intended, indeed based on xlsx. On my office computer I have indeed tried to designate the temp folder as a trusted location, I think from VBA I still got the error message. Anyway, xlsx works fine for us, especially when we can leave such settings on default.
I am indeed planning a different folder location, I'll figure that out.

I would like to have all the columns/cells in a table so that the user can filter easily? Can you help me with that?

[Ralf_Krieg]

Hello

What means "all the columns/cells in a table"? One Excelfile with 3 worksheets (Normal, Inseparable, Purchased)? Can you explain a bit more in detail?

[checkcheck_master]

Hello Krieg,
I mean select all cells and put them in a table, see image and my (3) code try outs.
I've heard the bell ringing but I don't know where the clapper hangs let's say.

Private Sub List_Objects(ByVal oWB As Workbook) ' Create Table
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet

    ' AutoFit Columns
    oWS.Cells.EntireColumn.AutoFit

'    ' Create Table
'    Dim LR As Long
'    Dim LC As Long
'
'    LR = oWS.Cells(Rows.Count, 1).End(xlUp).Row
'    LC = oWS.Cells(1, Columns.Count).End(xlToLeft).Column
'
'    Dim Rng As Range
'    Set Rng = oWS.Cells(1, 1).Resize(LR, LC)
'
'    'Dim Ws As WorkSheet
'    'Set Ws = oWB.ActiveSheet
'
'    oWS.ListObjects.Add xlSrcRange, xllistobjecthasheaders:=xlYes, Destination:=Rng
'    'oWS.ListObjects(1).Name = "Table"
'    'WS.ListObjects(2).TableStyle = "TableStyleMedium2"

End Sub

'Sub List_Objects(ByVal oWB As Workbook)
'
'    Dim MyTable As ListObject
'    Set MyTable = oWB.ActiveSheet.ListObjects("Table")
'
'    'MyTable.DataBodyRange.Select
'    'To Select data range without headers
'
'    MyTable.Range.Select
'    'To Select data range with headers
'
'    'MyTable.HeaderRowRange.Select
'    'To Select table header rows
'
'    'MyTable.ListColumns(2).Range.Select
'    'To select column 2 including header
'
'    'MyTable.ListColumns(2).DataBodyRange.Select
'    'To select column 2 without header
'
'End Sub

'Sub List_Objects(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook)
'
'    Dim LR As Long
'    Dim LC As Long
'
'    LR = oExcelApp.Cells(Rows.Count, 1).End(xlUp).Row
'    LC = oExcelApp.Cells(1, Columns.Count).End(xlToLeft).Column
'
'    Dim Rng As Range
'    Set Rng = oExcelApp.Cells(1, 1).Resize(LR, LC)
'
'    Dim Ws As WorkSheet
'    Set Ws = oWB.ActiveSheet
'
'    Ws.ListObjects.Add xlSrcRange, xllistobjecthasheaders:=xlYes, Destination:=Rng
'    Ws.ListObjects(1).Name = "EmpTable"
'
'End Sub

[checkcheck_master]

I managed to solve it Krieg, I was referring to oWB when it should be oWB2.

See code.

May I ask you to take a look at this post:

https://forums.autodesk.com/t5/inventor-customization/select-features-and-perform-right-mouse-button...

I would love to know a solution to my second question and I suspect you are seeing through that.

A little explanation:
When you are in a part mode you can choose 'Expand browser' to expand certain nodes and show the sketches and their dimensions which in turn can be changed. With Laurent's solution also the feature dimensions became visible like bends, flanges, radi etc. and can be changed as desired. I would like to have that also available when in edit mode while in an assembly. Do you know how I can get hold of those browser nodes in edit mode and make the dimensions visible in the same way?

' Export_BOM
' Yes, it's VBA Code.
' I think you have to add the a reference to Excel.
' In VBA Editor goto menu "Tools" --> "References".
' Search for the entry "Microsoft Excel xx.0 Object Library" and activate it.

'Modify the strings to your language version
Private Const sBOMStructureType As String = "BOM Structure" ' Name of the column (column header) in BOM for structure type (Normal, Purchased, Inseparable)
Private Const sNormal As String = "Normal"
Private Const sPurchased As String = "Purchased"
Private Const sInseparable As String = "Inseparable"

Private Const sPath As String = "C:\Temp\" 'Path to save the exported BOM's to
Private Const sFilename As String = "PartsOnly_" 'Static part of filename
'End Private Const (This text is only to show the underscore after 'PartsOnly'

Private Sub BOMExport()

'Makro assumes:
'- An assemblydocument is open
'- The part type column is NOT excluded in parts only view

'--------------------------------------------------------------------------------------------------
' Set timer
Dim Start As Double
Start = Timer

Dim TimeDateStamp As String
TimeDateStamp = Format(Date, "yyyy-mm-dd") & "_" & Format(Time, "hh:mm:ss")
TimeDateStamp = Replace(TimeDateStamp, ":", "")
'--------------------------------------------------------------------------------------------------

'GoTo Skip

Dim oApp As Inventor.Application
Set oApp = ThisApplication

Dim oAssDoc As AssemblyDocument
Set oAssDoc = oApp.ActiveDocument

Dim oBOM As BOM
Set oBOM = oAssDoc.ComponentDefinition.BOM

oBOM.PartsOnlyViewEnabled = True

Dim oBOMview As BOMView
For Each oBOMview In oBOM.BOMViews
    'If oBOMview.ViewType = BOMViewTypeEnum.kPartsOnlyBOMViewType Then
    If oBOMview.ViewType = kPartsOnlyBOMViewType Then
    'If oBOMview.ViewType = kStructuredBOMViewType Then
        Exit For
    End If
Next

If oBOMview Is Nothing Then
    MsgBox ("Can't get Parts only BOM view")
    Exit Sub
End If

'' Check if file exist
'If Dir(sPath & sFilename & sNormal & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'ElseIf Dir(sPath & sFilename & sPurchased & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'ElseIf Dir(sPath & sFilename & sInseparable & ".xlsx") <> "" Then
'    Call MsgBox("File " & sPath & sFilename & sNormal & ".xlsx already exist.", vbCritical, "ExportBOM")
'    Exit Sub
'End If

Dim strBOM1 As String
strBOM1 = sPath & sFilename & sNormal & " - " & TimeDateStamp & ".xlsx"
Dim strBOM2 As String
strBOM2 = sPath & sFilename & sPurchased & " - " & TimeDateStamp & ".xlsx"

Call oBOMview.Export(strBOM1, kMicrosoftExcelFormat, sNormal)
Call oBOMview.Export(strBOM2, kMicrosoftExcelFormat, sPurchased)
'Call oBOMview.Export(sPath & sFilename & sInseparable & ".xlsx", kMicrosoftExcelFormat, sInseparable)

Skip:

Dim oExcelApp As Excel.Application
Set oExcelApp = GetObject("", "Excel.Application")

If oExcelApp Is Nothing Then
    MsgBox ("Can't get Excel")
    Exit Sub
End If


Dim oWB As Workbook
Set oWB = oExcelApp.Workbooks.Open(strBOM1)
If Not oWB Is Nothing Then
    Set oWB = Filter(oExcelApp, oWB, sNormal)
    If Not oWB Is Nothing Then
        Call List_Objects(oExcelApp, oWB)
        oWB.Save
    End If
End If

Dim oWB2 As Workbook
Set oWB2 = oExcelApp.Workbooks.Open(strBOM2)
If Not oWB2 Is Nothing Then
    Set oWB2 = Filter(oExcelApp, oWB2, sPurchased)
    If Not oWB2 Is Nothing Then
        Call List_Objects(oExcelApp, oWB2)
        oWB2.Save
    End If
End If

'Dim oWB3 As Workbook
'Set oWB3 = oExcelApp.Workbooks.Open(sPath & sFilename & sInseparable & ".xlsx")
'If Not oWB3 Is Nothing Then
'    Set oWB3 = Filter(oExcelApp, oWB3, sInseparable)
'    If Not oWB3 Is Nothing Then
'        oWB3.Save
'    End If
'End If

Dim Result As VbMsgBoxResult
Result = MsgBox("Export done. & vbnewline & Elapsed time: " & Timer - Start & " Seconds" & vbNewLine & "View files in Excel?", vbYesNo, "ExportBOM")

If Result = vbYes Then
    oExcelApp.Visible = True
Else
    For Each oWB In oExcelApp.Workbooks
        oWB.Close (False)
    Next
    oExcelApp.Quit
End If

End Sub

Private Function Filter(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook, ByVal sName As String) As Workbook
    Dim lLastRow As Long
    Dim t As Long
    'lLastRow = oExcelApp.Cells(oWB.ActiveSheet.Rows.Count, 1).End(xlUp).Rows.Row
    ' Alternativ way to find last row
    lLastRow = oWB.ActiveSheet.UsedRange.Rows.Count
            
    'Debug.Print "lLastRow: " & lLastRow
    
    Dim s As Long
    s = FindColumn(oExcelApp, oWB)
    If s = 0 Then
        Call MsgBox("Column BOM Structure Type missing.", vbCritical, "ExportBOM")
        Filter = Nothing
        Exit Function
    End If
    
    For t = lLastRow To 2 Step -1
        If Not oExcelApp.Cells(t, s).Value = sName Then
            oWB.ActiveSheet.Rows(t).Delete Shift:=xlUp
        End If
    Next t
    
    Set Filter = oWB
End Function

Private Function FindColumn(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook) As Long
    Dim lLastColumn As Long
    lLastColumn = oExcelApp.Cells(1, oWB.ActiveSheet.Columns.Count).End(xlToLeft).Columns.Column
     
    Dim s As Long
    Dim rCells As Range
    For s = lLastColumn To 1 Step -1
        Set rCells = oExcelApp.Cells(1, s)
        If rCells.Value = sBOMStructureType Then
            FindColumn = s
            Exit For
        End If
    Next s
End Function

Private Sub List_Objects(ByVal oExcelApp As Excel.Application, ByVal oWB As Workbook) ' Create Table
    Dim oWS As WorkSheet
    Set oWS = oWB.ActiveSheet

    ' AutoFit Columns
    oWS.Cells.EntireColumn.AutoFit

    ' Create Table
    Dim LR As Long
    Dim LC As Long

    LR = oWS.Cells(Rows.Count, 1).End(xlUp).Row
    LC = oWS.Cells(1, Columns.Count).End(xlToLeft).Column

    Dim Rng As Range
    Set Rng = oWS.Cells(1, 1).Resize(LR, LC)

    oWS.ListObjects.Add xlSrcRange, xllistobjecthasheaders:=xlYes, Destination:=Rng
    oWS.ListObjects(1).Name = "Table"
    oWS.ListObjects(1).TableStyle = "TableStyleLight21"

    ' Freeze 1st row
    oExcelApp.Application.ScreenUpdating = True
    oWS.Cells(2, 1).Select
    oExcelApp.ActiveWindow.FreezePanes = True

End Sub

[checkcheck_master]

Hello Krieg,

Please find picture attached regarding Run Time Error 1004.

Any idea what could go wrong?

It happens occasionally, but I don't know what the cause is, I can't get it triggered, it seems like an Excel thing but...

[Ralf_Krieg]

Hello

I think Visual Basic simply don't knows from where to take the Rows propertie. Can you try to change this line and the following to

LR = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
LC = oWS.Cells(1, oWS.Columns.Count).End(xlToLeft).Column