## VBA Gauss-Jordan implementation

VBA has no implementation for array inversion, neither equations solver. So it comes very handy a Gauss-Jordan solver:
```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
[/sourcecode]	```

## Excel physics

This post is a recopilation of functions that can be used to compute simple physics in Excel. Basically, most of the physics phenomenon deals with parabollic shoot. When considering this, one should recall on the Laws of Newton, and more specifically the 2nd one, Momentum conservation. Focussing only on collisions for a dynamic particles system, a good starting reference is this video, following this info, with code avaliable at GitHub: https://www.youtube.com/watch?v=irbshkdVFao Here the author points out the three basic problems that are not usually considered with collisions:
• excessive computations (dt too small, that’s when no collisions at fixed time increments)
• miss collisions (dt too large, that’s when space travelled at one fixed time increment is larger than the collision range for two particles)
• lack of position precission when calculating the collisions at fixed spaced moments.
More equations and explanation is given at this site. Further on, it could be brought some attention to drag resistance, and even Magnus effects, in order to refine the precission of the movements. Following is some of the Physic functions already implemented:
```Option Explicit

Private Const PI As Double = 3.14159265358979
Public Const EPSILON As Double = 0.0000001

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 Function fXYZ(Optional ByVal X As Double = 0, _
Optional ByVal Y As Double = 0, _
Optional ByVal Z As Double = 0) As tXYZ
With fXYZ
.X = X
.Y = Y
.Z = Z
End With
End Function

Public Function fVector(Optional ByVal dbModule As Double = 0, _
Optional ByVal ß As Double = 0, _
Optional ByVal Ø As Double = 0) As tXYZ
With fVector
.X = (dbModule * Cos(ß) * Cos(Ø))
.Y = (dbModule * Cos(ß) * Sin(Ø))
.Z = (dbModule * Sin(ß))
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 Function fToDouble(ByRef vVariable As Variant) As Double()
Dim lgElement As Long

If IsArray(vVariable) Then
For lgElement = LBound(vVariable) To UBound(vVariable)
Next lgElement
End If
End Function

'-------------------------------

Public Sub sShoot()
Dim aTime() As Double
Dim oPoint() As tXYZ

oPoint() = fShoot(aTime:=fToDouble(fNewVector("0:1:10)")), _
dbStrength:=10, _
ß:=45, _
Ø:=0, _
oForce:=fXYZ(0, 0, 0), _
dbGravity:=9.81, _
dbMass:=10, _
dbAreaX:=10, _
dbAreaY:=10, _
dbAreaZ:=10, _
lgShapeX:=msoShapeRectangle, _
lgShapeY:=msoShapeRectangle, _
lgShapeZ:=msoShapeRectangle)
End Sub

Public Function fShoot(ByRef aTime() As Double, _
ByVal dbStrength As Double, _
ByVal ß As Double, _
ByVal Ø As Double, _
ByRef oForce As tXYZ, _
Optional ByVal dbGravity As Double = 9.81, _
Optional ByVal dbMass As Double = 0, _
Optional ByVal dbMediaDensity As Double = 0, _
Optional ByVal dbAreaX As Double = 0, _
Optional ByVal dbAreaY As Double = 0, _
Optional ByVal dbAreaZ As Double = 0, _
Optional ByVal lgShapeX As Long = msoShapeRectangle, _
Optional ByVal lgShapeY As Long = msoShapeRectangle, _
Optional ByVal lgShapeZ As Long = msoShapeRectangle) As tXYZ()
'oForce As tXYZ
' ••••••    vector
' ¤¤¤¤¤¤    projection on XY plane
' ......    arc
' ß  arc planeXY to vector
' Ø  arc planeXZ to vector XY projection
'
'       |   •
'       |  •
'       | •.
'       |•_.______
'      / ¤ . ß
'     /....¤
'    /  Ø    ¤
'
' Initial speed components:
' Vo,x = (Vo · Cos(ß)) · Cos(Ø)
' Vo,y = (Vo · Cos(ß)) · Sin(Ø)
' Vo,z = (Vo · Sin(ß))

' Dragg = (1 / 2) · MediaDensity · Cd · Area · V²
' F = m · a --> a = F / m  //  a = dV/dt  --> dV = a · dt = (F / m) · dt

' Speeds in any instant:
' Vx = Vox - (ResistanceX · t / Mass) + (t · ForceX / Mass)
' Vy = Voy - (ResistanceY · t / Mass) + (t · ForceY / Mass)
' Vz = Voz - (ResistanceZ · t / Mass) + (t · ForceZ / Mass) - (dbGravity · t)

' Position at any instant:
' X = Vox · t - (1/2 · ResistanceX · t² / Mass) + (1/2 · t² · ForceX / Mass)
' Y = Voy · t - (1/2 · ResistanceY · t² / Mass) + (1/2 · t² · ForceY / Mass)
' Z = Voz · t - (1/2 · ResistanceZ · t² / Mass) + (1/2 · t² · ForceZ / Mass) - (1/2 · dbGravity · t²)

Dim lgTime As Long
Dim t² As Double
Dim oPoint() As tXYZ
Dim oDrag As tXYZ
Dim oVel() As tXYZ
Dim oVo As tXYZ
Dim Vo As Double
Dim Speed As Double

'!!!!!!!!!!!
Vo = dbStrength
'Speed = fVectorModule(oVel(lgTime))
'!!!!!!!!!!!

'Initial speed components:
oVo = fVector(dbStrength, ß, Ø)

'Dragg = (1 / 2) · CD · Area · V²
'F = m · a --> a = F / m  //  a = dV/dt  --> dV = a · dt = (F / m) · dt
If dbAreaX  0 Then
oDrag.X = fDrag(oVel(lgTime).X, dbMediaDensity, dbAreaX, lgShapeX)
End If
If dbAreaY  0 Then
oDrag.Y = fDrag(oVel(lgTime).Y, dbMediaDensity, dbAreaY, lgShapeY)
End If
If dbAreaZ  0 Then
oDrag.Z = fDrag(oVel(lgTime).Z, dbMediaDensity, dbAreaZ, lgShapeZ)
End If
End If

'Speeds at any instant:
ReDim oVel(LBound(aTime) To UBound(aTime))
For lgTime = LBound(aTime) To UBound(aTime)
With oVel(lgTime)
.X = oVo.X + ((oForce.X - oDrag.X) / dbMass) * aTime(lgTime)
.Y = oVo.Y + ((oForce.Y - oDrag.Y) / dbMass) * aTime(lgTime)
.Z = oVo.Z + (((oForce.Z - oDrag.Z) / dbMass) - dbGravity) * aTime(lgTime)
End With
Next lgTime

'Position at any instant:
ReDim oPoint(LBound(aTime) To UBound(aTime))
For lgTime = LBound(aTime) To UBound(aTime)
With oPoint(lgTime)
t² = aTime(lgTime) * aTime(lgTime)
.X = oVo.X * aTime(lgTime) _
+ (((oForce.X - oDrag.X) / dbMass)) * t²
.Y = oVo.Y * aTime(lgTime) _
+ (((oForce.Y - oDrag.Y) / dbMass)) * t²
.Z = oVo.Z * aTime(lgTime) _
+ (((oForce.Z - oDrag.Z) / dbMass) - dbGravity) * t²
End With
Next lgTime

fShoot = oPoint()
End Function

Public Function fDrag(Optional ByVal dbVelocity As Double = 0, _
Optional ByVal dbMediaDensity As Double = 0, _
Optional ByVal dbArea As Double = 0, _
Optional ByVal lgShape As Long = 0) As Double
' For a body following an unidirectional path, will compute the drag force opposed to movement
' Dragg = (1 / 2) · MediaDensity · Cd · Area · V²
Dim dbCd As Double

Select Case lgShape
'Case Is = msoShape...: dbCd = ...
End Select

fDrag = (1 / 2) * dbMediaDensity * dbCd * dbArea * (dbVelocity ^ 2)
End Function

Public Function fHooke() 'Optional ByVal dbStrength As Double = 0, _
Optional ByVal dbElasticity As Double = 0) As Boolean
'For any object collisioning with another one, Hooke law will have an effect on the shape of both objects
End Function

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
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())
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())
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  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

Dim Plength As Single
Dim StartAng As Single
Dim NumBalls As Long
Dim StartA(1 To 5, 1 To 4) As Single
Dim StringA As Variant
Dim BallA As Variant
Dim TimeStep As Double
Dim i As Long
Dim Step As Single
Dim Level As Double
Dim StartLevel As Double
Dim SRotn As Single
Dim Start As Double
Dim Start2 As Double
Dim NextAng As Single
Dim AngA() As Double
Dim Taccn As Double
Dim V_1 As Double
Dim V_2 As Double
Dim Vav As Double
Dim Omav As Double
Dim Period As Double
Dim NumSteps As Long

Const BallR As Single = 25
Const StringTop As Single = 100
Const StringLength As Single = 200
Const String1X As Single = 250

Const g As Double = 9.8

Plength = Range("Plength").Value / 1000
StartAng = Range("StartAngle").Value * PI / 180
NumBalls = Range("NumNC").Value
StartLevel = StringLength / 10 * (1 - Cos(StartAng))

Period = 2 * PI * (Plength / g) ^ 0.5 * (1 + Sin(StartAng / 2) ^ 2 / 4 + Sin(StartAng / 2) ^ 4 * 9 / 64)
Range("period").Value = Period
NumSteps = Period / 0.05
TimeStep = Period / NumSteps
ReDim AngA(0 To NumSteps, 1 To 3)

AngA(0, 3) = -g * (Sin(StartAng))
AngA(0, 2) = TimeStep * AngA(0, 3) / 2
AngA(0, 1) = StartAng + AngA(0, 2) * TimeStep

For i = 1 To NumSteps
Taccn = -g * (Sin(AngA((i - 1), 1)))
AngA(i, 3) = Taccn
V_1 = AngA(i - 1, 2)
V_2 = V_1 + TimeStep * (Taccn * 1.5 - AngA((i - 1), 3) / 2)
AngA(i, 2) = V_2
Vav = (V_1 + V_2) / 2
Omav = Vav / Plength
AngA(i, 1) = AngA(i - 1, 1) + Omav * TimeStep
Next i

StringA = Array("NcLine1", "NcLine2", "NcLine3", "NcLine4", "NcLine5")

Do
NextAng = StartAng
For Step = 1 To NumSteps
Start = Timer
For i = 1 To 5
StartA(i, 1) = String1X + (i - 1) * 2 * BallR
StartA(i, 2) = StringTop
If ((Step  NumSteps * 3 / 4) And i  NumSteps / 4 And Step  NumBalls) Then
SRotn = 0
StartA(i, 3) = StartA(i, 1)
StartA(i, 4) = StartA(i, 2) + StringLength
Else
SRotn = NextAng
StartA(i, 3) = StartA(i, 1) + StringLength * Sin(SRotn)
StartA(i, 4) = StartA(i, 2) + StringLength * Cos(SRotn)

End If

ActiveSheet.Shapes(StringA(i - 1)).Delete
With ActiveSheet.Shapes.AddLine(StartA(i, 1), StartA(i, 2), StartA(i, 3), StartA(i, 4))
.Name = StringA(i - 1)
.Line.Weight = 2
End With

With ActiveSheet.Shapes(BallA(i - 1))
.Left = StartA(i, 3) - BallR
.Top = StartA(i, 4) - BallR
.Width = BallR * 2
.Height = .Width
End With
Next i

If Step = Round(NumSteps / 4, 0) + 1 Or Step = Round(NumSteps * 3 / 4, 0) + 1 Then Beep

NextAng = AngA(Step, 1)
Level = StringLength / 10 * (1 - Cos(NextAng))

Do While Timer < Start + TimeStep
DoEvents
Loop
Next Step
Loop
End Sub
```

