AnsweredAssumed Answered

Print Section Properties of Multiple selected faces to Excel

Question asked by Kenny Kobetsky on Jan 30, 2019

The purpose of this macro is to be able to select multiple surfaces from an assembly, and print out (to excel) the Area and Area Moment of Inertia (Ixx,Iyy,Izz) for each individual surface selected. For example, selecting both surfaces below with cursor, running the macro, and printing to excel each surface's respective Area, Ixx, Iyy, and Izz:


The code below works for one surface, but when multiple surfaces are selected, the macro is unable to distinguish between each individual surface, combines them, and outputs as if one selection was made. Any thoughts?




'Select surfaces before running macro

'Selection must be a surface


Dim swApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim FirstRow As Long

Dim FirstCol As Long

Dim Area As Long

Dim XVal As Long

Dim YVal As Long

Dim ZVal As Long

Dim AMOIxx As Long

Dim AMOIyy As Long

Dim AMOIzz As Long

Dim vComps As Variant

Dim i As Integer

Dim Message1 As String

Dim Message2 As String

Dim swModelExt As SldWorks.ModelDocExtension

Dim swSelMgr As SldWorks.SelectionMgr

Dim swFeat() As SldWorks.Feature

Dim swFaceEnt() As SldWorks.Entity

Dim swSketch As SldWorks.Sketch

Dim nSelType As Long

Dim swSelObj() As Object

Dim vSelObj As Variant

Dim vSectionProp As Variant

Dim nSelCount As Integer

Dim nNumObj As Long

Dim nFeatureArr() As Variant



Sub main()


Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

Set swModelExt = swModel.Extension

Set swSelMgr = swModel.SelectionManager





If swModel Is Nothing Then

swApp.SendMsgToUser2 "An Assembly document must be open as the active document(Error Code:1).", swMbWarning, swMbOk

Exit Sub

ElseIf swModel.GetType <> swDocASSEMBLY Then

swApp.SendMsgToUser2 "An Assembly document must be open as the active document(Error Code:2).", swMbWarning, swMbOk

Exit Sub


Message1 = "Assembly file confirmed!"

swApp.SendMsgToUser2 Message1, 2, 2 'first 2 = "ok option", second 2 = display info icon

End If





nSelCount = swSelMgr.GetSelectedObjectCount

Debug.Print "Selected Count: " & nSelCount


If nSelCount = 0 Then

swApp.SendMsgToUser2 "You must make a selection before running the macro (Error Code:2).", swMbWarning, swMbOk

Exit Sub


Message2 = "Number of Selections: " & nSelCount

swApp.SendMsgToUser2 Message2, 2, 2 'first 2 = "ok option", second 2 = display info icon

End If






Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True 'Display the created workbook

Set xlBook = xlApp.Workbooks.Add 'Create a new workbook

Set xlSheet = xlBook.Worksheets("Sheet1") 'Define which worksheet to use within the workbook


FirstRow = 1

FirstCol = 1


Area = FirstCol + 1

AMOIxx = FirstCol + 2

AMOIyy = FirstCol + 3

AMOIzz = FirstCol + 4


FilePath = swModel.GetPathName 'Defining file Path (to use to print to excel)

Debug.Print "FilePath: " & FilePath

FileName = swModel.GetTitle 'Defining file Name (to use to print to excel)

Debug.Print "FileName: " & FileName


'Labels for excel print out

xlSheet.Cells(FirstRow + 1, FirstCol).value = FileName

xlSheet.Cells(FirstRow + 2, FirstCol).value = "Config #"

xlSheet.Cells(FirstRow + 1, Area).value = "Area"

xlSheet.Cells(FirstRow + 2, Area).value = "mm^2"

xlSheet.Cells(FirstRow + 1, AMOIxx).value = "AMOI xx"

xlSheet.Cells(FirstRow + 2, AMOIxx).value = "mm^4"

xlSheet.Cells(FirstRow + 1, AMOIyy).value = "AMOI yy"

xlSheet.Cells(FirstRow + 2, AMOIyy).value = "mm^4"

xlSheet.Cells(FirstRow + 1, AMOIzz).value = "AMOI zz"

xlSheet.Cells(FirstRow + 2, AMOIzz).value = "mm^4"

FirstRow = FirstRow + 3 'start data on row 4






Dim swFace() As SldWorks.Face2

ReDim Preserve swFace(nSelCount - 1) 're-dimension array to have as many cells as there are selections



For i = 1 To nSelCount

Debug.Print "i: " & i


Set swFace(i - 1) = swSelMgr.GetSelectedObject5(i)



nSelType = swSelMgr.GetSelectedObjectType2(i)

Debug.Print "Selection Type: " & nSelType



nNumObj = nNumObj + 1

Debug.Print "nNumObj: " & nNumObj

ReDim Preserve swSelObj(nNumObj - 1)

ReDim Preserve swFaceEnt(nNumObj - 1)


Set swComponent = swFace(i - 1).GetComponent 'used to get the component name for excel printout


Set swFaceEnt(nNumObj - 1) = swFace(i - 1)

Set swSelObj(nNumObj - 1) = swFace(i - 1)




'Deselect faces and sketches; otherwise, user-interface selections are added to array parameter; leave section faces selected

If Not IsEmpty(swFaceEnt) Then

Debug.Print "Are we here?"

For k = 0 To UBound(swFaceEnt)


Next k

End If


If Not IsEmpty(swFeat) Then

Debug.Print "Are we also here?"

For k = 0 To UBound(swFeat)


Next k

End If


'This adds the array of faces or sketches to the selection set because the faces or sketches have been deselected, this preserves the selection set

vSelObj = swSelObj


vSectionProp = swModelExt.GetSectionProperties((vSelObj))

' Return code from: IModelDocExtension::GetSectionProperties

' 0 = success

' 1 = invalid input

' 2 = selected faces are not in the same or parallel planes

' 3 = unable to compute section properties

Debug.Print " Return code: " & vSectionProp(0)


'Print values in excel for each selection

xlSheet.Cells(FirstRow, FirstCol).value = swComponent.GetSelectByIDString

xlSheet.Cells(FirstRow, Area).value = vSectionProp(1) * 1000000#

xlSheet.Cells(FirstRow, AMOIxx).value = vSectionProp(5) * 1000000000000#

xlSheet.Cells(FirstRow, AMOIyy).value = vSectionProp(6) * 1000000000000#

xlSheet.Cells(FirstRow, AMOIzz).value = vSectionProp(7) * 1000000000000#

FirstRow = FirstRow + 1

Debug.Print "Next Empty Row: " & FirstRow

Debug.Print "Area: " & vSectionProp(1) * 1000000#


xlSheet.UsedRange.EntireColumn.AutoFit 'Resize cells to fit all info


Next i


xlSheet.Cells(1, FirstCol).value = FilePath 'print pathname (without resizing cell)


End Sub