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
Newton Excel Bach, not (just) an Excel Blog 
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
LikeLike
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
LikeLike
If you’d like to send sample worksheet and code, please send to Dougaj4 at gmail.
Thanks
LikeLike
Thanks for the code and the links. I’ll reply properly later, but it looks like the end of your message got truncated.
LikeLiked by 1 person
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 SubSeems 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
LikeLike
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.
LikeLike
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.
LikeLike
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 SubI’ll later post a solution for particles system on my blog.
Kind regards
LikeLike
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”…
LikeLike