## VBA array functions (MatLabish/Pythonish implementation)

Nor VBA nor Visual Basic have natively implemented most of the array functions that Python or MatLab (https://www.mathworks.com/help/matlab/functionlist.html) have. But they can be coded to get similar functionality. Following are a bunch of functions (code not finished, or even not just started -for those that have a ‘!!!!! at the beginning of the description-), just to get fast creation and operation over matrices in VBA. Note: This is a work on progress, so it’ll grow in the future with new functions.
```Option Explicit
'!!!!!!!!!!!!!!!!!!!
Public Const g_Base As Long = 0
'!!!!!!!!!!!!!!!!!!!
Public Function fNewArray(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Variant
'To reference all the elements in the mth row we type A(:m,).
'To reference all the elements in the nth column we type A(:,n).
'To reference all the elements in the mth to nth column we type A(:,m:n).
'To reference all the elements in the mth to nth row we type A(m:n,:).
'ToDo --> a([2,3,2,3],:)
'--> Row Vector []
'--> Column vector {}
Dim mArray As Variant

'Dim lgDim As Long
Dim lgElement As Long
Dim lgElements As Long
'strEnclosing As String = "[]"
Dim aVector() As String
Dim aElement() As String
Dim lgVector As Long
Dim strVector As String
Dim aCreator() As String

strText = VBA.Trim\$(strText)
'Join lines...
strText = VBA.Replace(strText, vbNewLine, "")
strText = VBA.Replace(strText, strNewLine, "")

aCreator() = VBA.Split(strText, ":")
If LBound(aCreator)  UBound(aCreator) Then
' array = [first : second : ... : last]
If (2 = (UBound(aCreator) - LBound(aCreator) + 1)) Then
ReDim mArray(g_Base + 0 To g_Base + aCreator()(LBound(aCreator)), _
g_Base + 0 To g_Base + aCreator()(UBound(aCreator)))
ElseIf (3 = (UBound(aCreator) - LBound(aCreator) + 1)) Then
ReDim mArray(g_Base + 0 To g_Base + aCreator()(LBound(aCreator) + 0) - 1, _
g_Base + 0 To g_Base + aCreator()(LBound(aCreator) + 1) - 1, _
g_Base + 0 To g_Base + aCreator()(UBound(aCreator)) - 1)
End If

Else
If strText Like "[[]*" Then
'--> Row Vector []
If strText Like "*]" Then
strText = VBA.Mid\$(strText, 2, VBA.Len(strText) - 2)
strText = VBA.Trim\$(strText)

'Get vectors
aVector = VBA.Split(strText, strRowSeparator)
strVector = VBA.Trim\$(aVector()(LBound(aVector)))

'Avoid repeated separators
Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
Loop
aElement = VBA.Split(strVector, strColSeparator)
ReDim mArray(g_Base + LBound(aVector) To g_Base + UBound(aVector), _
g_Base + LBound(aElement) To g_Base + UBound(aElement))

For lgVector = LBound(aVector) To UBound(aVector)
strVector = VBA.Trim\$(aVector(lgVector))

'Avoid repeated separators
Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
Loop
aElement = VBA.Split(strVector, strColSeparator)
For lgElement = LBound(aElement) To UBound(aElement)
mArray(g_Base + lgVector, g_Base + lgElement) = VBA.Val(aElement(lgElement))
Next lgElement
Next lgVector
End If

ElseIf strText Like "{*" Then
'--> Column vector {}
If strText Like "*}" Then
strText = VBA.Mid\$(strText, 2, VBA.Len(strText) - 1)

'Join lines...
strText = VBA.Replace(strText, strNewLine, "")

'Get Columns
aVector = VBA.Split(strText, strColSeparator)
strVector = VBA.Trim\$(aVector()(LBound(aVector)))

'Avoid repeated separators
Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
Loop
aElement = VBA.Split(strVector, strRowSeparator)
ReDim mArray(g_Base + LBound(aElement) To g_Base + UBound(aElement), _
g_Base + LBound(aVector) To g_Base + UBound(aVector))

For lgVector = LBound(aVector) To UBound(aVector)
strVector = VBA.Trim\$(aVector(lgVector))

'Avoid repeated separators
Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
Loop
aElement = VBA.Split(strVector, strRowSeparator)
For lgElement = LBound(aElement) To UBound(aElement)
mArray(g_Base + lgVector, g_Base + lgElement) = VBA.Val(aElement(lgElement))
Next lgElement
Next lgVector
End If
End If
End If

fNewArray = mArray
Erase aCreator()
End Function

Public Function fNewArrayStr(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As String()
Dim vArray As Variant
Dim aStr() As String
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aStr(lgR, lgC) = VBA.CStr(vArray(lgR, lgC))
Next lgC
Next lgR
fNewArrayStr = aStr()

Erase aStr()
End If
Erase vArray
End Function
Public Function fNewArrayDbl(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Double()
Dim vArray As Variant
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
Next lgC
Next lgR

End If
Erase vArray
End Function
Public Function fNewArraySng(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Single()
Dim vArray As Variant
Dim aSng() As Single
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aSng(lgR, lgC) = VBA.CSng(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
fNewArraySng = aSng()

Erase aSng()
End If
Erase vArray
End Function
Public Function fNewArrayLng(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Long()
Dim vArray As Variant
Dim aLng() As Long
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aLng(lgR, lgC) = VBA.CLng(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
fNewArrayLng = aLng()

Erase aLng()
End If
Erase vArray
End Function
Public Function fNewArrayInt(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Integer()
Dim vArray As Variant
Dim aInt() As Integer
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aInt(lgR, lgC) = VBA.CInt(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
fNewArrayInt = aInt()

Erase aInt()
End If
Erase vArray
End Function
Public Function fNewArrayBool(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Boolean()
Dim vArray As Variant
Dim aBool() As Boolean
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aBool(lgR, lgC) = VBA.CBool(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
fNewArrayBool = aBool()

Erase aBool()
End If
Erase vArray
End Function
Public Function fNewArrayByte(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Byte()
Dim vArray As Variant
Dim aByte() As Byte
Dim lgC As Long
Dim lgR As Long

vArray = fNewArray(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aByte(lgR, lgC) = VBA.CByte(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
fNewArrayByte = aByte()

Erase aByte()
End If
Erase vArray
End Function

Public Function fNewVector(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Variant
' vector = [first : step : last]
' To create a vector v with the first element f, last element l, and the difference between elements is any real number n
Dim mVector As Variant

Dim aCreator() As String
Dim aElement() As String
Dim dbFirst As Double
Dim dbLast As Double
Dim dbStep As Double
Dim lgElement As Long
Dim lgElements As Long
Dim lgStep As Long
Dim strVector As String

strText = VBA.Trim\$(strText)

aCreator() = VBA.Split(strText, ":")
If LBound(aCreator)  UBound(aCreator) Then
dbFirst = VBA.Val(aCreator()(LBound(aCreator) + 0))
dbLast = VBA.Val(aCreator()(LBound(aCreator) + 2))
dbStep = VBA.Val(aCreator()(LBound(aCreator) + 1))
If dbStep = 0 Then dbStep = 1
lgElements = VBA.CLng((dbLast - dbFirst) / dbStep)
ReDim mVector(g_Base + 0 To g_Base + lgElements - 1)
lgStep = 0
For lgElement = LBound(mVector) To UBound(mVector)
mVector(lgElement) = dbFirst + (lgStep * dbStep)
lgStep = lgStep + 1
Next lgElement
If mVector(UBound(mVector))  dbLast Then
ReDim Preserve mVector(LBound(mVector) To UBound(mVector) + 1)
mVector(UBound(mVector)) = dbLast
End If
fNewVector = mVector

Else
'Join lines...
strText = VBA.Replace(strText, strNewLine, "")

If VBA.InStr(1, strText, strRowSeparator) = 0 Then
'row vector
'Avoid repeated separators
Do While VBA.InStr(1, strVector, (strColSeparator & strColSeparator)) > 0
strVector = VBA.Replace(strVector, strColSeparator & strColSeparator, strColSeparator)
Loop

aElement() = VBA.Split(strText, strColSeparator)

ReDim mVector(g_Base + LBound(aElement) To g_Base + UBound(aElement))
For lgElement = LBound(aElement) To UBound(aElement)
mVector(lgElement) = VBA.Val(aElement(lgElement))
Next lgElement

Else
'column vector
'Avoid repeated separators... not likelly on column vectors
'Do While VBA.InStr(1, strVector, (strRowSeparator & strRowSeparator)) > 0
'    strVector = VBA.Replace(strVector, strRowSeparator & strRowSeparator, strRowSeparator)
'Loop

aElement() = VBA.Split(strText, strRowSeparator)

ReDim mVector(g_Base + LBound(aElement) To g_Base + UBound(aElement), g_Base)
For lgElement = LBound(aElement) To UBound(aElement)
mVector(lgElement, g_Base) = VBA.Val(aElement(lgElement))
Next lgElement
End If

fNewVector = mVector
End If
End Function
Public Function fNewVectorStr(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As String()
Dim vArray As Variant
Dim aStr() As String
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aStr(lgR) = VBA.CStr(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aStr(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aStr(lgR, lgC) = VBA.CStr(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorStr = aStr()

Erase aStr()
End If
Erase vArray
End Function
Public Function fNewVectorDbl(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Double()
Dim vArray As Variant
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aDbl(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
Next lgC
Next lgR
End If

End If
Erase vArray
End Function
Public Function fNewVectorSng(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Single()
Dim vArray As Variant
Dim aSng() As Single
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aSng(lgR) = VBA.CSng(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aSng(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aSng(lgR, lgC) = VBA.CSng(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorSng = aSng()

Erase aSng()
End If
Erase vArray
End Function
Public Function fNewVectorLng(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Long()
Dim vArray As Variant
Dim aLng() As Long
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aLng(lgR) = VBA.CLng(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aLng(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aLng(lgR, lgC) = VBA.CLng(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorLng = aLng()

Erase aLng()
End If
Erase vArray
End Function
Public Function fNewVectorInt(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Integer()
Dim vArray As Variant
Dim aInt() As Integer
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aInt(lgR) = VBA.CInt(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aInt(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aInt(lgR, lgC) = VBA.CInt(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorInt = aInt()

Erase aInt()
End If
Erase vArray
End Function
Public Function fNewVectorBool(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Boolean()
Dim vArray As Variant
Dim aBool() As Boolean
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aBool(lgR) = VBA.CBool(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aBool(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aBool(lgR, lgC) = VBA.CBool(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorBool = aBool()

Erase aBool()
End If
Erase vArray
End Function
Public Function fNewVectorByte(ByVal strText As String, _
Optional ByVal strColSeparator As String = " ", _
Optional ByVal strRowSeparator As String = ";", _
Optional ByVal strNewLine As String = "\") As Byte()
Dim vArray As Variant
Dim aByte() As Byte
Dim lgC As Long
Dim lgR As Long

vArray = fNewVector(strText, strColSeparator, strRowSeparator, strNewLine)
If IsArray(vArray) Then
If fNdims(vArray) = 1 Then
ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
aByte(lgR) = VBA.CByte(VBA.Val(vArray(lgR)))
Next lgR

ElseIf fNdims(vArray) = 2 Then
ReDim aByte(LBound(vArray, 1) To UBound(vArray, 1), _
LBound(vArray, 2) To UBound(vArray, 2))
For lgR = LBound(vArray, 1) To UBound(vArray, 1)
For lgC = LBound(vArray, 2) To UBound(vArray, 2)
aByte(lgR, lgC) = VBA.CByte(VBA.Val(vArray(lgR, lgC)))
Next lgC
Next lgR
End If
fNewVectorByte = aByte()

Erase aByte()
End If
Erase vArray
End Function

Public Function fLength(ByRef mArray As Variant) As Long
' length     Length of vector or largest array dimension
Dim nDim As Long
Dim lgDim As Long

If IsArray(mArray) Then
On Error GoTo ExitProc
lgDim = 0
Do
lgDim = lgDim + 1
If nDim  0)
Loop
End If

ExitProc:
On Error GoTo 0
fNdims = (lgDim - 1)
End Function

Public Function fNumEl(ByRef mArray As Variant) As Long
' numel      Number of array elements
Dim lgDim As Long
Dim lgElements As Long

If IsArray(mArray) Then
On Error GoTo ExitProc
lgDim = 0
Do
lgDim = lgDim + 1
lgElements = lgElements * (UBound(mArray, lgDim) - LBound(mArray, lgDim) + 1)
Loop
End If

ExitProc:
On Error GoTo 0
fNumEl = lgElements
End Function

Public Function IsColumn(ByRef mArray As Variant) As Boolean
' iscolumn   Determines whether input is column vector
If IsArray(mArray) Then
IsColumn = (UBound(mArray, 2) - LBound(mArray, 2) = 1)
End If
End Function

'Public Function IsEmpty(ByRef mArray As Variant) As Boolean
'' isempty    Determines whether array is empty
'    If IsArray(mArray) Then
'        'IsEmpty = True
'    End If
'End Function
'Public Function IsMatrix(ByRef mArray As Variant) As Boolean
'' ismatrix   Determines whether input is matrix
'    If IsArray(mArray) Then
'        'IsMatrix = True
'    End If
'End Function

Public Function IsRow(ByRef mArray As Variant) As Boolean
' isrow      Determines whether input is row vector
If IsArray(mArray) Then
IsRow = (UBound(mArray, 1) - LBound(mArray, 1) = 1)
End If
End Function

Public Function IsScalar(ByRef mArray As Variant) As Boolean
' isscalar   Determines whether input is scalar
If IsArray(mArray) Then
IsScalar = (Not IsArray(mArray))
End If
End Function

Public Function IsVector(ByRef mArray As Variant) As Boolean
' isvector   Determines whether input is vector
If IsArray(mArray) Then
IsVector = (UBound(mArray, 1) = LBound(mArray, 1)) Or (UBound(mArray, 2) = LBound(mArray, 2))
End If
End Function

Public Function fBlkDiag(ByVal mDiagonal As Variant, _
Optional ByVal lgDiagonal As Long = 0) As Variant
' blkdiag    Constructs block diagonal matrix from input arguments
'            placing the elements of vector mDiagonal on the lgDiagonal_th diagonal.
'     lgDiagonal=0 represents the main diagonal
'     lgDiagonal>0 is above the main diagonal
'     lgDiagonal<0 is below the main diagonal
Dim mArray As Variant
Dim lgElement As Long

If IsArray(mDiagonal) Then
ReDim mArray(LBound(mDiagonal) To UBound(mDiagonal), LBound(mDiagonal) To UBound(mDiagonal))
If lgDiagonal = 0 Then
For lgElement = LBound(mDiagonal) To UBound(mDiagonal)
mArray(lgElement, lgElement) = mDiagonal(lgElement)
Next lgElement
ElseIf lgDiagonal  0 Then
For lgElement = LBound(mDiagonal) To UBound(mDiagonal)
mArray(lgElement, lgElement + lgDiagonal) = mDiagonal(lgElement)
Next lgElement
End If
fBlkDiag = mArray
End If
End Function

Public Function fCircShift(ByRef mArray As Variant, _
ByVal mShifter As Variant, _
Optional ByVal dimCirculate As Long = 0) As Boolean
' circshift  Shifts array circularly
' Y = circshift(A,K) circularly shifts the elements in array A by K positions.
' If K is an integer, then circshift shifts along the first dimension of A whose size does not equal 1.
' If K is a vector of integers, then each element of K indicates the shift amount in the corresponding dimension of A.
Dim lgR As Long
Dim lgC As Long
Dim lgShift As Long
Dim mArrayTmp As Variant

If IsArray(mArray) Then
If dimCirculate = 0 Then
'Copy array
mArrayTmp = mArray

If IsArray(mShifter) Then
For lgR = LBound(mArray, 1) To UBound(mArray, 1)
If lgR - mShifter(g_Base + 0)  dbThreshold, mArray(lgR, lgC), dbThreshold)
Next lgC
Next lgR

fThreshold = mThreshold
End If
End Function

Public Function fRound(ByVal mArray As Variant, _
Optional ByVal lgDigits As Long = 0) As Variant
Dim lgR As Long
Dim lgC As Long
Dim mRound As Variant

If IsArray(mArray) Then
ReDim mThreshold(LBound(mArray, 1) To UBound(mArray, 1), LBound(mArray, 2) To UBound(mArray, 2))
For lgR = LBound(mArray, 1) To UBound(mArray, 1)
For lgC = LBound(mArray, 2) To UBound(mArray, 2)
mRound(lgR, lgC) = VBA.Round(mArray(lgR, lgC), lgDigits)
Next lgC
Next lgR
fRound = mRound
End If
End Function

Public Function fMagnitude(ByVal mArray As Variant, _
Optional ByVal lgOrder As Long = 2) As Double
Dim lgR As Long
Dim lgC As Long
Dim dbMagnitude As Long

If IsArray(mArray) Then
For lgR = LBound(mArray, 1) To UBound(mArray, 1)
For lgC = LBound(mArray, 2) To UBound(mArray, 2)
dbMagnitude = (mArray(lgR, lgC) * mArray(lgR, lgC))
Next lgC
Next lgR
If lgOrder = 2 Then
fMagnitude = VBA.Sqr(dbMagnitude)
Else
fMagnitude = dbMagnitude ^ (1 / lgOrder)
End If
End If
End Function
```
Also, the Gauss-Jordan reduction method is coded as:
```Option Explicit

Dim mArray() As Double

Private Sub UserForm_Initialize()
'call sSolve
End Sub

Private Sub cbSolve_Click()
Call sSolve
End Sub

Private Sub sSolve()
Call sGaussJordan(mArray())
End Sub

On Error GoTo ErrLec

Dim lgR As Long
Dim lgC As Long
Dim lgRetVal As Long
Dim Nm As Long

If VarType(Selection) = vbObject Then
mArray() = fNewArrayDbl(Me.txtSystem.Text, " ", ";", "\")
Me.sbNum.Value = UBound(mArray, 1) - LBound(mArray, 1) + 1
Nm = Me.sbNum.Value
Else
If Selection.Rows.Count > 1 And _
Selection.Rows.Count > 1 Then
Me.sbNum.Value = Selection.Rows.Count
Nm = Me.sbNum.Value

ReDim mArray(g_Base To (Nm - 1 + g_Base), g_Base To Nm + g_Base)
For lgR = g_Base To Nm - 1 + g_Base
For lgC = g_Base To Nm + g_Base
'If Cuadric.TextMatrix(lgR + 1, lgC) = "" Then Cuadric.TextMatrix(lgR + 1, lgC) = 0
'mArray(lgR, lgC) = Cuadric.TextMatrix(lgR + 1, lgC)
mArray(lgR, lgC) = Selection.Cells(lgR + 1, lgC + 1).Value2
Next
Next
Else
mArray() = fNewArrayDbl(Me.txtSystem.Text, " ", ";", "\")
Me.sbNum.Value = UBound(mArray, 1) - LBound(mArray, 1) + 1
Nm = Me.sbNum.Value
End If
End If

ExitProc:
Exit Sub

ErrLec:
lgRetVal = VBA.MsgBox("Error introducing data (" & Err.Description & ")", vbExclamation)
End Sub

Private Sub sbNum_Change()
txtEquations.Value = VBA.Str(sbNum.Value)
End Sub

Public Sub sGaussJordan(ByRef mArray() As Double)
'Based on code found: http://mvb6.blogspot.com/2017/08/metodo-de-gauss-jordan-vb-60.html
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 Es
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
Es:
Next lgR
Next lgPivot

'Print solution
For lgR = LBound(mArray, 1) To UBound(mArray, 1)
Debug.Print mArray(lgR, Nm) 'vba.Format(mArray(lgR, Nm), "##,##0.00")
Next lgR

ExitProc:
Exit Sub

ErrControl:
lgRetVal = VBA.MsgBox("System has no solution", vbCritical)
End Sub
```
Future implementations will be, for example, then capability to handle complex numbers, via the UDT tObject, with little to no change in the code (only replacing “) As Variant” with “) As tObject()” and ” As Variant” with “() As tObject”. Even NaN, NaT, Inf,… MatLab special reserved variables can be used along the code, setting TypeObj to 0 and giving .Text property the name of the reserved variable. This will be a possible group implementation to handle complex numbers inside VBA
```Option Explicit

Public Enum eTypeObj
eText = 0
eNatural = 2
eReal = 1
eComplex = -1
End Enum
Public Type tObject
Size As Long 'Total bytes

TypeObj As Long
'Text = 0
'[R]Real = 1, [C]Complex = -1
'[Z]Natural (Integers ±) = 2

R As Double 'Real part
I As Double 'Imaginary part

Text As String
'Name As String * 10
End Type

Public Function fNew(Optional ByVal TypeObj As Long = 0, _
Optional ByVal R As Double = 0, _
Optional ByVal c As Double = 0, _
Optional ByVal Text As String = "") As tObject
'Set new object
With fNew
.Size = 20 + Len(Text)
.TypeObj = TypeObj '[Z]Natural = 2, [R]Real = 1, [C]Complex = -1, Text = 0

.R = R
.I = c

.Text = Text
End With
End Function
Public Function fComplex(ByRef dbReal As Double, _
ByRef dbImaginary As Double) As tObject
' complex   Create complex array
fComplex = fNew(eComplex, dbReal, dbImaginary, "")
End Function
Public Function fAbs(ByRef oObject As tObject) As Double
' abs       Absolute value and complex magnitude
With oObject
If .TypeObj > 0 Then
fAbs = VBA.Abs(.R)
ElseIf .TypeObj = eComplex Then
fAbs = VBA.Sqr(.R ^ 2 + .I ^ 2)
End If
End With
End Function
Public Function fAngle(ByRef oObject As tObject) As Double
' angle     Phase angle
With oObject
If VBA.Abs(.R)  0 Then
fSignObj = fSign(oObject.R)
ElseIf .TypeObj = eComplex Then
fSignObj = fSign(oObject.R)
End If
End With
End Function
Public Function fUnwrap(ByRef oObject1 As tObject, _
ByRef oObject2 As tObject) As Double
' unwrap    Correct phase angles to produce smoother phase plots
'!!!!!
End Function
Public Function fReal(ByRef oObject As tObject) As Double
' real      Real part of complex number
If oObject.TypeObj = eComplex Then fReal = oObject.R
End Function
Public Function fImag(ByRef oObject As tObject) As Double
' imag      Imaginary part of complex number
If oObject.TypeObj = eComplex Then fImag = oObject.I
End Function

Public Function fComplexSum(ByRef oObject1 As tObject, _
ByRef oObject2 As tObject) As tObject
If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
With fComplexSum
.R = oObject1.R + oObject2.R
If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
.TypeObj = eComplex
.I = oObject1.I + oObject2.I
Else
.TypeObj = eReal
End If
End With
End If
End Function

Public Function fComplexDiff(ByRef oObject1 As tObject, _
ByRef oObject2 As tObject) As tObject
If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
With fComplexDiff
.R = oObject1.R - oObject2.R
If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
.TypeObj = eComplex
.I = oObject1.I - oObject2.I
Else
.TypeObj = eReal
End If
End With
End If
End Function

Public Function fComplexMult(ByRef oObject1 As tObject, _
ByRef oObject2 As tObject) As tObject
' z1·z2 = (a, b)·(c, d) = (a·c - b·d), (a·d - b·c)
If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
With fComplexMult
.R = oObject1.R * oObject2.R 'only the real part
If (oObject1.TypeObj = eComplex Or oObject2.TypeObj = eComplex) Then
.TypeObj = eComplex
.I = oObject1.R * oObject2.I + oObject1.I * oObject2.R
.R = .R - oObject1.I * oObject2.I
Else
.TypeObj = eReal
End If
End With
End If
End Function

Public Function fComplexRec(ByRef oObject As tObject) As tObject
' 1/z = 1/(a, b) = (a, -b)/(a²+b²)
Dim oReciproc As tObject
Dim dbModule² As Double

With oObject
If .TypeObj = eComplex Then
dbModule² = (.R ^ 2 + .I ^ 2)
With fComplexRec
.TypeObj = oObject.TypeObj
.R = oObject.R / dbModule²
.I = -oObject.I / dbModule²
End With

ElseIf .TypeObj = eReal Then
With fComplexRec
.TypeObj = oObject.TypeObj
.R = oObject.R
End With
End If
End With
End Function

Private Sub sComplexDiv()
Dim oObject1 As tObject
Dim oObject2 As tObject
Dim oObject As tObject
With oObject1
.TypeObj = eComplex
.R = 4
.I = 3
End With
With oObject2
.TypeObj = eComplex
.R = 2
.I = 1
End With
oObject = fComplexDiv(oObject1, oObject2)
Stop
End Sub

Public Function fComplexDiv(ByRef oObject1 As tObject, _
ByRef oObject2 As tObject) As tObject
' z1/z2 = (a, b)·[(c, d)/(c²+d²)] = (ac+bd , cb-da)/(c²+d²)
'Dim oComplexRec As tObject
Dim dbModule² As Double

If (VBA.Abs(oObject1.TypeObj) = eReal Or VBA.Abs(oObject2.TypeObj) = eReal) Then
With fComplexDiv
If (oObject2.TypeObj = eComplex) Then
dbModule² = (oObject2.R ^ 2 + oObject2.I ^ 2)
.TypeObj = eComplex
'oComplexRec = fComplexRec(oObject2)
.R = (oObject1.R * oObject2.R + oObject1.I * oObject2.I) / dbModule²
.I = (oObject1.I * oObject2.R - oObject1.R * oObject2.I) / dbModule²

Else
.TypeObj = eReal
.R = oObject1.R / oObject2.R
.I = oObject1.R / oObject2.R
End If
End With
End If
End Function

Public Function fConj(ByRef oObject As tObject) As tObject
' conj      Complex conjugate
With fConj
If .TypeObj = eComplex Then
.TypeObj = oObject.TypeObj
.R = oObject.R
.I = -oObject.I

ElseIf .TypeObj = eReal Then
.TypeObj = oObject.TypeObj
.R = oObject.R
End If
End With
End Function
```

