Daily Download 9: Animation in Excel

The missing post from yesterday’s list was: Drawing in Excel – 2 , with download file:

http://www.interactiveds.com.au/software/animate.zip

Other animation related posts include:

By Jingo
Dancing Pendulums
Yet more pendulums
Rotating Hypercubes
Animated Pythagoras

This entry was posted in Animation, Excel, Javascript, VBA and tagged , , . Bookmark the permalink.

9 Responses to Daily Download 9: Animation in Excel

  1. audeser says:

    Nice illustrative post about application of momentum conservation (Newton’s 2nd law). It would be nice to have it generalized to any number of objects, like a molecular dynamics system.
    So, reworking a bit your code, Sub Animate, I get something that would look like Sub AnimateGeneralized (it’s yet not finished, … not fully solved registration and storage of multiple collisions, but not far from it’s final stage. It requires only a blank worksheet, beacuse of rnd generation of objects):

    Option Explicit
    Const Pi As Double = 3.14159265358979

    Private Type tXYZ
    X As Double
    Y As Double
    Z As Double
    End Type
    Private Type tCollision
    Shp1 As Long
    Shp2 As Long
    Time As Double
    End Type

    Public Sub Animate()
    Dim oShpFrm As Excel.Shape
    Dim lgShp As Long
    Dim lgShpEval As Long
    Dim oShp1 As Excel.Shape
    Dim oShp2 As Excel.Shape

    Dim Ovl1R As Single
    Dim Ovl2R As Single
    Dim CCDist As Single

    Dim TopBox As Single
    Dim BottBox As Single
    Dim LeftBox As Single
    Dim RightBox As Single

    Dim CenterShp1 As tXYZ
    Dim CenterShp2 As tXYZ
    Dim DimShp1 As tXYZ
    Dim DimShp2 As tXYZ
    Dim vectorShp1 As tXYZ
    Dim vectorShp2 As tXYZ
    Dim Velocity As tXYZ
    Dim CCAng As Single
    Dim Shp2_Speed As Single
    Dim Shp1_Speed As Single
    Dim Angle_Shp2 As Single
    Dim Angle_Shp1 As Single
    Dim DX As Single
    Dim DY As Single

    Dim Start As Single
    Dim TimeStep As Double
    Dim TimeEval As Double
    Dim TimeCollision As Double

    With ActiveSheet
    For Each oShpFrm In .Shapes
    oShpFrm.Delete
    Next oShpFrm

    Velocity.X = 10 ‘.Range(“Hspeed”).Value
    Velocity.Y = 10 ‘.Range(“Vspeed”).Value

    TimeStep = 0.01

    ‘ Get frame limits
    Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
    Left:=20, _
    Top:=20, _
    Width:=400, _
    Height:=400)
    ‘oShpFrm.Name = “Frame”
    With oShpFrm
    TopBox = .Top
    BottBox = TopBox + .Height
    LeftBox = .Left
    RightBox = LeftBox + .Width
    End With

    ‘Random shape creation and speed vector assignment
    DimShp1.X = (50 * Rnd())
    DimShp1.Y = DimShp1.X ‘(50 * Rnd())
    CenterShp1.X = LeftBox + ((RightBox – LeftBox – DimShp1.X) * Rnd())
    CenterShp1.Y = TopBox + ((BottBox – TopBox – DimShp1.Y) * Rnd())
    Set oShp1 = .Shapes.AddShape(Type:=msoShapeOval, _
    Left:=CenterShp1.X, _
    Top:=CenterShp1.Y, _
    Width:=DimShp1.X, _
    Height:=DimShp1.Y)
    ‘oShp1.Name = “Oval1”
    With vectorShp1
    .X = Velocity.X * (((RightBox – LeftBox) / 1000) * Rnd())
    .Y = Velocity.Y * (((BottBox – TopBox) / 1000) * Rnd())
    End With
    DimShp2.X = (50 * Rnd())
    DimShp2.Y = DimShp2.X ‘(50 * Rnd())
    CenterShp2.X = LeftBox + ((RightBox – LeftBox – DimShp2.X) * Rnd())
    CenterShp2.Y = TopBox + ((BottBox – TopBox – DimShp2.Y) * Rnd())
    Set oShp2 = .Shapes.AddShape(Type:=msoShapeOval, _
    Left:=CenterShp2.X, _
    Top:=CenterShp2.Y, _
    Width:=DimShp2.X, _
    Height:=DimShp2.Y)
    ‘oShp1.Name = “Oval2”
    With vectorShp2
    .X = Velocity.X * (((RightBox – LeftBox) / 1000) * Rnd())
    .Y = Velocity.Y * (((BottBox – TopBox) / 1000) * Rnd())
    End With

    Ovl1R = (DimShp1.X + DimShp1.Y) / 4
    Ovl2R = (DimShp2.X + DimShp2.Y) / 4

    ‘ Random initial movements:
    With vectorShp1
    .X = Velocity.X * (((RightBox – LeftBox) / 1000) * Rnd())
    .Y = Velocity.Y * (((BottBox – TopBox) / 1000) * Rnd())
    End With
    With vectorShp2
    .X = Velocity.X * (((RightBox – LeftBox) / 1000) * Rnd())
    .Y = Velocity.Y * (((BottBox – TopBox) / 1000) * Rnd())
    End With

    Do
    With oShp1
    .IncrementLeft vectorShp1.X
    .IncrementTop vectorShp1.Y
    CenterShp1.X = .Left + (DimShp1.X / 2)
    CenterShp1.Y = .Top + (DimShp1.Y / 2)
    End With
    With vectorShp1
    If (CenterShp1.X RightBox – (DimShp1.X / 2)) Then .X = -.X
    If (CenterShp1.Y BottBox – (DimShp1.Y / 2)) Then .Y = -.Y
    End With
    With oShp2
    .IncrementLeft vectorShp2.X
    .IncrementTop vectorShp2.Y
    CenterShp2.X = .Left + (DimShp2.X / 2)
    CenterShp2.Y = .Top + (DimShp2.Y / 2)
    End With
    With vectorShp2
    If (CenterShp2.X RightBox – (DimShp2.X / 2)) Then .X = -.X
    If (CenterShp2.Y BottBox – (DimShp2.Y / 2)) Then .Y = -.Y
    End With

    ‘Distance between shapes
    DX = (CenterShp1.X – CenterShp2.X)
    DY = (CenterShp1.Y – CenterShp2.Y)
    CCDist = Sqr(DX ^ 2 + DY ^ 2)

    If CCDist < (Ovl1R + Ovl2R) Then
    If DX 0 Then CCAng = Atn(DY / DX) Else CCAng = Pi / 2
    With vectorShp1
    Angle_Shp1 = Atn(.Y / .X)
    Shp1_Speed = Sqr(.X ^ 2 + .Y ^ 2)
    End With
    With vectorShp2
    Angle_Shp2 = Atn(.Y / .X)
    Shp2_Speed = Sqr(.X ^ 2 + .Y ^ 2)
    End With

    Angle_Shp1 = CCAng * 2 – Angle_Shp1
    Angle_Shp2 = CCAng * 2 – Angle_Shp2

    With vectorShp1
    .X = -Shp1_Speed * Cos(Angle_Shp1)
    .Y = Shp1_Speed * Sin(Angle_Shp1)
    End With
    With vectorShp2
    .X = Shp2_Speed * Cos(Angle_Shp2)
    .Y = -Shp2_Speed * Sin(Angle_Shp2)
    End With
    End If

    Start = VBA.Timer()
    Do While VBA.Timer() t = (X2o – X1o)/(vx1 – vx2)
    ‘ So, we have to find the next collision in time (searching with any next object we find):
    For lgShpEval = (lgShp + 1) To UBound(oShp)
    TimeEval = (CenterShp(lgShp).X – CenterShp(lgShpEval).X) _
    / (vectorShp(lgShpEval).X – vectorShp(lgShp).X)

    CenterShp(lgShp).Y = CenterShp(lgShp).Y + (TimeEval * vectorShp(lgShp).Y)
    CenterShp(lgShpEval).Y = CenterShp(lgShpEval).Y + (TimeEval * vectorShp(lgShpEval).Y)

    If VBA.Abs(CenterShp(lgShp).Y – CenterShp(lgShpEval).Y) 0 Then ‘ negative times implies that they are getting separated
    If TimeCollision > TimeEval Then
    TimeCollision = TimeEval
    Erase oCollision()
    ReDim Preserve oCollision(g_Base)
    oCollision(g_Base).Shp1 = lgShp
    oCollision(g_Base).Shp2 = lgShpEval

    Else ‘If TimeCollision = TimeEval Then
    ‘More than two objects colliding at the same moment:
    TimeCollision = TimeEval
    lgCollision = lgCollision + 1
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(lgCollision).Shp1 = lgShp
    oCollision(lgCollision).Shp2 = lgShpEval
    End If
    End If
    End If
    Next lgShpEval

    ‘ Check collision against frame walls:
    TimeEval = (CenterShp(lgShp).X – (LeftBox + DimShp(lgShp).X / 2)) _
    / vectorShp(lgShp).X
    If TimeEval > 0 Then ‘ negative times implies that they are getting separated
    If TimeCollision > TimeEval Then
    TimeCollision = TimeEval
    Erase oCollision()
    lgCollision = g_Base
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(lgCollision).Shp1 = lgShp
    oCollision(lgCollision).Shp2 = -xlEdgeLeft ‘7
    ElseIf TimeCollision = TimeEval Then
    TimeCollision = TimeEval
    lgCollision = lgCollision + 1
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(g_Base).Shp1 = lgShp
    oCollision(g_Base).Shp2 = -xlEdgeLeft ‘7
    End If
    End If
    TimeEval = (RightBox – (DimShp(lgShp).X / 2) – CenterShp(lgShp).X) _
    / vectorShp(lgShp).X
    If TimeEval > 0 Then ‘ negative times implies that they are getting separated
    If TimeCollision > TimeEval Then
    TimeCollision = TimeEval
    Erase oCollision()
    lgCollision = g_Base
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(lgCollision).Shp1 = lgShp
    oCollision(lgCollision).Shp2 = -xlEdgeLeft ‘7
    ElseIf TimeCollision = TimeEval Then
    TimeCollision = TimeEval
    lgCollision = lgCollision + 1
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(g_Base).Shp1 = lgShp
    oCollision(g_Base).Shp2 = -xlEdgeRight ’10
    End If
    End If
    TimeEval = (CenterShp(lgShp).Y – (TopBox + DimShp(lgShp).Y / 2)) _
    / vectorShp(lgShp).Y
    If TimeEval > 0 Then ‘ negative times implies that they are getting separated
    If TimeCollision > TimeEval Then
    TimeCollision = TimeEval
    Erase oCollision()
    lgCollision = g_Base
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(lgCollision).Shp1 = lgShp
    oCollision(lgCollision).Shp2 = -xlEdgeLeft ‘7
    ElseIf TimeCollision = TimeEval Then
    TimeCollision = TimeEval
    lgCollision = lgCollision + 1
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(g_Base).Shp1 = lgShp
    oCollision(g_Base).Shp2 = -xlEdgeTop ‘8
    End If
    End If
    TimeEval = (BottBox – (DimShp(lgShp).X / 2) – CenterShp(lgShp).Y) _
    / vectorShp(lgShp).Y
    If TimeEval > 0 Then ‘ negative times implies that they are getting separated
    If TimeCollision > TimeEval Then
    TimeCollision = TimeEval
    Erase oCollision()
    lgCollision = g_Base
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(lgCollision).Shp1 = lgShp
    oCollision(lgCollision).Shp2 = -xlEdgeLeft ‘7
    ElseIf TimeCollision = TimeEval Then
    TimeCollision = TimeEval
    lgCollision = lgCollision + 1
    ReDim Preserve oCollision(g_Base To lgCollision)
    oCollision(g_Base).Shp1 = lgShp
    oCollision(g_Base).Shp2 = -xlEdgeBottom ‘9
    End If
    End If
    Next lgShp

    ‘ No object collide with anything until TimeCollision, so:
    For lgShp = LBound(oShp) To UBound(oShp)
    With oShp(lgShp)
    .IncrementLeft (vectorShp(lgShp).X * TimeCollision)
    .IncrementTop (vectorShp(lgShp).Y * TimeCollision)
    CenterShp(lgShp).X = .Left + (DimShp(lgShp).X / 2)
    CenterShp(lgShp).Y = .Top + (DimShp(lgShp).Y / 2)
    End With
    Next lgShp

    Stop
    ‘ First check collisions against walls
    lgCounter = LBound(oCollision)
    For lgCollision = LBound(oCollision) To UBound(oCollision)
    If oCollision(lgCollision).Shp2 < 0 Then 'Wall collision
    If oCollision(lgCollision).Shp2 = xlEdgeLeft Then
    With vectorShp(oCollision(lgCollision).Shp1)
    .X = -.X
    End With
    End If
    If oCollision(lgCollision).Shp2 = xlEdgeRight Then
    With vectorShp(oCollision(lgCollision).Shp1)
    .X = -.X
    End With
    End If
    If oCollision(lgCollision).Shp2 = xlEdgeBottom Then
    With vectorShp(oCollision(lgCollision).Shp1)
    .Y = -.Y
    End With
    End If
    If oCollision(lgCollision).Shp2 = xlEdgeTop Then
    With vectorShp(oCollision(lgCollision).Shp1)
    .Y = -.Y
    End With
    End If

    Else
    lgCounter = lgCounter + 1 'Counter with other particles
    ReDim Preserve PtrCollision(g_Base To lgCounter)
    PtrCollision(lgCounter) = lgCollision

    'If they are not repeated…
    ' bStack = True
    ' For lgPtr = LBound(PtrCollision) To UBound(PtrCollision)
    ' If oCollision(PtrCollision(lgPtr)).Shp1 = …lgShp1 Then
    ' bStack = False
    ' Exit For
    ' End If
    ' If oCollision(PtrCollision(lgPtr)).Shp2 = …lgShp1 Then
    ' bStack = False
    ' Exit For
    ' End If
    ' Next lgPtr
    ' If bStack Then
    ' ReDim Preserve PtrObj(g_Base To lgCounter)
    ' PtrObj(lgCounter) = oCollision(lgCollision).Shp1
    ' End If
    '
    ' bStack = True
    ' For lgPtr = LBound(PtrCollision) To UBound(PtrCollision)
    ' If oCollision(PtrCollision(lgPtr)).Shp1 = …lgShp2 Then
    ' bStack = False
    ' Exit For
    ' End If
    ' If oCollision(PtrCollision(lgPtr)).Shp2 = …lgShp2 Then
    ' bStack = False
    ' Exit For
    ' End If
    ' Next lgPtr
    ' If bStack Then
    ' ReDim Preserve PtrObj(g_Base To lgCounter)
    ' PtrObj(lgCounter) = oCollision(lgCollision).Shp2
    ' End If

    End If
    Next lgCollision

    Stop
    ' Then process collisions against other particles
    If Not (Not PtrCollision()) Then
    'Create XYZ systems of equations for the momentum (call Gauss-Jordan solver):
    ReDim mCollision(LBound(PtrCollision) To UBound(PtrCollision), _
    LBound(PtrCollision) To UBound(PtrCollision) + 1)

    ReDim PtrObj(LBound(PtrCollision) To UBound(PtrCollision))
    For lgCollision = LBound(PtrCollision) To UBound(PtrCollision)
    Next lgCollision
    ' Sort elements by Id
    'Call fQuickSort_ArrayLng(PtrObj())

    'For X direction
    For lgCollision = LBound(PtrCollision) To UBound(PtrCollision)
    '…………
    ' mMomentum(lgCollision).X = mMomentum(lgCollision).X _
    ' + vectorShp(lgShp1).X * (DimShp(lgShp1).X + DimShp(lgShp1).Y) / 2 _
    ' + vectorShp(lgShp2).X * (DimShp(lgShp2).X + DimShp(lgShp2).Y) / 2
    ' mMomentum(lgCollision).Y = mMomentum(lgCollision).Y _
    ' + vectorShp(lgShp1).Y * (DimShp(lgShp1).Y + DimShp(lgShp1).Y) / 2 _
    ' + vectorShp(lgShp2).Y * (DimShp(lgShp2).Y + DimShp(lgShp2).Y) / 2

    ' 'Distance between shapes (lgShp1, lgShp2)
    ' DX = (CenterShp(lgShp1).X – CenterShp(lgShp2).X)
    ' DY = (CenterShp(lgShp1).Y – CenterShp(lgShp2).Y)
    '
    ' If DX 0 Then CCAng = Atn(DY / DX) Else CCAng = Pi / 2

    ‘ With vectorShp(oCollision(lgCollision).Shp1)
    ‘ Angle_Shp1 = Atn(.Y / .X)
    ‘ Shp1_Speed = Sqr(.X ^ 2 + .Y ^ 2)
    ‘ End With
    ‘ With vectorShp(oCollision(lgCollision).Shp2)
    ‘ Angle_Shp2 = Atn(.Y / .X)
    ‘ Shp2_Speed = Sqr(.X ^ 2 + .Y ^ 2)
    ‘ End With

    ‘ Angle_Shp1 = CCAng * 2 – Angle_Shp1
    ‘ Angle_Shp2 = CCAng * 2 – Angle_Shp2

    ‘ With vectorShp(oCollision(lgCollision).Shp1)
    ‘ .X = -Shp1_Speed * Cos(Angle_Shp1)
    ‘ .Y = Shp1_Speed * Sin(Angle_Shp1)
    ‘ End With
    ‘ With vectorShp(oCollision(lgCollision).Shp2)
    ‘ .X = Shp2_Speed * Cos(Angle_Shp2)
    ‘ .Y = -Shp2_Speed * Sin(Angle_Shp2)
    ‘ End With
    ‘…………
    Next lgCollision
    ‘Call fGaussJordan(mMomentum)

    ‘For Y direction…
    ‘…
    ‘For Z direction…
    ‘…
    End If

    Start = VBA.Timer()
    Do While VBA.Timer() < (Start + TimeStep) 'TimeCollision
    DoEvents
    Loop
    Loop
    End With
    End Sub

    'Public Function fGaussJordan()
    'End Function
    'Public Function fQuickSort_ArrayLng()
    'End Function

    As I stated, is not yet finished. I have -somewhere- another code for colliding cars with no-elastic collision implementation that I'll post on my blog (by the way, I recomend to take a look it, as following posts will deal with structural calculations on Excel… following your guidances, as well as Turan Babacan's implementations on Excel and Youtuber Manos).
    And finally related to this

    Like

    • audeser says:

      The fQuickSort_ArrayLng() will be post as the code is finally finished, so here only the fGaussJordan() function:
      Public Function fGaussJordan(ByRef mArray() As Double) As Double()
      Dim lgR As Long
      Dim lgC As Long
      Dim lgPivot As Long
      Dim lgR_Homogenize As Long
      Dim dbTmp As Double
      Dim lgRetVal As Long
      Dim mArrayTmp() As Double
      Dim Nm As Integer

      On Error GoTo ErrControl

      Nm = UBound(mArray, 1) – LBound(mArray, 1) + 1
      ReDim mArrayTmp(LBound(mArray, 1) To UBound(mArray, 1), LBound(mArray, 2) To UBound(mArray, 2))

      ‘ Swap rows (if needed)
      If (mArray(0, 0) = 0) Then
      For lgR = LBound(mArray, 1) To UBound(mArray, 1)
      If (mArray(lgR, 0) 0) Then
      For lgC = LBound(mArray, 2) To UBound(mArray, 2)
      mArrayTmp(0, lgC) = mArray(0, lgC)
      mArray(0, lgC) = mArray(lgR, lgC)
      mArray(lgR, lgC) = mArrayTmp(0, lgC)
      Next lgC
      End If
      Next lgR
      End If

      For lgPivot = LBound(mArray, 1) To UBound(mArray, 1)
      dbTmp = mArray(lgPivot, lgPivot)
      For lgC = LBound(mArray, 2) To UBound(mArray, 2)
      mArray(lgPivot, lgC) = mArray(lgPivot, lgC) / dbTmp
      Next lgC
      For lgR = LBound(mArray, 1) To UBound(mArray, 1)
      If (lgR = lgPivot) Then GoTo NextRow
      dbTmp = mArray(lgR, lgPivot)
      For lgR_Homogenize = LBound(mArray, 2) To UBound(mArray, 2)
      mArray(lgR, lgR_Homogenize) = mArray(lgR, lgR_Homogenize) – (dbTmp * mArray(lgPivot, lgR_Homogenize))
      Next lgR_Homogenize
      NextRow:
      Next lgR
      Next lgPivot

      ‘Print solution
      ReDim mArrayTmp(LBound(mArray, 1) To UBound(mArray, 1))
      For lgR = LBound(mArray, 1) To UBound(mArray, 1)
      mArrayTmp(lgR) = mArray(lgR, Nm)
      ‘Debug.Print VBA.Format(mArray(lgR, Nm), “##,##0.00”)
      Next lgR
      fGaussJordan = mArrayTmp()

      ExitProc:
      Exit Function

      ErrControl:
      lgRetVal = VBA.MsgBox(“System has no solution”, vbCritical)
      End Function

      Like

    • dougaj4 says:

      Thanks for the code and the links. I’ll reply properly later, but it looks like the end of your message got truncated.

      Liked by 1 person

  2. audeser says:

    Doug, I have continued working with this subject (collision for a system of particles), and tried to check the moment convervation as well as the kinetic energy.
    Following Wikipedia archive found two implementations for 2D collision between two particles, so I’ve included yours, and another one found in a MIT article. So I coded the function fCollision.
    To run the program, simply run sCollision_2Objects (paste code in blank worksheet).

    Option Explicit
    
    Private Const PI As Double = 3.14159265358979
    Public Const EPSILON As Double = 0.0000001
    Private bStop As Boolean
    
    Private Type tXYZ
        X As Double
        Y As Double
        Z As Double
    End Type
    
    Public Function fCollision(ByRef CenterShp1 As tXYZ, _
                               ByRef CenterShp2 As tXYZ, _
                               ByRef vectorShp1 As tXYZ, _
                               ByRef vectorShp2 As tXYZ, _
                               Optional ByVal Ovl1R As Double = 1, _
                               Optional ByVal Ovl2R As Double = 1, _
                               Optional ByVal dbMassShp1 As Double = 1, _
                               Optional ByVal dbMassShp2 As Double = 1, _
                               Optional ByVal lgSelector As Long = 1) As Boolean
        Dim vectorShp1_ As tXYZ
        Dim vectorShp2_ As tXYZ
        Dim velShp1 As Double
        Dim velShp2 As Double
        Dim CCDist As Double 'centers distance
        Dim dx As Double
        Dim dy As Double
        Dim dbAngle As Double
        Dim dbAngle1 As Double
        Dim dbAngle2 As Double
        Dim dbMass1Ratio As Double
        Dim dbMass2Ratio As Double
        Dim dbTotalMass As Double
        
        dbTotalMass = (dbMassShp1 + dbMassShp2)
        dbMass1Ratio = dbMassShp1 / dbTotalMass
        dbMass2Ratio = dbMassShp2 / dbTotalMass
        
        dx = (CenterShp1.X - CenterShp2.X)
        dy = (CenterShp1.Y - CenterShp2.Y)
        CCDist = Sqr(dx ^ 2 + dy ^ 2)
    
        If CCDist < (Ovl1R + Ovl2R) Then 'They collide
            fCollision = True
    
            'Debug.Print "oShp1(" & VBA.Format(vectorShp1.X, "0.00") & ", " & VBA.Format(vectorShp1.Y, "0.00") & ")" & vbNewLine & _
                        "oShp2(" & VBA.Format(vectorShp2.X, "0.00") & ", " & VBA.Format(vectorShp2.Y, "0.00") & ")"
            lgSelector = 2
            'For lgSelector = 1 To 4
                Select Case lgSelector
                    Case 1:
                    '1) from https://en.m.Wikipedia.org/wiki/Elastic_collision
                    ' This does not keep Kinetic energy constant
                        With vectorShp1
                            velShp1 = VBA.Sqr(.X ^ 2 + .Y ^ 2)
                            If VBA.Abs(.X) > EPSILON Then dbAngle1 = Atn(.Y / .X) Else dbAngle1 = PI / 2
                        End With
                        With vectorShp2
                            velShp2 = VBA.Sqr(.X ^ 2 + .Y ^ 2)
                            If VBA.Abs(.X) > EPSILON Then dbAngle2 = Atn(.Y / .X) Else dbAngle2 = PI / 2
                        End With
                
                        vectorShp1_.X = (((dbMassShp1 - dbMassShp2) * velShp1 * Cos(dbAngle1 - dbAngle)) _
                                      + (2 * dbMassShp2 * velShp2 * Cos(dbAngle2 - dbAngle)) * (Cos(dbAngle) / dbTotalMass)) _
                                      + (velShp1 * Sin(dbAngle1 - dbAngle) * Sin(dbAngle))
                        vectorShp1_.Y = (((dbMassShp1 - dbMassShp2) * velShp1 * Cos(dbAngle1 - dbAngle)) _
                                      + (2 * dbMassShp2 * velShp2 * Cos(dbAngle2 - dbAngle)) * (Sin(dbAngle) / dbTotalMass)) _
                                      + (velShp1 * Sin(dbAngle1 - dbAngle) * Cos(dbAngle))
                
                        vectorShp2_.X = (((dbMassShp2 - dbMassShp1) * velShp2 * Cos(dbAngle2 - dbAngle)) _
                                      + (2 * dbMassShp1 * velShp1 * Cos(dbAngle1 - dbAngle)) * (Cos(dbAngle) / dbTotalMass)) _
                                      + (velShp2 * Sin(dbAngle2 - dbAngle) * Sin(dbAngle))
                        vectorShp2_.Y = (((dbMassShp2 - dbMassShp1) * velShp2 * Cos(dbAngle2 - dbAngle)) _
                                      + (2 * dbMassShp1 * velShp1 * Cos(dbAngle1 - dbAngle)) * (Sin(dbAngle) / dbTotalMass)) _
                                      + (velShp2 * Sin(dbAngle2 - dbAngle) * Cos(dbAngle))
                            
                    Case 2:
                    '2)  from https://en.m.Wikipedia.org/wiki/Elastic_collision.
                    ' This does not keep Kinetic energy constant
                        Dim Movement_1_2 As tXYZ
                        Dim Movement_2_1 As tXYZ
                        Dim Contact_1_2 As tXYZ
                        Dim Contact_2_1 As tXYZ
                        Dim dbModule As Double
                        Dim dbModule_2 As Double
                        Dim Movement_1_2·Contact_1_2 As Double
                        Dim Movement_2_1·Contact_2_1 As Double
                
                        With Movement_1_2
                            .X = vectorShp1.X - vectorShp2.X
                            .Y = vectorShp1.Y - vectorShp2.Y
                        End With
                        With Movement_2_1
                            .X = -Movement_1_2.X
                            .Y = -Movement_1_2.Y
                        End With
                        With Contact_1_2
                            .X = CenterShp1.X - CenterShp2.X
                            .Y = CenterShp1.Y - CenterShp2.Y
                        End With
                        dbModule_2 = fVector²(Contact_1_2)
                        dbModule = fVectorModule(Contact_1_2)
                        With Contact_2_1
                            .X = -Contact_1_2.X / dbModule
                            .Y = -Contact_1_2.Y / dbModule
                        End With
                        With Contact_1_2
                            .X = -Contact_2_1.X
                            .Y = -Contact_2_1.Y
                        End With
                
                        Movement_1_2·Contact_1_2 = fDotProduct(Movement_1_2, Contact_1_2, False)
                        Movement_2_1·Contact_2_1 = fDotProduct(Movement_2_1, Contact_2_1, False)
                        
                        vectorShp1_.X = vectorShp1.X - (2 * dbMass2Ratio * Movement_1_2·Contact_1_2 * Contact_1_2.X)
                        vectorShp1_.Y = vectorShp1.Y - (2 * dbMass2Ratio * Movement_1_2·Contact_1_2 * Contact_1_2.Y)
                        
                        vectorShp2_.X = vectorShp2.X - (2 * dbMass1Ratio * Movement_2_1·Contact_2_1 * Contact_2_1.X)
                        vectorShp2_.Y = vectorShp2.Y - (2 * dbMass1Ratio * Movement_2_1·Contact_2_1 * Contact_2_1.Y)
                
                    Case 3:
                    '3) from: http://web.mit.edu/8.01t/www/materials/modules/chapter15.pdf   Eq 0.4.17 & 0.4.20
                        vectorShp1_.X = (vectorShp1.X * (dbMassShp1 - dbMassShp2) / dbTotalMass) _
                                      + (vectorShp2.X * (2 * dbMassShp2) / dbTotalMass)
                        vectorShp2_.X = (vectorShp2.X * (dbMassShp2 - dbMassShp1) / dbTotalMass) _
                                      + (vectorShp1.X * (2 * dbMassShp1) / dbTotalMass)
                
                        vectorShp1_.Y = (vectorShp1.Y * (dbMassShp1 - dbMassShp2) / dbTotalMass) _
                                      + (vectorShp2.Y * (2 * dbMassShp2) / dbTotalMass)
                        vectorShp2_.Y = (vectorShp2.Y * (dbMassShp2 - dbMassShp1) / dbTotalMass) _
                                      + (vectorShp1.Y * (2 * dbMassShp1) / dbTotalMass)
                
                    Case 4:
                    '4) from: http://newtonexcelbatch.com/excel drawing
                        ' Get the contact angle
                        If dx <> 0 Then dbAngle = Atn(dy / dx) Else dbAngle = PI / 2
                
                        With vectorShp1
                            dbAngle1 = Atn(.Y / .X)
                            velShp1 = Sqr(.X ^ 2 + .Y ^ 2)
                        End With
                        With vectorShp2
                            dbAngle2 = Atn(.Y / .X)
                            velShp2 = Sqr(.X ^ 2 + .Y ^ 2)
                        End With
                
                        dbAngle1 = dbAngle * 2 - dbAngle1
                        dbAngle2 = dbAngle * 2 - dbAngle2
                
                        With vectorShp1_
                            .X = -velShp1 * Cos(dbAngle1)
                            .Y = velShp1 * Sin(dbAngle1)
                        End With
                        With vectorShp2_
                            .X = velShp2 * Cos(dbAngle2)
                            .Y = -velShp2 * Sin(dbAngle2)
                        End With
                
                    'Case 5:
                    '    ' For an object, tangential velocity will vary, normal velocity will not
                    '    With vectorShp1_
                    '        .X = -velShp1 * Cos(dbAngle1)
                    '        .Y = velShp1 * Sin(dbAngle1)
                    '    End With
                    '    With vectorShp2_
                    '        .X = velShp2 * Cos(dbAngle2)
                    '        .Y = -velShp2 * Sin(dbAngle2)
                    '    End With
                
                End Select
        
            'Debug.Print vbTab & lgSelector & ": (" & VBA.Format(vectorShp1_.X, "0.00") & ", " & VBA.Format(vectorShp1_.Y, "0.00") & ")" & _
                        vbTab & " : " & "(" & VBA.Format(vectorShp2_.X, "0.00") & ", " & VBA.Format(vectorShp2_.Y, "0.00") & ")"
            'Next lgSelector
            
            vectorShp1 = vectorShp1_
            vectorShp2 = vectorShp2_
        End If
    
    End Function
    
    Public Function fDotProduct(ByRef oVector1 As tXYZ, _
                                ByRef oVector2 As tXYZ, _
                                Optional ByVal bNormalized As Boolean = False) As Double
        Dim dbModule1 As Double
        Dim dbModule2 As Double
        
        If bNormalized Then
            dbModule1 = fVectorModule(oVector1) 'VBA.Sqr(oVector1.X ^ 2 + oVector1.Y ^ 2 + oVector1.Z ^ 2)
            dbModule2 = fVectorModule(oVector2) 'VBA.Sqr(oVector2.X ^ 2 + oVector2.Y ^ 2 + oVector2.Z ^ 2)
            fDotProduct = (oVector1.X * oVector2.X _
                         + oVector1.Y * oVector2.Y) _
                         / (dbModule1 * dbModule2)
        Else
            fDotProduct = oVector1.X * oVector2.X _
                        + oVector1.Y * oVector2.Y
        End If
        
    End Function
    
    Public Function fVector²(ByRef oVector As tXYZ) As Double
        With oVector
            fVector² = (.X ^ 2 + .Y ^ 2 + .Z ^ 2)
        End With
    End Function
    
    Public Function fVectorModule(ByRef oVector As tXYZ) As Double
        With oVector
            fVectorModule = VBA.Sqr(.X ^ 2 + .Y ^ 2 + .Z ^ 2)
        End With
    End Function
    
    Public Sub sCollision_2Objects()
        Dim oShpFrm As Excel.Shape
        Dim lgShp As Long
        Dim lgShpEval As Long
        Dim oShp1 As Excel.Shape
        Dim oShp2 As Excel.Shape
        
        Dim Ovl1R As Single
        Dim Ovl2R As Single
        Dim CCDist As Single
        
        Dim TopBox As Single
        Dim BottBox As Single
        Dim LeftBox As Single
        Dim RightBox As Single
        
        Dim CenterShp1 As tXYZ
        Dim CenterShp2 As tXYZ
        Dim DimShp1 As tXYZ
        Dim DimShp2 As tXYZ
        Dim dbMassShp1 As Double
        Dim dbMassShp2 As Double
        Dim vectorShp1 As tXYZ
        Dim vectorShp2 As tXYZ
        Dim vectorShp1_ As tXYZ
        Dim vectorShp2_ As tXYZ
        Dim Velocity As tXYZ
        Dim Momentum As tXYZ
        Dim Momentum_ As tXYZ
        Dim EKinetic As Double
        Dim EKinetic_ As Double
        Dim CCAng As Single
        Dim Shp2_Speed As Single
        Dim Shp1_Speed As Single
        Dim Angle_Shp2 As Single
        Dim Angle_Shp1 As Single
        Dim dx As Single
        Dim dy As Single
        
        Dim Start As Single
        Dim TimeStep As Double
        Dim TimeEval As Double
        Dim TimeCollision As Double
    
        With ActiveSheet
            For Each oShpFrm In .Shapes
                oShpFrm.Delete
            Next oShpFrm
            
            Velocity.X = 5 '.Range("Hspeed").Value
            Velocity.Y = 5 '.Range("Vspeed").Value
        
            TimeStep = 0.01
            
            ' Command Button
            Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                           Left:=430, _
                                           Top:=20, _
                                           Width:=30, _
                                           Height:=20)
            oShpFrm.OnAction = "sAnimation"
            
            ' Command Button "Stop"
            Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                           Left:=430, _
                                           Top:=50, _
                                           Width:=30, _
                                           Height:=20)
            oShpFrm.OnAction = "sStop"
    
            ' Get frame limits
            Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                           Left:=20, _
                                           Top:=20, _
                                           Width:=400, _
                                           Height:=400)
            'oShpFrm.Name = "Frame"
            With oShpFrm
                TopBox = .Top
                BottBox = TopBox + .Height
                LeftBox = .Left
                RightBox = LeftBox + .Width
            End With
        
            'Random shape creation and speed vector assignment
            DimShp1.X = 50 '(50 * Rnd())
            DimShp1.Y = 50 'DimShp1.X '(50 * Rnd())
            CenterShp1.X = LeftBox + ((RightBox - LeftBox - DimShp1.X) * Rnd())
            CenterShp1.Y = TopBox + ((BottBox - TopBox - DimShp1.Y) * Rnd())
            Set oShp1 = .Shapes.AddShape(Type:=msoShapeOval, _
                                         Left:=CenterShp1.X, _
                                         Top:=CenterShp1.Y, _
                                         Width:=DimShp1.X, _
                                         Height:=DimShp1.Y)
            'oShp1.Name = "Oval1"
            With vectorShp1
                .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
            End With
            DimShp2.X = 30 '(50 * Rnd())
            DimShp2.Y = 30 'DimShp2.X '(50 * Rnd())
            CenterShp2.X = LeftBox + ((RightBox - LeftBox - DimShp2.X) * Rnd())
            CenterShp2.Y = TopBox + ((BottBox - TopBox - DimShp2.Y) * Rnd())
            Set oShp2 = .Shapes.AddShape(Type:=msoShapeOval, _
                                         Left:=CenterShp2.X, _
                                         Top:=CenterShp2.Y, _
                                         Width:=DimShp2.X, _
                                         Height:=DimShp2.Y)
            'oShp1.Name = "Oval2"
            With vectorShp2
                .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
            End With
            
            Ovl1R = (DimShp1.X + DimShp1.Y) / 4
            Ovl2R = (DimShp2.X + DimShp2.Y) / 4
    
            ' Random initial movements:
            With vectorShp1
                .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
            End With
            With vectorShp2
                .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
            End With
            
            dbMassShp1 = PI * (DimShp1.X / 2) ^ 2
            dbMassShp2 = PI * (DimShp2.X / 2) ^ 2
            
            With Momentum
                .X = (dbMassShp1 * vectorShp1.X) + (dbMassShp2 * vectorShp2.X)
                .Y = (dbMassShp1 * vectorShp1.Y) + (dbMassShp2 * vectorShp2.Y)
            End With
            EKinetic = (1 / 2) * (dbMassShp1 * (vectorShp1.X ^ 2 + vectorShp1.Y ^ 2) _
                                + dbMassShp2 * (vectorShp2.X ^ 2 + vectorShp2.Y ^ 2))
            
            Do
                With oShp1
                    .IncrementLeft vectorShp1.X
                    .IncrementTop vectorShp1.Y
                    CenterShp1.X = .Left + (DimShp1.X / 2)
                    CenterShp1.Y = .Top + (DimShp1.Y / 2)
                End With
                With vectorShp1
                    If (CenterShp1.X < LeftBox + (DimShp1.X / 2)) Or (CenterShp1.X > RightBox - (DimShp1.X / 2)) Then .X = -.X
                    If (CenterShp1.Y < TopBox + (DimShp1.Y / 2)) Or (CenterShp1.Y > BottBox - (DimShp1.Y / 2)) Then .Y = -.Y
                End With
                With oShp2
                    .IncrementLeft vectorShp2.X
                    .IncrementTop vectorShp2.Y
                    CenterShp2.X = .Left + (DimShp2.X / 2)
                    CenterShp2.Y = .Top + (DimShp2.Y / 2)
                End With
                With vectorShp2
                    If (CenterShp2.X < LeftBox + (DimShp2.X / 2)) Or (CenterShp2.X > RightBox - (DimShp2.X / 2)) Then .X = -.X
                    If (CenterShp2.Y < TopBox + (DimShp2.Y / 2)) Or (CenterShp2.Y > BottBox - (DimShp2.Y / 2)) Then .Y = -.Y
                End With
    
                If fCollision(CenterShp1, CenterShp2, _
                              vectorShp1, vectorShp2, _
                              Ovl1R, Ovl2R, _
                              dbMassShp1, dbMassShp2, _
                              2) Then
                    With Momentum_
                        .X = (dbMassShp1 * vectorShp1.X) + (dbMassShp2 * vectorShp2.X)
                        .Y = (dbMassShp1 * vectorShp1.Y) + (dbMassShp2 * vectorShp2.Y)
                    End With
                    If VBA.Abs(Momentum_.X - Momentum.X) > 1 Then Stop
                    If VBA.Abs(Momentum_.Y - Momentum.Y) > 1 Then Stop
    
                    EKinetic_ = (1 / 2) * (dbMassShp1 * (vectorShp1.X ^ 2 + vectorShp1.Y ^ 2) _
                                         + dbMassShp2 * (vectorShp2.X ^ 2 + vectorShp2.Y ^ 2))
                    
                    If VBA.Abs(EKinetic_ - EKinetic) > 0.1 Then Stop
                End If
        
                Start = VBA.Timer()
                Do While VBA.Timer() < (Start + TimeStep) 'TimeCollision
                    DoEvents
                    If bStop Then Exit Do
                Loop
            Loop
        End With
    End Sub
    

    Seems no one (the formulations) is verifying the momentum conservation (but they do on the kinetic energy). I’ve done a little visual check and only the formulations for lgSelector = 2 & lgSelector = 3 seem to give good visual results. Your implementation is not considering Mass so it should be discarded… please confirm if your idea was to show the capabilities to draw not the physical properly modelation of the collision.

    Anyway, I’ll go a little further to try to get it clear for myself.

    Kind regards

    Like

    • dougaj4 says:

      Thanks for the new code. Using the format tags makes it much easier to use. I tried it pasting into a new module in my animate spreadsheet, and it seems to work OK, but stops at the first collision.

      Yes, my code was more a demonstration of animation in VBA, rather than the physics, so the assumption was that the objects had the same mass, but it shouldn’t be too hard to add in the mass.

      Looking at your blog, some things here that you might find interesting include:
      -A VBA sort function.
      -Code linking to Python, Numpy and Scipy using xlwings
      -Links to the Alglib maths library
      -Frame analysis routines, including linear algebra solvers in VBA, Fortran, Alglib and Python.

      Like

      • audeser says:

        Hi Doug,
        I’ve, in the past, got in touch with you, dealing with the Visualization procedures.
        Your blog is incredible, and is a big reference for me, as it seems I’m always five years behind what you’re researching 🙂
        One thing that I “do not enjoy” is that you have moved to Python as calculations got more complicated. For me, it has been very hard to learn Python (VBA is much more human readable i think), but it may be the direction things should go (learn Python), as Microsoft is not pushing to much in favor of VBA (VBasic6).

        Kind regards.

        Like

    • audeser says:

      Finally, the code solution for 2D collision, where Momentum conservation and Kinetic energy conservation are met. I made a mistake, probably during debugging, because lgSelector=2 and lgSelector = 3 formulations both were energy and momentum compliant. So the code amended is here (with a nice arrow to show the movement direction):

      Public Function fCollision(ByRef CenterShp1 As tXYZ, _
                                 ByRef CenterShp2 As tXYZ, _
                                 ByRef vectorShp1 As tXYZ, _
                                 ByRef vectorShp2 As tXYZ, _
                                 Optional ByVal Ovl1R As Double = 1, _
                                 Optional ByVal Ovl2R As Double = 1, _
                                 Optional ByVal dbMassShp1 As Double = 1, _
                                 Optional ByVal dbMassShp2 As Double = 1, _
                                 Optional ByVal lgSelector As Long = 1) As Boolean
          Dim vectorShp1_ As tXYZ
          Dim vectorShp2_ As tXYZ
          Dim velShp1 As Double
          Dim velShp2 As Double
          Dim CCDist As Double 'centers distance
          Dim dx As Double
          Dim dy As Double
          Dim dbAngle As Double
          Dim dbAngle1 As Double
          Dim dbAngle2 As Double
          Dim dbMass1Ratio As Double
          Dim dbMass2Ratio As Double
          Dim dbTotalMass As Double
          
          dbTotalMass = (dbMassShp1 + dbMassShp2)
          dbMass1Ratio = dbMassShp1 / dbTotalMass
          dbMass2Ratio = dbMassShp2 / dbTotalMass
          
          dx = (CenterShp1.X - CenterShp2.X)
          dy = (CenterShp1.Y - CenterShp2.Y)
          CCDist = Sqr(dx ^ 2 + dy ^ 2)
      
          If CCDist < (Ovl1R + Ovl2R) Then 'They collide
              fCollision = True
      
              'For lgSelector = 1 To 3
                  Select Case lgSelector
                      Case 1:
                      '1) from https://en.m.Wikipedia.org/wiki/Elastic_collision
                      ' This does not keep Kinetic energy constant...
                          With vectorShp1
                              velShp1 = VBA.Sqr(.X ^ 2 + .Y ^ 2)
                              If VBA.Abs(.X) > EPSILON Then dbAngle1 = Atn(.Y / .X) Else dbAngle1 = PI / 2
                          End With
                          With vectorShp2
                              velShp2 = VBA.Sqr(.X ^ 2 + .Y ^ 2)
                              If VBA.Abs(.X) > EPSILON Then dbAngle2 = Atn(.Y / .X) Else dbAngle2 = PI / 2
                          End With
                  
                          vectorShp1_.X = (((dbMassShp1 - dbMassShp2) * velShp1 * Cos(dbAngle1 - dbAngle)) _
                                        + (2 * dbMassShp2 * velShp2 * Cos(dbAngle2 - dbAngle)) * (Cos(dbAngle) / dbTotalMass)) _
                                        + (velShp1 * Sin(dbAngle1 - dbAngle) * Sin(dbAngle))
                          vectorShp1_.Y = (((dbMassShp1 - dbMassShp2) * velShp1 * Cos(dbAngle1 - dbAngle)) _
                                        + (2 * dbMassShp2 * velShp2 * Cos(dbAngle2 - dbAngle)) * (Sin(dbAngle) / dbTotalMass)) _
                                        + (velShp1 * Sin(dbAngle1 - dbAngle) * Cos(dbAngle))
                  
                          vectorShp2_.X = (((dbMassShp2 - dbMassShp1) * velShp2 * Cos(dbAngle2 - dbAngle)) _
                                        + (2 * dbMassShp1 * velShp1 * Cos(dbAngle1 - dbAngle)) * (Cos(dbAngle) / dbTotalMass)) _
                                        + (velShp2 * Sin(dbAngle2 - dbAngle) * Sin(dbAngle))
                          vectorShp2_.Y = (((dbMassShp2 - dbMassShp1) * velShp2 * Cos(dbAngle2 - dbAngle)) _
                                        + (2 * dbMassShp1 * velShp1 * Cos(dbAngle1 - dbAngle)) * (Sin(dbAngle) / dbTotalMass)) _
                                        + (velShp2 * Sin(dbAngle2 - dbAngle) * Cos(dbAngle))
                              
                      Case 2:
                      '2)  from https://en.m.Wikipedia.org/wiki/Elastic_collision
                          Dim Movement_1_2 As tXYZ
                          Dim Movement_2_1 As tXYZ
                          Dim Contact_1_2 As tXYZ
                          Dim Contact_2_1 As tXYZ
                          Dim dbModule As Double
                          Dim dbModule_2 As Double
                          Dim Movement_1_2·Contact_1_2 As Double
                          Dim Movement_2_1·Contact_2_1 As Double
                  
                          With Movement_1_2
                              .X = vectorShp1.X - vectorShp2.X
                              .Y = vectorShp1.Y - vectorShp2.Y
                          End With
                          With Movement_2_1
                              .X = -Movement_1_2.X
                              .Y = -Movement_1_2.Y
                          End With
                          With Contact_1_2
                              .X = CenterShp1.X - CenterShp2.X
                              .Y = CenterShp1.Y - CenterShp2.Y
                          End With
                          dbModule_2 = fVector²(Contact_1_2)
                          dbModule = fVectorModule(Contact_1_2)
                          With Contact_2_1
                              .X = -Contact_1_2.X / dbModule
                              .Y = -Contact_1_2.Y / dbModule
                          End With
                          With Contact_1_2
                              .X = -Contact_2_1.X
                              .Y = -Contact_2_1.Y
                          End With
                  
                          Movement_1_2·Contact_1_2 = fDotProduct(Movement_1_2, Contact_1_2, False)
                          Movement_2_1·Contact_2_1 = fDotProduct(Movement_2_1, Contact_2_1, False)
                          
                          vectorShp1_.X = vectorShp1.X - (2 * dbMass2Ratio * Movement_1_2·Contact_1_2 * Contact_1_2.X)
                          vectorShp1_.Y = vectorShp1.Y - (2 * dbMass2Ratio * Movement_1_2·Contact_1_2 * Contact_1_2.Y)
                          
                          vectorShp2_.X = vectorShp2.X - (2 * dbMass1Ratio * Movement_2_1·Contact_2_1 * Contact_2_1.X)
                          vectorShp2_.Y = vectorShp2.Y - (2 * dbMass1Ratio * Movement_2_1·Contact_2_1 * Contact_2_1.Y)
                  
                      Case 3:
                      '3) from: http://web.mit.edu/8.01t/www/materials/modules/chapter15.pdf   Eq 0.4.17 & 0.4.20
                          vectorShp1_.X = (vectorShp1.X * (dbMassShp1 - dbMassShp2) / dbTotalMass) _
                                        + (vectorShp2.X * (2 * dbMassShp2) / dbTotalMass)
                          vectorShp2_.X = (vectorShp2.X * (dbMassShp2 - dbMassShp1) / dbTotalMass) _
                                        + (vectorShp1.X * (2 * dbMassShp1) / dbTotalMass)
                  
                          vectorShp1_.Y = (vectorShp1.Y * (dbMassShp1 - dbMassShp2) / dbTotalMass) _
                                        + (vectorShp2.Y * (2 * dbMassShp2) / dbTotalMass)
                          vectorShp2_.Y = (vectorShp2.Y * (dbMassShp2 - dbMassShp1) / dbTotalMass) _
                                        + (vectorShp1.Y * (2 * dbMassShp1) / dbTotalMass)
                  End Select
              'Next lgSelector
              
              vectorShp1 = vectorShp1_
              vectorShp2 = vectorShp2_
          End If
      
      End Function
      
      Public Sub sAnimation()
          Call sCollision_2Objects
      End Sub
      Public Sub sStop()
          bStop = Not bStop
      End Sub
      
      Public Sub sCollision_2Objects()
      Dim sgScale As Single: sgScale = 10
      '!!!!!!!!!!!!!
          Dim oShpFrm As Excel.Shape
          Dim lgShp As Long
          Dim lgShpEval As Long
          Dim oShp1 As Excel.Shape
          Dim oShp2 As Excel.Shape
          
          Dim oShpVector1 As Excel.Shape
          Dim oShpVector2 As Excel.Shape
          Dim oShpVector1_ As Excel.Shape
          Dim oShpVector2_ As Excel.Shape
          
          Dim Ovl1R As Single
          Dim Ovl2R As Single
          Dim CCDist As Single
          
          Dim TopBox As Single
          Dim BottBox As Single
          Dim LeftBox As Single
          Dim RightBox As Single
          
          Dim CenterShp1 As tXYZ
          Dim CenterShp2 As tXYZ
          Dim DimShp1 As tXYZ
          Dim DimShp2 As tXYZ
          Dim dbMassShp1 As Double
          Dim dbMassShp2 As Double
          Dim vectorShp1 As tXYZ
          Dim vectorShp2 As tXYZ
          Dim vectorShp1_ As tXYZ
          Dim vectorShp2_ As tXYZ
          Dim Velocity As tXYZ
          Dim Momentum As tXYZ
          Dim Momentum_ As tXYZ
          Dim EKinetic As Double
          Dim EKinetic_ As Double
          Dim CCAng As Single
          Dim Shp2_Speed As Single
          Dim Shp1_Speed As Single
          Dim Angle_Shp2 As Single
          Dim Angle_Shp1 As Single
          Dim dx As Single
          Dim dy As Single
          
          Dim Start As Single
          Dim TimeStep As Double
          Dim TimeEval As Double
          Dim TimeCollision As Double
      
          With ActiveSheet
              For Each oShpFrm In .Shapes
                  oShpFrm.Delete
              Next oShpFrm
              
              Velocity.X = 5 '.Range("Hspeed").Value
              Velocity.Y = 5 '.Range("Vspeed").Value
          
              TimeStep = 0.01
              
              ' Command Button
              Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                             Left:=430, _
                                             Top:=20, _
                                             Width:=30, _
                                             Height:=20)
              oShpFrm.OnAction = "sAnimation"
              
              ' Command Button "Stop"
              Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                             Left:=430, _
                                             Top:=50, _
                                             Width:=30, _
                                             Height:=20)
              oShpFrm.OnAction = "sStop"
      
              ' Get frame limits
              Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                             Left:=20, _
                                             Top:=20, _
                                             Width:=400, _
                                             Height:=400)
              'oShpFrm.Name = "Frame"
              With oShpFrm
                  TopBox = .Top
                  BottBox = TopBox + .Height
                  LeftBox = .Left
                  RightBox = LeftBox + .Width
                  
                  .Fill.Transparency = 1
              End With
          
              'Random shape creation and speed vector assignment
              DimShp1.X = 50 '(50 * Rnd())
              DimShp1.Y = 50 'DimShp1.X '(50 * Rnd())
              CenterShp1.X = LeftBox + ((RightBox - LeftBox - DimShp1.X) * Rnd())
              CenterShp1.Y = TopBox + ((BottBox - TopBox - DimShp1.Y) * Rnd())
              Set oShp1 = .Shapes.AddShape(Type:=msoShapeOval, _
                                           Left:=CenterShp1.X, _
                                           Top:=CenterShp1.Y, _
                                           Width:=DimShp1.X, _
                                           Height:=DimShp1.Y)
              With oShp1
                  .Name = "Oval1"
                  .Fill.Transparency = 1
              End With
              
              With vectorShp1
                  .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                  .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
              End With
              DimShp2.X = 30 '(50 * Rnd())
              DimShp2.Y = 30 'DimShp2.X '(50 * Rnd())
              CenterShp2.X = LeftBox + ((RightBox - LeftBox - DimShp2.X) * Rnd())
              CenterShp2.Y = TopBox + ((BottBox - TopBox - DimShp2.Y) * Rnd())
              Set oShp2 = .Shapes.AddShape(Type:=msoShapeOval, _
                                           Left:=CenterShp2.X, _
                                           Top:=CenterShp2.Y, _
                                           Width:=DimShp2.X, _
                                           Height:=DimShp2.Y)
              With oShp2
                  .Name = "Oval2"
                  .Fill.Transparency = 1
              End With
              
              With vectorShp2
                  .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                  .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
              End With
              
              Ovl1R = (DimShp1.X + DimShp1.Y) / 4
              Ovl2R = (DimShp2.X + DimShp2.Y) / 4
      
              ' Random initial movements:
              With vectorShp1
                  .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                  .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
              End With
              With vectorShp2
                  .X = Velocity.X * (((RightBox - LeftBox) / 1000) * Rnd())
                  .Y = Velocity.Y * (((BottBox - TopBox) / 1000) * Rnd())
              End With
              
              dbMassShp1 = PI * (DimShp1.X / 2) ^ 2
              dbMassShp2 = PI * (DimShp2.X / 2) ^ 2
              
              With Momentum
                  .X = (dbMassShp1 * vectorShp1.X) + (dbMassShp2 * vectorShp2.X)
                  .Y = (dbMassShp1 * vectorShp1.Y) + (dbMassShp2 * vectorShp2.Y)
              End With
              EKinetic = (1 / 2) * (dbMassShp1 * (vectorShp1.X ^ 2 + vectorShp1.Y ^ 2) _
                                  + dbMassShp2 * (vectorShp2.X ^ 2 + vectorShp2.Y ^ 2))
              
              Do
                  With oShp1
                      .IncrementLeft vectorShp1.X
                      .IncrementTop vectorShp1.Y
                      CenterShp1.X = .Left + (DimShp1.X / 2)
                      CenterShp1.Y = .Top + (DimShp1.Y / 2)
                  End With
                  With vectorShp1
                      If (CenterShp1.X < LeftBox + (DimShp1.X / 2)) Or (CenterShp1.X > RightBox - (DimShp1.X / 2)) Then .X = -.X
                      If (CenterShp1.Y < TopBox + (DimShp1.Y / 2)) Or (CenterShp1.Y > BottBox - (DimShp1.Y / 2)) Then .Y = -.Y
                  End With
                  With oShp2
                      .IncrementLeft vectorShp2.X
                      .IncrementTop vectorShp2.Y
                      CenterShp2.X = .Left + (DimShp2.X / 2)
                      CenterShp2.Y = .Top + (DimShp2.Y / 2)
                  End With
                  With vectorShp2
                      If (CenterShp2.X < LeftBox + (DimShp2.X / 2)) Or (CenterShp2.X > RightBox - (DimShp2.X / 2)) Then .X = -.X
                      If (CenterShp2.Y < TopBox + (DimShp2.Y / 2)) Or (CenterShp2.Y > BottBox - (DimShp2.Y / 2)) Then .Y = -.Y
                  End With
      
                  If Not (oShpVector1 Is Nothing) Then oShpVector1.Delete
                  If Not (oShpVector2 Is Nothing) Then oShpVector2.Delete
                  If Not (oShpVector1_ Is Nothing) Then oShpVector1_.Delete
                  If Not (oShpVector2_ Is Nothing) Then oShpVector2_.Delete
      
                  Set oShpVector1 = .Shapes.AddLine(BeginX:=CenterShp1.X, _
                                                    BeginY:=CenterShp1.Y, _
                                                    EndX:=CenterShp1.X + (sgScale * vectorShp1.X), _
                                                    EndY:=CenterShp1.Y + (sgScale * vectorShp1.Y))
                  Call sArrow(oShpVector1, CenterShp1, vectorShp1, , sgScale)
                  Set oShpVector2 = .Shapes.AddLine(BeginX:=CenterShp2.X, _
                                                    BeginY:=CenterShp2.Y, _
                                                    EndX:=CenterShp2.X + (sgScale * vectorShp2.X), _
                                                    EndY:=CenterShp2.Y + (sgScale * vectorShp2.Y))
                  Call sArrow(oShpVector2, CenterShp2, vectorShp2, , sgScale)
                  
                  If fCollision(CenterShp1, CenterShp2, _
                                vectorShp1, vectorShp2, _
                                Ovl1R, Ovl2R, _
                                dbMassShp1, dbMassShp2, _
                                2) Then
                      'If Not (oShpVector1 Is Nothing) Then oShpVector1.Delete
                      'If Not (oShpVector2 Is Nothing) Then oShpVector2.Delete
                      'Set oShpVector1_ = .Shapes.AddLine(BeginX:=CenterShp1.X, BeginY:=CenterShp1.Y, _
                                                        EndX:=CenterShp1.X + (10*vectorShp1.X), EndY:=CenterShp1.Y + (10*vectorShp1.Y))
                      Call sArrow(oShpVector1, CenterShp1, vectorShp1, , sgScale)
                      'Set oShpVector2_ = .Shapes.AddLine(BeginX:=CenterShp2.X, BeginY:=CenterShp2.Y, _
                                                        EndX:=CenterShp2.X + (10*vectorShp2.X), EndY:=CenterShp2.Y + (10*vectorShp2.Y))
                      Call sArrow(oShpVector2, CenterShp2, vectorShp2, , sgScale)
                     
                      With Momentum_
                          .X = (dbMassShp1 * vectorShp1.X) + (dbMassShp2 * vectorShp2.X)
                          .Y = (dbMassShp1 * vectorShp1.Y) + (dbMassShp2 * vectorShp2.Y)
                      End With
                      If VBA.Abs(Momentum_.X) - VBA.Abs(Momentum.X) > 0.1 Then Stop
                      If VBA.Abs(Momentum_.Y) - VBA.Abs(Momentum.Y) > 0.1 Then Stop
      
                      EKinetic_ = (1 / 2) * (dbMassShp1 * (vectorShp1.X ^ 2 + vectorShp1.Y ^ 2) _
                                           + dbMassShp2 * (vectorShp2.X ^ 2 + vectorShp2.Y ^ 2))
                      
                      If VBA.Abs(EKinetic_ - EKinetic) > 0.1 Then Stop
                  End If
          
                  Start = VBA.Timer()
                  Do While VBA.Timer() < (Start + TimeStep) 'TimeCollision
                      DoEvents
                      If bStop Then Exit Sub
                  Loop
              Loop
          End With
      End Sub
      
      Private Sub sArrow(ByVal oShpArrow As Excel.Shape, _
                         ByRef oCenter As tXYZ, _
                         ByRef oVector As tXYZ, _
                         Optional ByVal Rotation As Single = 0, _
                         Optional ByVal sgScale As Single = 10)
          
          With oShpArrow
              '.Rotation = Rotation
              
              .Line.BeginArrowheadStyle = msoArrowheadNone
              .Line.BeginArrowheadWidth = msoArrowheadWide
              .Line.BeginArrowheadLength = msoArrowheadLong
              
              .Line.EndArrowheadStyle = msoArrowheadOpen
              .Line.EndArrowheadWidth = msoArrowheadWide
              .Line.EndArrowheadLength = msoArrowheadLong
              
              If oVector.X > 0 Then
                  '.Left = oCenter.X
                  '.Width = sgScale * oVector.X
              Else
                  '.Left = oCenter.X + oVector.X
                  '.Width = sgScale * VBA.Abs(oVector.X)
              End If
              If oVector.Y > 0 Then
                  '.Top = oCenter.Y
                  '.Height = sgScale * oVector.Y
              Else
                  '.Top = oCenter.Y + oVector.Y
                  '.Height = sgScale * VBA.Abs(oVector.Y)
              End If
              
              'If .Nodes.Count > 0 Then
                  'Dim oNode As Excel.ShapeNode
                  'With .Nodes(0)
                  '    .Points(1, 1) = 1
                  '    .Points(1, 2) = 1
                  'End With
                  'With .Nodes(1)
                  '    .Points(1, 1) = 1
                  '    .Points(1, 2) = 1
                  'End With
              'End if
          End With
      
      End Sub
      

      I’ll later post a solution for particles system on my blog.

      Kind regards

      Like

      • audeser says:

        Just for clarifying: some of the functions: fDotProduct, fVector², fVectorModule and the initial declarations (UDT…) should be borrowed from the previous post.
        Also, I would recomend to turn off the Momentum check, because is not always “compliant”…

        Like

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google+ photo

You are commenting using your Google+ account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

This site uses Akismet to reduce spam. Learn how your comment data is processed.