macro to export center of mass/gravity of parts from an assembly to excel

Mark did you looked at this macro by Tobin: https://forum.solidworks.com/message/215433#215433

Try this, but make sure to add Excel in as a resource.  This is specifically designed to output the COM to an excel file for each part component in the assembly (not sub assemblies, but all the way down to the part level).

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
Set swAssembly = SwModel
Set swModExt = SwModel.Extension
Set MassProp = swModExt.CreateMassProperty

OutputPath = Environ("USERPROFILE") & "\Desktop\CenterOfMass\"
OutputFN = SwModel.GetTitle & ".xlsx"

If Dir(OutputPath & OutputFN) <> "" Then
Kill OutputPath & OutputFN
End If

Set xlApp = Excel.Application
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.GetBodies3(0, BodyInfo)
'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
            xlBook.Save
           
        'End If 'UBound(Bodies) <> -1
       
    End If 'Not an Assembly

    End If 'swComp.GetSuppression <> 0

Next Component

xlWorkBooks.Close
xlApp.Quit

End Sub

Hello;

VB newbie here.

This works great!!!!

Can someone help me to change the units from metric to inch/lbs?

Thanks in advance for your time!

Not sure whether the issue of the sub assembly's mass using the assembly's mass.was cleared or not but I used the macro "Macro to Export Part Mass and COG (Assy).swp" written by Deepak to solve it.

Just put in the codes between @@@ as shown below.

'                                If Bodies <> Empty Then

'                                   @@@

'                                    Mass for asm and prt

                                    Dim swCompModel As SldWorks.ModelDoc2

                                    Set swCompModel = swComp.GetModelDoc2

                                    Dim swMassProps As SldWorks.MassProperty

                                    If Not swCompModel Is Nothing Then

                                        Set swMassProps = swCompModel.Extension.CreateMassProperty()

                                    Else

                                    swApp.SendMsgToUser2 "Error getting the File " & swCompModel.GetName, swMbWarning, swMbOk

                                    End If

'                                   @@@

'

'

'

And change the mass variable callout to swMassProps.Mass instead of MassProp.Mass

                                    xlsheet.Range("E" & xlCurRow).Value = swMassProps.Mass

Extra note:

Please clean up the unused variable or reorder the variable initialization to you want to. Explore Deepak's macro for more depth.

My understanding was that the code below does not work with sub assembly. That is why the mass was just taken from the parent assembly instead.

RetBool = MassProp.AddBodies(Bodies)

Therefore you need the code below inside the "For Each Component In Components" loop

Set swMassProps = swCompModel.Extension.CreateMassProperty()

instead of the code in the parent assembly

Set swModExt = SwModel.Extension

Set MassProp = swModExt.CreateMassProperty

Experts,
I am working on mass and cog extraction and exportation to excel
I am working on vb.net and not vba. I have implemeted the mecro posted by Deepak (Deepak Gupta 4 mars 2013 07:22) on vb.net bu and here is the code:

Public Sub ComponentsAttributs()

        swModelDoc2 = iSwApp.ActiveDoc

        'Dim swModExt As ModelDocExtension

        Dim swAssembly As AssemblyDoc = swModelDoc2

        Dim SwComp As Component2

        Dim MassProp As MassProperty

        Dim Component As Object

        Dim Components As Object

        Dim Bodies As Object

        'Dim BodyInfo As Object

        Dim CenOfM As Object

        Dim RetBool As Boolean

        Dim RetVal As Long

        'Dim OutputPath As String

        'Dim OutputFN As String

        Dim ExcelCurRow As Integer

        '--------------------------------------------------'

        MassProp = swModelDoc2.Extension.CreateMassProperty

        'Start Excel and get Application object.

        ExcelApp = CreateObject("Excel.Application")

        ExcelApp.Visible = True

        ' Add a new workbook.

        ExcelWorkBook = ExcelApp.Workbooks.Add

        ExcelSheet = ExcelWorkBook.ActiveSheet

        ExcelSheet.Cells(1, 1).Value = "Component"

        ExcelSheet.Cells(1, 2).Value = "X Loc (mm)"

        ExcelSheet.Cells(1, 3).Value = "Y Loc (mm)"

        ExcelSheet.Cells(1, 4).Value = "Z Loc (mm)"

        ExcelSheet.Cells(1, 5).Value = "Mass (kg)"

        ExcelSheet.Cells(1, 6).Value = "Type"

        ExcelCurRow = 2

        RetVal = swAssembly.ResolveAllLightWeightComponents(False)

        Components = swAssembly.GetComponents(False)

        For Each Component In Components

            SwComp = Component

            If SwComp.GetSuppression <> 0 Then

                'If LCase(Right(SwComp.GetPathName, 3)) <> "asm" Then

                Bodies = SwComp.GetBodies3(-1, 1)

                'MsgBox SwComp.Name

                'If Bodies <> Empty Then

                RetBool = MassProp.AddBodies(Bodies)

                CenOfM = MassProp.CenterOfMass

                txtComponentsData.Text = txtComponentsData.Text & SwComp.Name & vbCrLf

                ExcelSheet.Range("A" & ExcelCurRow).Value = SwComp.Name

                ExcelSheet.Range("B" & ExcelCurRow).Value = CenOfM(0) * 1000

                ExcelSheet.Range("C" & ExcelCurRow).Value = CenOfM(1) * 1000

                ExcelSheet.Range("D" & ExcelCurRow).Value = CenOfM(2) * 1000

                ExcelSheet.Range("E" & ExcelCurRow).Value = MassProp.Mass

                If LCase(Microsoft.VisualBasic.Right(SwComp.GetPathName, 3)) = "asm" Then

                    ExcelSheet.Range("F" & ExcelCurRow).Value = "Assembly"

                ElseIf LCase(Microsoft.VisualBasic.Right(SwComp.GetPathName, 3)) = "prt" Then

                    ExcelSheet.Range("F" & ExcelCurRow).Value = "Part"

                Else

                    ExcelSheet.Range("F" & ExcelCurRow).Value = "Undetermined"

                End If 'Right 3 of file extension

                ExcelCurRow = ExcelCurRow + 1

                'End If 'UBound(Bodies) <> -1

                'End If 'Not an Assembly

            End If 'swComp.GetSuppression <> 0

        Next Component

        ExcelSheet.UsedRange.EntireColumn.AutoFit()

    End Sub

the code goes on but  I have the following result: the same values on all compoenents.
Can anyone help me?

Dear all,

I'm currently using this macro but the result is the same for all assembly.
Someone could help me to debug it....

Follow the macro used:

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 swMassProps 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

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("Feuil1")

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

        Set swModExt = SwModel.Extension

        Set MassProp = swModExt.CreateMassProperty

        MassProp.UseSystemUnits = True

        'Mass for asm and prt

           Dim swCompModel As SldWorks.ModelDoc2

           Set swCompModel = SwComp.GetModelDoc2

           Dim swMassProps As SldWorks.MassProperty

           If Not swCompModel Is Nothing Then

            Set swMassProps = swCompModel.Extension.CreateMassProperty()

           Else

            swApp.SendMsgToUser2 "Error getting the File " & swCompModel.GetName, swMbWarning, swMbOk

           End If

            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 = swMassProps.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

            Erase CenOfM

        '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

Hello all,

After collaboration with Deepak Gupta, we get this macro (CF).
Problem is than she give data in local, but we want to get them in global system as you have in your mass proprieties window.

If you know or look for on it share ;p