ds-blue-logo
sw-logo
Login and Get Started
Preview  |  SOLIDWORKS USER FORUM
Use your SOLIDWORKS ID or 3DEXPERIENCE ID to log in.
exporting part dimensions to excel file
EBEdgars Baumanis13/01/2018

Hi!

I have found on the internet one macro that I would like to improve. It opens up assembly and exports each part weight. In the end I would like to get macro which opens up assembly, then reads dimensions of part and export that information to excel. Main purpose of that would be knowing how much of different metal sheet would be needed to make the parts from assembly. I understand that getpartbox function returns not so precise information, especially if that part has irregular shape. However, for me it is not so important, getpartbox function would be suitable for me.

Here is the original macro that I have found: 

Dim swApp As SldWorks.SldWorks
Dim SwModel As SldWorks.ModelDoc2
Dim swModExt As SldWorks.ModelDocExtension
Dim swAssembly As SldWorks.AssemblyDoc
Dim SwComp As SldWorks.Component2
Dim MassProp As SldWorks.MassProperty
Dim Component As Variant
Dim Components As Variant
Dim Bodies As Variant
Dim BodyInfo As Variant
Dim CenOfM As Variant
Dim RetBool As Boolean
Dim RetVal As Long
Dim xlApp As Excel.Application
Dim xlWorkBooks As Excel.Workbooks
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim OutputPath As String
Dim OutputFN As String
Dim xlCurRow As Integer
Sub main()
Set swApp = Application.SldWorks
Set SwModel = swApp.ActiveDoc
If SwModel Is Nothing Then
        swApp.SendMsgToUser2 "An assembly must be an active document.", swMbWarning, swMbOk
        Exit Sub
      End If
      
         
If SwModel.GetType <> swDocASSEMBLY Then
        swApp.SendMsgToUser2 "An assembly must be an active document.", swMbWarning, swMbOk
        Exit Sub
Else
Set swAssembly = SwModel
End If
Set swModExt = SwModel.Extension
Set MassProp = swModExt.CreateMassProperty
OutputPath = Environ("USERPROFILE") & "\Desktop\"
OutputFN = SwModel.GetTitle & ".xlsx"
If Dir(OutputPath & OutputFN) <> "" Then
Kill OutputPath & OutputFN
End If
Set xlApp = Excel.Application
xlApp.Visible = True
Set xlWorkBooks = Excel.Workbooks
Set xlBook = xlWorkBooks.Add()
Set xlsheet = xlBook.Worksheets("Sheet1")
xlsheet.Range("A1").Value = "Component"
xlsheet.Range("B1").Value = "X Loc (mm)"
xlsheet.Range("C1").Value = "Y Loc (mm)"
xlsheet.Range("D1").Value = "Z Loc (mm)"
xlsheet.Range("E1").Value = "Mass (kg)"
xlsheet.Range("F1").Value = "Type"
xlBook.SaveAs OutputPath & OutputFN
xlCurRow = 2
RetVal = swAssembly.ResolveAllLightWeightComponents(False)
Components = swAssembly.GetComponents(False)
For Each Component In Components
    Set SwComp = Component
    If SwComp.GetSuppression <> 0 Then
    'If LCase(Right(SwComp.GetPathName, 3)) <> "asm" Then
        Bodies = SwComp.GetBodies2(0)
'MsgBox SwComp.Name
        'If Bodies <> Empty Then
            RetBool = MassProp.AddBodies(Bodies)
            CenOfM = MassProp.CenterOfMass
            
            xlsheet.Range("A" & xlCurRow).Value = SwComp.Name
            xlsheet.Range("B" & xlCurRow).Value = CenOfM(0) * 1000
            xlsheet.Range("C" & xlCurRow).Value = CenOfM(1) * 1000
            xlsheet.Range("D" & xlCurRow).Value = CenOfM(2) * 1000
            xlsheet.Range("E" & xlCurRow).Value = MassProp.Mass
            
            If LCase(Right(SwComp.GetPathName, 3)) = "asm" Then
            xlsheet.Range("F" & xlCurRow).Value = "Assembly"
            ElseIf LCase(Right(SwComp.GetPathName, 3)) = "prt" Then
            xlsheet.Range("F" & xlCurRow).Value = "Part"
            Else
            xlsheet.Range("F" & xlCurRow).Value = "Undetermined"
            End If 'Right 3 of file extension
            xlCurRow = xlCurRow + 1
            
            
        'End If 'UBound(Bodies) <> -1
        
    'End If 'Not an Assembly
    End If 'swComp.GetSuppression <> 0
