Center of gravity - macro for SolidWorks 1

[picia]

Hi. I create a macro for Solid Works which identify selected surface and give data about it. Now I want write macro which give information about center of gravity selected surface. If You have any sugestion or time to solve this problem I willbe greatful - Piotrek

 

[handleman]

If you want the CG of a part you can use the macro at

http://www.solidworktips.com/macro_pages/index.htm

This was the first result of a Google search for "solidworks center of gravity macro"

If you want the "CG" in 3D space of some arbritrary surface (i.e. not a planar face or a solid body) you have a different problem entirely.

 

[picia]

Ok, thanks. I find this macro earlier, but this program sketch a point (center of gravity) of a body(part) and I need center of a selected surface not a part...

 

[handleman]

This code creates a reference point at the CG of a surface and returns a pointer to the refpoint. It's the same as going to Insert>Reference Geometry>Point... and choosing "center of face".

Sub main()

Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
Dim vRefPointFeatures As Variant
vRefPointFeatures = Part.FeatureManager.InsertReferencePoint(4, 0, 0.01, 1)
End Sub

 

[picia]

hello, thanks handleman for your help...
now i try make a macro which return coordinates of center of selected surface no sketch this point.if You have any idea please weite... thanks...

 

[handleman]

All you have to do after creating the point is to get its coordinates and then delete the point.

Sub GetXYZofSurfaceCentroid()
'***********************************
'Get XYZ coordinates of centroid and load
'them into array "XYZ"
'***********************************

Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim SelMgr As SldWorks.SelectionMgr
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim Feature As SldWorks.Feature
Dim MathPoint As SldWorks.MathPoint
Dim RefPoint As SldWorks.RefPoint
Dim vRefPointFeatureArray As Variant
Dim XYZ As Variant
Set swApp = Application.SldWorks

Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager
If SelMgr.GetSelectedObjectCount2(-1) <> 1 Then
    MsgBox "You must select a single face/surface for this macro."
    Exit Sub
ElseIf SelMgr.GetSelectedObjectType3(1, -1) <> swSelFACES Then
    MsgBox SelMgr.GetSelectedObjectType3(1, -1)
    MsgBox "You must select a single face/surface for this macro."
    Exit Sub
End If

vRefPointFeatureArray = Part.FeatureManager.InsertReferencePoint(4, 0, 0.01, 1)
Set Feature = vRefPointFeatureArray(0)
Set RefPoint = Feature.GetSpecificFeature2
Set MathPoint = RefPoint.GetRefPoint
XYZ = MathPoint.ArrayData
Set MathPoint = Nothing
Set RefPoint = Nothing
Set Feature = Nothing
Part.Extension.DeleteSelection2 (2)
MsgBox "X: " & XYZ(0) & vbCrLf & "Y: " & XYZ(1) & vbCrLf & "Z: " & XYZ(2)
End Sub

 

[picia]

I must say that You are very good in this subject (SolidWorks&VBA). You help me much, so I am greatful You for your help.Thanks!

 

[bloodclot]

When trying to access the macro page link I get this message:

"This domain name expired on 03/26/2006 and is pending renewal or deletion"

FYI

I come from a small town where the population NEVER changed. Everytime someone got pregnant, someone left town.