### Library bindings

```Private oCadApp As Object 'AutoCAD.AutoCADApplication or BricscadApp.AcadApplication
```

To draw inside CAD application through VBA we need to link the CAD application instante and the CAD drawing document, in order to do it programmatically use following code:
```Private oCadApp As Object 'AutoCAD.AutoCADApplication or BricscadApp.AcadApplication

Optional ByRef strFullPath_File As String = vbNullString) As Boolean

'Check if AutoCAD application is open. If not, create a new instance and make it visible.
On Error Resume Next
' or also:
'If Err.Description > vbNullString Then
'    Err.Clear
End If

'Check if there is an AutoCAD object.
End If
On Error GoTo 0

'Check if there is an active drawing. If no active drawing is found, create a new one.
On Error Resume Next
'strFullPath_File = VBA.Environ("UserProfile") & "\Documents\Doc.dxf"
End If
On Error GoTo 0

'Check if the active space is paper space and change it to model space.
If .ActiveSpace = 0 Then '0 = acPaperSpace in early binding
.ActiveSpace = 1      '1 = acModelSpace in early binding
End If
End With

ExitProc:
On Error GoTo 0
Exit Function
End Function
```
Remember that the CAD object is open, to close it programmatically, use following code:
```Public Function fCloseCAD(Optional ByVal strFullPathFile_CAD As String = vbNullString)
End If

End Function
```

