Macro to find center of gravity of a shape

[JuneTheSecond]

I made a macro to find a center of gravity of a given shape.

This macro makes a copy of the shape,
slice vertically the copied shape into n pieces,
calculate center of gravity, delete sliced shapes,
and add mark to show the center of gravity.

To find center of gravity,
ppease add new page, create a new shape on blank page, ot drop down a shape.
And run macro "FindGravityCenterOnShape".

Please enjoy.

[JuneTheSecond]

Macro to find mean aerodynamic chord of wing as well as center of gravity.
Mean aerodynamic chord is shortly called as MAC.
MAC is one of the most important parameters to design airplane.

[Yacine]

Hi Junichi-san, as usual outstanding cool. And even If I don't see a usage for me in it right now, just my congratulations for the performance. ;-)

[Visio Guy]

Wow, you are doing "Visual Calculus"!

I think there are other ways to find the center of area by using vectors around the edges of polygons. (Signed Area?). So you could use calls to the shp.Paths(n).Points to get vectors even for curved outlines, then calculate using vectors based on those points.

[JuneTheSecond]

Lot of thanks, Visio Guy!
I forgot such an elegant way you suggested.
The outer product of 2 vectors makes twice the area of triangle.
May be a good way, may culculate correctly, even if the shape is complicated.

[JuneTheSecond]

Here is the macro using Shape.Paths(n).Points property.
Thank you Visio Guy again.

Code Select Expand



Option Explicit
Option Base 1

Sub FindGravityCenterByShapePath()

    Dim shp As Visio.Shape
    Dim xy() As Double
    Dim UB As Long
    Set shp = ActiveWindow.Selection(1)
    Dim Length As Double
    Dim Area As Double
    Dim xg As Double
    Dim yg As Double
    Dim x() As Double
    Dim y() As Double
    Dim I As Long
    Dim N As Long
   
    If shp.Paths.Count <> 1 Then
        MsgBox "Shape must be simple."
        Exit Sub
    End If
   
   
   
    shp.Paths(1).Points 0#, xy
   
    UB = UBound(xy)
    N = UB / 2 + 1
    ReDim Preserve x(N)
    ReDim Preserve y(N)
       
    For I = 1 To N - 1
        x(I) = xy(2 * I - 2) - shp.Cells("PinX")
        y(I) = xy(2 * I - 1) - shp.Cells("PinY")
    Next
        x(N) = x(1)
        y(N) = y(1)
       
        CalcLength shp, x, y, N, Length
        CalcArea shp, x, y, N, Area
        CalcCG shp, x, y, N, xg, yg
   
    Debug.Print Length
    Debug.Print Area
    Debug.Print xg, yg
End Sub

Sub CalcLength(shp As Visio.Shape, x() As Double, y() As Double, N As Long, Length As Double)
    Dim I As Long
   
    For I = 1 To N - 1
        Length = Length + Sqr((x(I + 1) - x(I)) ^ 2 + (y(I + 1) - y(I)) ^ 2)
    Next

End Sub

Sub CalcArea(shp As Visio.Shape, x() As Double, y() As Double, N As Long, Area As Double)
    Dim I As Long
   
    For I = 1 To N - 1
        Area = Area + (x(I) * y(I + 1) - y(I) * x(I + 1)) * 0.5
    Next

End Sub

Sub CalcCG(shp As Visio.Shape, x() As Double, y() As Double, N As Long, xg As Double, yg As Double)
    Dim I As Long
    Dim xMoment As Double
    Dim yMoment As Double
    Dim xs As Double
    Dim ys As Double
    Dim Area As Double
    Dim dArea As Double
    Dim d As Double
    Dim OvalShp As Visio.Shape
    Dim xc As Double
    Dim yc As Double
   
       
    For I = 1 To N - 1
       
        dArea = (x(I) * y(I + 1) - y(I) * x(I + 1)) * 0.5
        Area = Area + dArea
        xs = (x(I) + x(I + 1)) / 3#
        ys = (y(I) + y(I + 1)) / 3#
        xMoment = xMoment + dArea * xs
        yMoment = yMoment + dArea * ys
    Next
   
    xg = xMoment / Area + shp.Cells("LocPinX")
    yg = yMoment / Area + shp.Cells("LocPinY")
   
    xc = xMoment / Area + shp.Cells("PinX")
    yc = yMoment / Area + shp.Cells("PinY")
   
   
    d = 0.1
    Set OvalShp = ActivePage.DrawOval(xc - d, yc - d, xc + d, yc + d)
    OvalShp.DrawLine OvalShp.Cells("Width") * 0, OvalShp.Cells("Height") * 0.5, OvalShp.Cells("Width") * 1, OvalShp.Cells("Height") * 0.5
    OvalShp.DrawLine OvalShp.Cells("Width") * 0.5, OvalShp.Cells("Height") * 0, OvalShp.Cells("Width") * 0.5, OvalShp.Cells("Height") * 1
   
End Sub