![[cheers]](/data/assets/smilies/cheers.gif "[cheers] [cheers]")
Option Explicit
Option Base 1
Dim swApp As SldWorks.SldWorks
Dim swApp1 As Object
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.DrawingDoc
Dim swView As SldWorks.View
Dim swTable As SldWorks.TableAnnotation
Const swDocDRAWING = 3
Const swTableType = 2
Const swOpenDocOptions_Silent = &H1
Public NoOfAss As Long
Public Type BOM_Data
Item As String
PartNumber As String
Qty As String
Description As String
Material As String
Supplier As String
End Type
Public LineItem() As BOM_Data
'.........................................
'.........................................
'.........................................
Sub ImportBOM()
'
'
Dim swError As Long, iPos As Long, bClose As Boolean, returnOK As Boolean
Dim nextdoc As Object, stmp As String, Model As Object
Dim sModelName As String, sPartName As String
Dim strTitle As String, strPartNumber As String
Dim i As Long, nNumRow As Long
Dim docTitle As String
'.........................................
'.........................................
'.........................................
'switch to solid works
Set swApp = GetObject(, "SldWorks.Application")
swApp.Visible = True
If Err.Number <> 0 Then
MsgBox "Can not Find SldWorks.Application" & vbCrLf & _
"ErrNo: " & Err.Number & " ErrMsg: " & Err.Description _
, vbOKOnly, "Error in ExportBOM()"
Err.Clear
GoTo CleanUp
End If
'get the drawing
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
Call MsgBox("Unable to open document!", vbExclamation, "Import BOM") ' Display error message
GoTo CleanUp ' If no model currently loaded, then exit
Else
Set swPart = swModel
docTitle = swPart.GetTitle
End If
'Get Drawing Template (first view)
Set swView = swPart.GetFirstView
Do While Not swView Is Nothing
Set swTable = swView.GetFirstTableAnnotation
Do While Not swTable Is Nothing
If swTable.Type = swTableType Then
'Process Table if BOM
nNumRow = swTable.RowCount
ReDim LineItem(nNumRow - 1)
'Get table content
For i = 1 To nNumRow - 1
LineItem(i).Item = swTable.Text(i, 0)
LineItem(i).PartNumber = swTable.Text(i, 5)
LineItem(i).Qty = swTable.Text(i, 1)
LineItem(i).Description = swTable.Text(i, 4)
LineItem(i).Material = swTable.Text(i, 2)
LineItem(i).Supplier = swTable.Text(i, 3)
Next i
End If
Set swTable = swTable.GetNext
Loop
Set swView = swView.GetNextView
Loop
'Doc is drawing ->activate model and read "Description" from there
Set swView = swPart.GetFirstView 'dwg template
Set swView = swView.GetNextView 'first dwg view
'get referenced model
sModelName = swView.GetReferencedModelName()
'switch to the model if it is already open
sPartName = sModelName
iPos = InStr(1, sPartName, "\")
Do While iPos > 0
sPartName = Right(sPartName, Len(sPartName) - iPos)
iPos = InStr(1, sPartName, "\")
Loop
' On Error Resume Next
Set nextdoc = swApp.GetFirstDocument
stmp = nextdoc.GetTitle
bClose = True 'assume file is not open
Do While stmp <> ""
If InStr(1, stmp, sPartName) > 0 Then
If nextdoc.Visible = True Then
bClose = False 'document is already open
Else
bClose = True 'document is not open yet
End If
Exit Do
End If
Set nextdoc = nextdoc.GetNext
stmp = nextdoc.GetTitle
If Err.Number <> 0 Then Exit Do
Loop
Set Model = swApp.ActivateDoc2(sModelName, True, swError)
' get Description from the model
strTitle = Model.CustomInfo("Description")
' get Part Number from Model Name
strPartNumber = Left(stmp, Len(stmp) - 7)
'reactivate drawing
'close the model
Model.Save2 True
If bClose = True Then 'only close if we had to open it
swApp.CloseDoc sModelName
End If
Set swPart = swApp.ActivateDoc2(docTitle, True, swError)
'return to Excel
'.........................................
'.........................................
'.........................................
CleanUp:
Unload frmNoOfAss
Set swApp = Nothing
Set swPart = Nothing
Set swView = Nothing
Set swTable = Nothing
Set Model = Nothing
Set nextdoc = Nothing
End Sub