### Drawing in CAD data from Excel

If we want to draw some entities, we can use something like these codes, derived from theSwamp.org, and Christos Samaras’s (My Engineering World) posts 1 (to draw a 2D polyline) and 2 (to draw a 3D polyline with a extruded section). Modify to your convenience.
```Public Sub DrawText()
Dim strFullPath_File As String

Dim Height As Double
Dim P(0 To 2) As Double
Dim TxtStr As String

Height = 1
P(0) = 1: P(1) = 1: P(2) = 0
TxtStr = Cells(1, 1)

End Sub

Public Sub sDrawPolyline()
'Draws a polyline in AutoCAD using X and Y coordinates from sheet Coordinates.

'Declaring the necessary variables.
Dim dblCoordinates() As Double
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim k As Long

Dim wsData As Excel.Worksheet
Dim rgData As Excel.Range

' Get data
'Set rgData = Application.InputBox(Prompt:="Select range of points", _
Title:="Select data", _
Type:=8)

Set wsData = rgData.Parent 'ActiveSheet
With wsData
.Activate

'Find the last row.
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

'Check if there are at least two points.
If LastRow < 3 Then
MsgBox "There not enough points to draw the polyline!", vbCritical, "Points Error"
Exit Sub
End If

'Get the array size.
ReDim dblCoordinates(2 * (LastRow - 1) - 1)

'Pass the coordinates to array.
k = 0
For i = 2 To LastRow
For j = 1 To 2
dblCoordinates(k) = .Cells(i, j)
k = k + 1
Next j
Next i
End With

' Get CAD app and Doc

'Draw the polyline either at model space or at paper space.
'Else
'End If

'Leave the polyline open (the last point is not connected with the first point).
'Set the next line to true if you need to connect the last point with the first one.

'Zooming in to the drawing area.

'Inform the user that the polyline was created.
MsgBox "The polyline was successfully created!", vbInformation, "Finished"

End Sub

Public Sub sDraw3DPolyline()
' Draws a 3D polyline in AutoCAD using X, Y and Z coordinates from the sheet Coordinates.
' If the user enter a radius value the code transforms the 3D polyline to a pipe-like solid, using
' the AddExtrudedSolidAlongPath method. In this way you can draw a pipeline directly from Excel!

' Remarks: You can extrude only 2D planar regions.
' The path should not lie on the same plane as the profile, nor should it have areas of high curvature.

' Although the available path objects not include the 3D polyline, we can use this object,
' but taking into account the fact that both Profile and Path objects must not lie on the same plane. We can overcome this limitation with a simple trick:
' we rotate the Profile object!
' So, in the particular case, we rotate the circle 45 degrees over the y axis,
' in order the circle plane to be different than the 3D polyline plane(s).
' Moreover, we apply the Move method in order to move the 3D "solid" polyline back to its original position
'(since the AddExtrudedSolidAlongPath method will start drawing the 3D “solid” polyline at profile's coordinates - usually at (0,0,0)).

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Can also be achieved with the SWEEP command/method over an SCR phrase
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

' Declaring the necessary variables.
Dim oCircle(0 To 0)         As Object 'BricscadApp.Circle

Dim LastRow                 As Long
Dim dblCoordinates()        As Double
Dim i                       As Long
Dim j                       As Long
Dim k                       As Long
Dim CircleCenter(0 To 2)    As Double
Dim RotPoint1(2)            As Double
Dim RotPoint2(2)            As Double
Dim Regions                 As Variant
Dim FinalPosition(0 To 2)   As Double

Dim lgRetVal                As Long

Dim wsData As Excel.Worksheet
Dim rgCoordinates           As Excel.Range

' Get coordinates data
'Set rgCoordinates = Application.InputBox(Prompt:="Select range of points", _
Title:="Select data", _
Type:=8)

Set wsData = rgCoordinates.Parent 'ActiveSheet
With wsData
.Activate

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

'Check if there are at least two points.
If LastRow  0 Then
' Set the circle center at the (0,0,0) point.
CircleCenter(0) = 0: CircleCenter(1) = 0: CircleCenter(2) = 0

' Draw the circle.

' Initialize the rotational axis.
RotPoint1(0) = 0: RotPoint1(1) = 0: RotPoint1(2) = 0
RotPoint2(0) = 0: RotPoint2(1) = 10: RotPoint2(2) = 0

' Rotate the circle in order to avoid errors with AddExtrudedSolidAlongPath method.
oCircle(0).Rotate3D RotPoint1, RotPoint2, 0.785398163 '45 degrees

' Create a region from the circle.

' Create the "solid polyline".

' Set the position where the solid should be transfered after its design (its original position).
With Sheets("Coordinates")
FinalPosition(0) = .Range("A2").Value
FinalPosition(1) = .Range("B2").Value
FinalPosition(2) = .Range("C2").Value
End With

' Move the solid to its final position.
oSolidPol.Move CircleCenter, FinalPosition

' Delete the circle.
oCircle(0).Delete

' Delete the region.
Regions(0).Delete

' If the "solid polyline" was created successfully delete the initial polyline.
If Err.Number = 0 Then
End If
End If

' Zooming in to the drawing area.