Eng-Tips is the largest engineering community on the Internet

Intelligent Work Forums for Engineering Professionals

  • Congratulations waross on being selected by the Eng-Tips community for having the most helpful posts in the forums last week. Way to Go!

Modified Catia BOM macro

Status
Not open for further replies.

vijayjaipal

Mechanical
Jun 22, 2022
1
SE
Hello,

I downloaded a catia BOM macro and attempted to modify to our needs- unfortunately I am stuck on one final thing...
From the Single product assembly, am able to extract all the parts in the BOM .
When i have multiple products assembly and parts selected inside assembly doesn't appear in the BOM
Could you anyone help me on this

I really am a novice when it comes to coding, so any advise you can provide would be extremely helpful.

below is the code am using


Sub CATMain()
' ******************************* test if product is open *****************************
If CATIA.Documents.Count = 0 Then
MsgBox "There is no CATIA Documents open. Open a Product file and run this script again.", , msgboxtext
Exit Sub
End If
If InStr(CATIA.ActiveDocument.Name, ".CATProduct") < 1 Then
MsgBox "Active CATIA Document is not a Product. Open a Product file and run this script again.", , msgboxtext
Exit Sub
End If
' ******************************* variables *******************************************
Set cad = CATIA.ActiveDocument
Set sel = cad.Selection
Set prod = cad.Product.Products



'Dim tab(4,9000)
Dim tab2(4, 9000)
k = 0
' ******************************* test if some parts is selected **********************
If sel.Count = 0 Then
MsgBox "Select parts from tree.", , msgboxtext
Exit Sub
End If
If sel.Count >= 9000 Then
MsgBox "Number of selected parts for BOM exceeds 9000. Program error.", , msgboxtext
Exit Sub
End If
' ******************************* load ************************************************
For i = 1 To prod.Count
For j = 1 To sel.Count
If prod.Item(i).Name = sel.Item(j).Reference.Name Then
k = k + 1
tab2(1, k) = prod.Item(i).PartNumber
'tab(2,k)=sel.item(j).reference.name
'tab(3,k)=prod.item(i).DescriptionRef
tab2(4, k) = 1
End If
Next
Next
' ******************************* sort ************************************************
If k > 1 Then
For i = 1 To k - 1
For j = i + 1 To k
If tab2(1, i) > tab2(1, j) Then
tab2(1, 9000) = tab2(1, j)
'tab(2,9000)=tab(2,j)
tab2(3, 9000) = tab2(3, j)
tab2(4, 9000) = tab2(4, j)
tab2(1, j) = tab2(1, i)
'tab(2,j)=tab(2,i)
tab2(3, j) = tab2(3, i)
tab2(4, j) = tab2(4, i)
tab2(1, i) = tab2(1, 9000)
'tab(2,i)=tab(2,9000)
tab2(3, i) = tab2(3, 9000)
tab2(4, i) = tab2(4, 9000)
End If
Next
Next
' ******************************* count ***********************************************
Dim total, linecount, totalcount
total = 1
linecount = 1
totalcount = 1



For i = 1 To k
If tab2(1, i) = tab2(1, i + 1) Then
linecount = linecount + 1
End If
If tab2(1, i) <> tab2(1, i + 1) Then
tab2(1, totalcount) = tab2(1, i)
tab2(4, totalcount) = linecount
totalcount = totalcount + 1
linecount = 1
End If
tab2(4, totalcount) = linecount
Next

End If

k = totalcount - 1

' ******************************* output to excel *************************************
'for i=1 to k
'msgbox i & " " & tab(1,i) & " " & tab(2,i) & " " & tab(3,i) & " " & tab(4,i)
'next
Dim xlApp
Err.Clear
On Error Resume Next
' set xlApp = GetObject(,"Excel")
Set xlApp = GetObject(, "EXCEL.Application")
If Err.Number <> 0 Then
Err.Clear
' Set xlApp = CreateObject("Excel")
Set xlApp = CreateObject("EXCEL.Application")
End If
xlApp.Visible = True
xlApp.Workbooks.Add
If Err.Number <> 0 Then
MsgBox "Can't open excel.", , msgboxtext
workbook.Close
xlApp.Quit
End If
row = 1
col = 1
xlApp.Cells(row, col + 1).Value = "CATProduct:"
xlApp.Cells(row, col + 1).Font.Bold = True
xlApp.Cells(row + 1, col + 1).Value = cad.Name
row = 4
xlApp.Cells(row, col + 1).Value = "Part Number"
xlApp.Cells(row, col + 2).Value = " "
xlApp.Cells(row, col + 3).Value = "Description"
xlApp.Cells(row, col + 4).Value = "QNT."
xlApp.Columns.Columns(2).Columnwidth = 30
xlApp.Columns.Columns(3).Columnwidth = 30
xlApp.Columns.Columns(4).Columnwidth = 50
For i = 1 To 4
xlApp.Cells(row, col + i).Interior.ColorIndex = 40
xlApp.Cells(row, col + i).Font.Bold = True
xlApp.Cells(row, col + i).HorizontalAlignment = 3
xlApp.Cells(row, col + i).borders.LineStyle = 1
xlApp.Cells(row, col + i).borders.Weight = -4138
Next
' row=row+1
For i = 1 To k
xlApp.Cells(row + i, col + 1).Value = tab2(1, i)
'xlApp.Cells(row+i,col+2).Value = tab(2,i)
'xlApp.Cells(row+i,col+3).Value = trim(tab(3,i))
xlApp.Cells(row + i, col + 4).Value = tab2(4, i)
For j = 1 To 4
xlApp.Cells(row + i, col + j).Interior.ColorIndex = 19
xlApp.Cells(row + i, col + j).Font.Bold = False
xlApp.Cells(row + i, col + j).borders.LineStyle = 1
Next
Next
xlApp.Cells(row + i, col).Select
' xlApp.Cells(1, 1).HorizontalAlignment = 2
End Sub
 
 https://files.engineering.com/getfile.aspx?folder=f6420e5e-f4ae-4965-8f20-ef2cb26c8b9d&file=Thread-3.JPG
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top