Continue to Site

Welcome to 3DCADForums

Join our CAD community forums where over 25,000 users interact to solve day to day problems and share ideas. We encourage you to visit, invite you to participate and look forward to your input and opinions. Acrobat 3D, AutoCAD, Catia, Inventor, IronCAD, Creo, Pro/ENGINEER, Solid Edge, SolidWorks, and others.

BOM export macro

Striple

New member
Hello all!

A friend made me a macro to export a BOM from a drawing in Excel (CSV format). My problem: I need that macro can add a new table for each execution. I can't find how I can do that. For exemple: My drawing have a 3 line BOM. I run the macro once, it works properly.
But I need a new table (same) at the end of the previous if I run again the macro. How can I modify this code????
This is ma actual code:


Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2

Sub main()

Dim swFeat As SldWorks.Feature
Dim swBomFeat As SldWorks.BomFeature

'Application SW
Set swApp = Application.SldWorks

'Document actif
Set swModel = swApp.ActiveDoc
Debug.Print "Document : " & swModel.GetTitle



'Récupération de la première fonction
Set swFeat = swModel.FirstFeature


'Parcours des autres fonctions
Do While Not swFeat Is Nothing



'Récupération des fonction de type Nomenclature (BOM)
If "BomFeat" = swFeat.GetTypeName Then

Debug.Print "Fonction : " & swFeat.Name

Set swBomFeat = swFeat.GetSpecificFeature2

'Traitement
ProcessBomFeature swBomFeat

End If

Set swFeat = swFeat.GetNextFeature

Loop

vTableArr = swBomFeat.GetTableAnnotations



End Sub



Sub ProcessBomFeature(swBomFeat As SldWorks.BomFeature)



Dim vTableArr As Variant
Dim vTable As Variant
Dim swTable As SldWorks.TableAnnotation
Dim swAnn As SldWorks.Annotation
Dim nNumCol As Long
Dim nNumRow As Long
Dim sRowStr As String
Dim i As Long
Dim j As Long

'Récupération des tables d'annotation
vTableArr = swBomFeat.GetTableAnnotations

'Parcours des tables d'annotation
For Each vTable In vTableArr

'Récupération d'une table
Set swTable = vTable

'Récupération des contenus
Set swAnn = swTable.GetAnnotation

'Nombre de colonne et de ligne
nNumCol = swTable.ColumnCount
nNumRow = swTable.RowCount

'Nom et type de table
Debug.Print " Table : " & swAnn.GetName & " Type : " & swTable.Type

'Parcours des lignes
For i = 0 To nNumRow - 1

sRowStr = " "

'Parcours des colonnes
For j = 0 To nNumCol - 1

sRowStr = sRowStr & swTable.Text(i, j) & " | "

Next j

' Affichage du contenu
Debug.Print Left(sRowStr, Len(sRowStr) - 1)

Next i



'Dossier de sortie
Dim xlsPath As String
xlsPath = Mid(swModel.GetPathName, 1, InStrRev(swModel.GetPathName, "")

'Nom du XLS
Dim xlsName As String
If InStrRev(swModel.GetTitle, ".") > 0 Then
xlsName = Mid(swModel.GetTitle, 1, InStrRev(swModel.GetTitle, ".") - 1) & ".csv"
Else
xlsName = swModel.GetTitle & ".csv"
End If

Debug.Print "Sortie : " & xlsPath & xlsName

'Export Excel

swTable.SaveAsText xlsPath & xlsName, ";"

Next vTable

MsgBox "Export terminé"

End Sub

Could anyone help me??

Thanks
 
Try this
Dim swApp As Object
Sub main()


Dim swFeat As SldWorks.Feature
Dim swBomFeat As SldWorks.BomFeature

'Application SW
Set swApp = Application.SldWorks

'Document actif
Set swModel = swApp.ActiveDoc
Debug.Print "Document : " & swModel.GetTitle



'Récupération de la première fonction
Set swFeat = swModel.FirstFeature


'Parcours des autres fonctions
Do While Not swFeat Is Nothing



'Récupération des fonction de type Nomenclature (BOM)
If "BomFeat" = swFeat.GetTypeName Then

Debug.Print "Fonction : " & swFeat.Name

Set swBomFeat = swFeat.GetSpecificFeature2

'Traitement
ProcessBomFeature swBomFeat

End If

Set swFeat = swFeat.GetNextFeature

Loop

vTableArr = swBomFeat.GetTableAnnotations



End Sub
Sub ProcessBomFeature(swBomFeat As SldWorks.BomFeature)


Set swModel = swApp.ActiveDoc
Dim vTableArr As Variant
Dim vTable As Variant
Dim swTable As SldWorks.TableAnnotation
Dim swAnn As SldWorks.Annotation
Dim nNumCol As Long
Dim nNumRow As Long
Dim sRowStr As String
Dim i As Long
Dim j As Long
Dim k As Integer 'added
Dim Repeat As Integer 'added
Dim oRowStr As String 'added
Dim BOMOut() As String 'added


'Set the next line to how many times you want the BOM to repeat on the sheet
Repeat = 3 'added
k = 0 'added
'Récupération des tables d'annotation
vTableArr = swBomFeat.GetTableAnnotations

'Parcours des tables d'annotation
For Each vTable In vTableArr
k = k + 1 'added

'Récupération d'une table
Set swTable = vTable

'Récupération des contenus
Set swAnn = swTable.GetAnnotation

'Nombre de colonne et de ligne
nNumCol = swTable.ColumnCount
nNumRow = swTable.RowCount

ReDim BOMOut(0 To nNumRow - 1) As String 'added

'Nom et type de table
Debug.Print " Table : " & swAnn.GetName & " Type : " & swTable.Type

'Parcours des lignes
For i = 0 To nNumRow - 1

sRowStr = " "
oRowStr = "" 'added

'Parcours des colonnes
For j = 0 To nNumCol - 1

sRowStr = sRowStr & swTable.Text(i, j) & " | "
oRowStr = oRowStr & swTable.Text(i, j) & "," 'added

Next j

BOMOut(i) = Left(oRowStr, Len(oRowStr) - 1) 'added

' Affichage du contenu
Debug.Print Left(sRowStr, Len(sRowStr) - 1)

Next i


'Dossier de sortie
Dim xlspath As String
xlspath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".") - 1) & k & ".csv" 'This causes each bom on the sheet to get a different suffix
''Nom du XLS
''Dim xlsName As String
''If InStrRev(swModel.GetTitle, ".") > 0 Then
''xlsName = Mid(swModel.GetTitle, 1, InStrRev(swModel.GetTitle, ".") - 1) & ".csv"
''Else
''xlsName = swModel.GetTitle & ".csv"
''End If

Debug.Print "Sortie : " & xlspath

'Export Excel 'this replaces the previous code
Open xlspath For Output As #1
For i = 1 To Repeat
If i = 1 Then x = 0 Else x = 1 'If you want the Titles to repeat above each copy of the BOM, then change this line to just "x=1" (no quotes)
For j = x To nNumRow - 1
Print #1, BOMOut(j)
Next j
Print #1, "" 'If you don't want a space between groups delete this line
Next i
Close #1

'swTable.SaveAsText xlspath & xlsName, ";"

Next vTable

MsgBox "Export terminé"

End Sub
 

Articles From 3DCAD World

Sponsor

Back
Top