Next Component
xlsheet.UsedRange.EntireColumn.AutoFit
xlBook.Save
'xlWorkBooks.Close
'xlApp.Quit
End Sub

I will remind that I am only beginner. I found the spot where macro start putting information into excel cells. I tried adding there this getpartbox function, but I get error. I cannot figure out why it does not like it. I get error "Object doesn' t support this property or method".

Here is "my edited" code

Dim swApp As SldWorks.SldWorks
Dim SwModel As SldWorks.ModelDoc2
Dim swModExt As SldWorks.ModelDocExtension
Dim swAssembly As SldWorks.AssemblyDoc
Dim SwComp As SldWorks.Component2
Dim MassProp As SldWorks.MassProperty
Dim Component As Variant
Dim Components As Variant
Dim Bodies As Variant
Dim BodyInfo As Variant
Dim CenOfM As Variant
Dim RetBool As Boolean
Dim RetVal As Long
Dim xlApp As Excel.Application
Dim xlWorkBooks As Excel.Workbooks
Dim xlBook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim OutputPath As String
Dim OutputFN As String
Dim xlCurRow As Integer
 Dim SolidWorksPartCorners As Variant
Sub main()
Set swApp = Application.SldWorks
Set SwModel = swApp.ActiveDoc
If SwModel Is Nothing Then
        swApp.SendMsgToUser2 "An assembly must be an active document.", swMbWarning, swMbOk
        Exit Sub
      End If
      
         
If SwModel.GetType <> swDocASSEMBLY Then
        swApp.SendMsgToUser2 "An assembly must be an active document.", swMbWarning, swMbOk
        Exit Sub
Else
Set swAssembly = SwModel
End If
Set swModExt = SwModel.Extension
Set MassProp = swModExt.CreateMassProperty
OutputPath = Environ("USERPROFILE") & "\Desktop\"
OutputFN = SwModel.GetTitle & ".xlsx"
If Dir(OutputPath & OutputFN) <> "" Then
Kill OutputPath & OutputFN
End If
Set xlApp = Excel.Application
xlApp.Visible = True
Set xlWorkBooks = Excel.Workbooks
Set xlBook = xlWorkBooks.Add()
Set xlsheet = xlBook.Worksheets("Sheet1")
xlsheet.Range("A1").Value = "Component"
xlsheet.Range("B1").Value = "X Loc (mm)"
xlsheet.Range("C1").Value = "Y Loc (mm)"
xlsheet.Range("D1").Value = "Z Loc (mm)"
xlsheet.Range("E1").Value = "Mass (kg)"
xlsheet.Range("F1").Value = "Type"
xlBook.SaveAs OutputPath & OutputFN
xlCurRow = 2
RetVal = swAssembly.ResolveAllLightWeightComponents(False)
Components = swAssembly.GetComponents(False)
For Each Component In Components
    Set SwComp = Component
    If SwComp.GetSuppression <> 0 Then
    'If LCase(Right(SwComp.GetPathName, 3)) <> "asm" Then
        Bodies = SwComp.GetBodies2(0)
'MsgBox SwComp.Name
        'If Bodies <> Empty Then
            RetBool = MassProp.AddBodies(Bodies)
        ' '     CenOfM = MassProp.CenterOfMass
            
      
            
       
            
            xlsheet.Range("A" & xlCurRow).Value = SwComp.Name
        ' '     xlsheet.Range("B" & xlCurRow).Value = CenOfM(0) * 1000
        ' '     xlsheet.Range("C" & xlCurRow).Value = CenOfM(1) * 1000
        ' '     xlsheet.Range("D" & xlCurRow).Value = CenOfM(2) * 1000
            xlsheet.Range("E" & xlCurRow).Value = MassProp.Mass
      
            
            If LCase(Right(SwComp.GetPathName, 3)) = "asm" Then
            xlsheet.Range("F" & xlCurRow).Value = "Assembly"
            ElseIf LCase(Right(SwComp.GetPathName, 3)) = "prt" Then
            xlsheet.Range("F" & xlCurRow).Value = "Part"
            Else
            xlsheet.Range("F" & xlCurRow).Value = "Undetermined"
            End If 'Right 3 of file extension
            
            
            
            
                  SolidWorksPartCorners = SwModel.GetPartBox(True)
            
            
            xlCurRow = xlCurRow + 1
            
            
        'End If 'UBound(Bodies) <> -1
        
    'End If 'Not an Assembly
    End If 'swComp.GetSuppression <> 0
Next Component
xlsheet.UsedRange.EntireColumn.AutoFit
xlBook.Save
'xlWorkBooks.Close
'xlApp.Quit
End Sub

Can you help me fix this problem, so I can continue editing this script?