Blog

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:

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

For library binding to ActiveX objects from AutoCAD (or equivalent software), we can follow these posts on StackOverflow and theSwamp.org, that gives us the references for AutoCAD application. For every software, and for each every version, there will be a different GUI code, so take care.

‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

Another ‘better’ option is to go with ‘Late binding’ (instead of ‘Early binding’ that needs the references to be set in the VBA project). It’s no so clear and get developers far away from IntellySense, but knowing the objects, methods and properties, you can manage. It has the tremendous advantage that there is no need for the software version user has installed on his/her computer to be the same as in the developer’s (of course, they must have the same CAD software…).

These are late binding declarations for the two common objects (oCADApp and oCADDoc).

```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.
' Release the objects.
Set oCircle(0) = Nothing
Set oSolidPol = Nothing
' Inform the user that the 3D polyline was created.
lgRetVal = MsgBox("The 3D polyline was successfully created in AutoCAD!", vbInformation, "Finished")
End Sub
[/sourcecode]
```

Excel Games

I’ve been wondering if video games (RPG mainly) could be developed under Excel+VBA. It’s cristal clear that Excel by itself can be turned into a time consuming machine. For this task, simple games were developed by Andrew Engwirda, and even the Excel gurus Chip Pearson and Andy Pope have posts on games. Also, a fun version […]

I’ve been wondering if video games (RPG mainly) could be developed under Excel+VBA.

When open Excel looks like a plain table, nothing that can resemble a dynamic environment. That is a fairly untrue statement. Even from the first MsOffice version, it has embebded easter-eggs full of motion.

Aside from easter-eggs, that are specifically coded inside Office, with a little help of imagination cells, formulas, charts and shapes can be turned into objects that do not behave as static ones.

It’s cristal clear that Excel by itself can be turned into a time consuming machine. For this task, simple games were developed by Andrew Engwirda, and even the Excel gurus Chip Pearson and Andy Pope have posts on games. Also, a fun version of Mine Sweeper can be downloaded at the great https://www.vertex42.com/ExcelArticles/fun-with-excel.html. But it seems these examples had no real intention to be more than table games, like the Sudokus, Chess, Monopoly and a myriad of things like that. Even a more evolved, as The game of life, is kind of obvious to be rightly implemented into Excel, as they are mostly “table formated”. There are a lot of samples of this kind on Keko’s site, on ExcelGame’s site, and on DzikoSoft.

For more complex creations, and one that really have perplexed myself since long time ago, are that from George Lungu’s ExcelUnusual, Excel as pure art. But it also seems difficult to extend this concept for using Excel as a game developing environment.

But the thing we are looking after resembles more to the new mobile games. They, for sure, can be emulated in Excel, for example, Angry Birds, or the short lived FlappyBird one, here in three flavours, Cells scent, throughly explained hereChart scent (not downloadable any more), and Forms scent.

An approximation to the game world via Flash, as depicted in most of the links at https://www.exceltrick.com/interesting/excel-games-free-download/, is not a feasible solution, as has little to do with Excel+VBA, beeing an embedded Flash object (an it’s security implications), and need a javascriptish language to be learned, which is not very VBA look alike.

So, if we want to go further on Excel, things start to get tricky, as usually they are lost on dead sites or are not yet fully developed.

Legendary Colo’s Excel Junk Room maintained a list of Excel games that leaded me to Kouichi Tani’s dead web site, which contains a bunch of games made entirely on Excel (the site is dead, so again archive.org came to the recue).

Looks like japanese people really enjoy “playing” with Excel, as you can see in any of the games linked at http://www1.plala.or.jp/chikada/vba/vba.htm which also has a better looking site http://www.geocities.jp/excel_game/. They are in most cases 2D, but the ideas underneath must be of some value, and can be borrowed for the development.

Newer good approximations to this subject are triyed and described by:

• C Bel has created an incredible 3D engine (Doom alike) which surely could be improved if some calculations were coded with VBA, but so far is looks like this:

Finally Excel can be unleash free to get a Legend of Zelda port to Excel. Better to see it with your own eyes to believe it (not 3D, kinda isometric view):

(download at http://youtu.be/PL9lz5_W0Bo). The author has also programmed an Space Wars clone, a car driving Out Run clone, and some other games. He also developed some kind of Sprite drawing software, very useful to make great games, which I would recommend to combine with a BMPToExcel macro to get sprites done in a bliss.
All can be downloaded from his 4Shared account, starting from his Excelda! (https://www.4shared.com/office/_LGiDKRt/Excelda_v013.html). They have a big issue with API functions (Sleep and GetAsyncKeyState, that make the games ultraslow, even with modern computers -although I’m using Office2k7 which it not a good platform for these kind of graphic developments-).

These last five items are the more promissing ones, but they seem not to rely on Excel.Shapes (GamesExcel ones does), and that thing is annoying me a bit. I believe better looking games with “decent” frame rate can be achieved with Excel.Shapes… so should be tried.

It should be worth to check ExcelSimulators site, as they have triyed several options to get the job done with shapes and also Priyenda Kumar’s site in his series for the game of the Bowman.

Excel as a Game Engine Motor

Following is my intro into the “game business”…

Lets throw some code into the VBA editor. Open the code module of a worksheet, put code PlayScreen inside.

Code PlayScreen:

```Option Explicit

'Move After Return Direction
Dim OldMARD As Excel.XlDirection 'Global
Dim NewMARD As Excel.XlDirection 'Global

Private Sub WorkSheet_Activate()
Call fSetPlayScreen(ActiveSheet, OldMARD, NewMARD)
End Sub

Private Sub WorkSheet_Deactivate()
Call fRestorePlayScreen(OldMARD)
End Sub
```

This procedures will trigger any time Worksheet get activated/desactivated, and their purpose is setting whole Columnwidth and Rowheight in order to achieve movements.
Also, some key events are captured and assigned to game events, “{LEFT}”, “{RIGHT}”, “{UP}”, “{DOWN}” for obvious reasons, “f” (as there is no {SPACE} chance no recalling to GetAsyncKeyState) can be assigned to fire of any ammo the character has in its bag, and even some combinations like “+{UP}” can be used to jump or “+{DOWN}” to crawl, “+{RIGHT} to run faster,…

For achieving this, paste the following code in a module:

```Option Explicit

Const BulletSize As Single = 1

Public Function fBuildCaller(ByVal bWorkbookName As Boolean, _
ByVal ProcName As String, _
ParamArray Args() As Variant) As Variant
' Function to build procedure with variable number of arguments
' Take care that if bWorkBookName = True, will be permanent linked to the Workbook
Dim oItem As Variant
Dim oSubItem As Variant
Dim strDebug As String
Dim lgRetVal As Long

For Each oItem In Args
If IsArray(oItem) Then
For Each oSubItem In oItem
strDebug = strDebug & " """ & oSubItem & ""","
Next oSubItem
Else
strDebug = strDebug & " """ & oItem & ""","
End If
Next oItem

If bWorkbookName Then
lgRetVal = VBA.MsgBox("If bWorkbookName is set to True, will be permanently linked to Workbook, go with it?", _
vbYesNo + vbExclamation, "I N F O")
If lgRetVal = vbNo Then bWorkbookName = False
End If
If strDebug = vbNullString Then
strDebug = VBA.IIf(bWorkbookName, "'" & ThisWorkbook.Name & "'!", "") & _
"'" & ProcName & "'"
Else
strDebug = VBA.IIf(bWorkbookName, "'" & ThisWorkbook.Name & "'!", "") & _
"'" & ProcName & VBA.Mid\$(strDebug, 1, Len(strDebug) - 1) & "'"
End If
fBuildCaller = strDebug
End Function

Public Function fBuildCaller2(ByVal ProcName As String, _
ParamArray Args() As Variant) As Variant
' Only working for PopUpMenus... better use fBuildCaller
' Has the advantage that "OnAction" is not linked to the WorkBook name
Dim oItem As Variant
Dim strDebug As String

For Each oItem In Args
strDebug = strDebug & Chr(34) & oItem + Chr(34) & ","
Next

If strDebug = vbNullString Then
strDebug = ProcName
Else
strDebug = ProcName & "(" & VBA.Mid\$(strDebug, 1, Len(strDebug) - 1) & ")"
End If
fBuildCaller2 = strDebug
End Function

Public Function fWalk(ByVal oDirection As Excel.XlDirection, _
Optional ByVal bFast As Boolean = False)
Dim oWsh As Excel.Worksheet
Dim sgSpeed As Single

Set oWsh = ActiveSheet
sgSpeed = oWsh.Cells(1, 1).Column.Width

'Application.ScreenUpdating = False
With ActiveWindow
If bFast Then
Select Case oDirection
Case Is = xlToLeft
'.LargeScroll ToRight:=-1
oWsh.Shapes("Body").IncrementLeft -(2 * sgSpeed)
Case Is = xlDown:
'.LargeScroll Down:=-1
oWsh.Shapes("Body").IncrementTop -(2 * sgSpeed)
Case Is = xlToRight
'.LargeScroll ToRight:=1
oWsh.Shapes("Body").IncrementLeft (2 * sgSpeed)
Case Is = xlUp
'.LargeScroll Down:=1
oWsh.Shapes("Body").IncrementTop (2 * sgSpeed)
End Select
Else
Select Case oDirection
Case Is = xlToLeft
.SmallScroll ToRight:=-1
oWsh.Shapes("Body").IncrementLeft -(1 * sgSpeed)
Case Is = xlDown
'.SmallScroll Down:=-1
oWsh.Shapes("Body").IncrementTop -(1 * sgSpeed)
Case Is = xlToRight
.SmallScroll ToRight:=1
oWsh.Shapes("Body").IncrementLeft (1 * sgSpeed)
Case Is = xlUp
'.SmallScroll Down:=1
oWsh.Shapes("Body").IncrementTop (1 * sgSpeed)
End Select
End If
'.LargeScroll ToRight:=-1
'.LargeScroll Down:=1
End With
'Application.ScreenUpdating = True
End Function

Public Function fSetPlayScreen(ByVal oWsh As Excel.Worksheet, _
ByRef OldMARD As Excel.XlDirection, _
Optional ByRef NewMARD As Excel.XlDirection = xlDown)
Dim oCells As Excel.Range
Dim BulletSize As Single

' Set zoom
ActiveWindow.Zoom = 70
With oWsh
Set oCells = .Cells
oCells.RowHeight = 15
oCells.ColumnWidth = 2.14
Set oCells = Nothing
End With

With Application
Call set_MARD(NewMARD, OldMARD)
'MARD = Application.MoveAfterReturnDirection
'.MoveAfterReturnDirection = xlToLeft 'xlToRight

'Restore OnKey Events
.OnKey "{LEFT}", fBuildCaller(False, "fWalk", xlToLeft)
.OnKey "{RIGHT}", fBuildCaller(False, "fWalk", xlToRight)
.OnKey "{DOWN}", fBuildCaller(False, "fWalk", xlUp)
.OnKey "{UP}", fBuildCaller(False, "fWalk", xlDown)

.OnKey "f", fBuildCaller(False, "fFire", BulletSize)
.OnKey "g", fBuildCaller(False, "fGetObject")
.OnKey "a", fBuildCaller(False, "fAmmo")
.OnKey "d", fBuildCaller(False, "fDestroy")

.OnKey "+{LEFT}", fBuildCaller(False, "fWalk", xlToLeft, "True")
.OnKey "+{RIGHT}", fBuildCaller(False, "fWalk", xlToRight, "True")
.OnKey "+{DOWN}", fBuildCaller(False, "fCrawl")
.OnKey "+{UP}", fBuildCaller(False, "fJump")
End With
End Function

Public Function fJump()
' Make the character jump to gather a platform or to avoid an enemy
End Function
Public Function fCrawl()
' Make the character crawl to gather some tight space, or to avoid high enemy attack
End Function
Public Function fGetObject()
' Make the character get any object
End Function
Public Function fFire(ByVal BulletSize As Single)
' Generate a bullet that moves BulletSize
End Function
Public Function fAmmo()
' Let the character get any ammo it has... can be implemented as a roulette... next ammo, next ammo,...
End Function
Public Function fDestroy()
' Let the character destroy any object in front of him
End Function

'Public Sub sRestorePlayScreen()
'    Call fRestorePlayScreen
'End Sub

Public Function fRestorePlayScreen(Optional ByRef OldMARD As Excel.XlDirection = xlDown)
With Application
Call restore_MARD(OldMARD)
'.MoveAfterReturnDirection = MARD

'Restore OnKey Events
.OnKey "{LEFT}"
.OnKey "{RIGHT}"
.OnKey "{DOWN}"
.OnKey "{UP}"

.OnKey "+{LEFT}"
.OnKey "+{RIGHT}"
.OnKey "+{DOWN}"
.OnKey "+{UP}"
End With
End Function

Public Sub set_MARD(ByRef OldMARD As Excel.XlDirection, _
Optional ByRef NewMARD As Excel.XlDirection = xlDown)
OldMARD = Application.MoveAfterReturnDirection
Application.MoveAfterReturnDirection = NewMARD 'xlDown, xlUP, xlToLeft, xlToRight
End Sub

Public Sub restore_MARD(Optional ByRef OldMARD As Excel.XlDirection = xlDown)
Application.MoveAfterReturnDirection = OldMARD
End Sub
```

In the worksheet, we need a character, named “Body” in this sample that must exists on the worksheet, this should be a shape (of any kind). So insert one to keep things moving.

From here on, we need a label in order to show score and other information (like number of lifes, health status, ammo,…). Lets call this shape “Info”.

We can add a physical green ground, and some deep background with clouds or sunny sky.

There can be enemies of different kinds, and for these we need a collision detection procedure (that will be implemented soon and posted here).

This could be a simple RPG game engine. Possibilities are endless.

Excel has enough capabilities to be used as a poor man’s CAD application, not recalling to Windows API to do it (at least not the ones used to draw), which IMHO would be the best way to accomplish full CAD features but could take longer to get working as a whole. Full DXF, SHP, KML,… I/O operations can be done inside the Excel CAD.

A good first reference of what can be done with Excel is this guide.

First, we need to know which are the shapes that we will deal with. So lets draw them in an Excel Worksheet to take a look in their geometry. To do so, we use a VBA macro to generate them, from information in Mso online help.

If we paste the Mso help table in a Worksheet, order them by msoAutoShapeType, we can therun the following VBA code to make the shapes appear (also will show the number of adjustments it has, and the numeration of the connecting sites if desired).

[sourcecode language=”vb”]
Public Sub sShapes_Template()
‘https://msdn.microsoft.com/en-us/vba/office-shared-vba/articles/msoautoshapetype-enumeration-office
‘ConnectionSites are generally distributed from 1=90º in counter clockwise order (from 109 to 136 in clockwise order, and 1=0º)
Dim oCell As Excel.Range
Dim oShpGroup As Excel.Shape
Dim oShp As Excel.Shape
Dim oShpCtr As Excel.Shape
Dim oShpConnector As Excel.Shape
Dim msoAutoshapeTypeValue As Long
Dim sgHeight As Single
Dim sgWidth As Single
Dim sgLeft As Single
Dim sgTop As Single
Dim lgConnector As Long

Const TOP_SIDE As Integer = 1
Const LEFT_SIDE As Integer = 2
Const BOTTOM_SIDE As Integer = 3
Const RIGHT_SIDE As Integer = 4

With ActiveSheet
.Rows(“2:185”).RowHeight = 72
For Each oCell In .Columns(1).SpecialCells(xlCellTypeConstants).Cells
If oCell.Row >= 3 Then
msoAutoshapeTypeValue = oCell.Offset(0, 1).Value
sgHeight = oCell.Height – 10
sgWidth = sgHeight

On Error GoTo NextShp
Left:=oCell.Left + (2 * sgWidth), _
Top:=oCell.Top + 5, _
Width:=sgWidth, _
Height:=sgHeight)
‘Set new Group
Set oShpGroup = oShp
oShpGroup.Name = “#” & msoAutoshapeTypeValue & “_”

With oShp
With .Fill
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
End With
With .Line
.DashStyle = msoLineSolid
.Transparency = 0
End With
With .TextFrame
With .Characters
.Font.Color = 1
‘.Font.Name = “Garamond”
‘.Font.size = 12
End With
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
End With
‘ Set oShpConnector = .Shapes.AddShape(msoShapeRectangle, _
‘ oShp.Left, _
‘ oShp.Top + oShp.Heigth, _
‘ oShp.Left + oShp.Width, _
‘ oShp.Top)
‘End If

oShp.Name = “#” & msoAutoshapeTypeValue

If oShp.ConnectionSiteCount > 0 Then
lgConnector = 0
For lgConnector = 1 To oShp.ConnectionSiteCount
0, _
0, _
0, _
0)
With oShpConnector
With .ConnectorFormat
.BeginConnect ConnectedShape:=oShp, ConnectionSite:=lgConnector
.EndConnect ConnectedShape:=oShp, ConnectionSite:=lgConnector
End With
sgLeft = .Left – 10
sgTop = .Top – 10
.Delete
End With

Left:=sgLeft, _
Top:=sgTop, _
Width:=20, _
Height:=20)
With oShpCtr
.Name = “#” & msoAutoshapeTypeValue & “_” & lgConnector
With .Fill
.Transparency = 1
End With
With .Line
.DashStyle = msoLineDashDotDot
.Transparency = 1
End With

If .Connector Or .Type = msoLine Then

‘ rough approximation of the Excel 2007 preset line style #17
.Line.Weight = 2
.Line.ForeColor.RGB = RGB(192, 80, 77)
.Visible = msoTrue
End If
With .TextFrame
With .Characters
.Text = lgConnector
.Font.Color = 1
‘.Font.Name = “Garamond”
‘.Font.size = 12
End With
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
End With

‘Set oShpGroup = .Shapes.Range(Array(oShpGroup.Name, oShpCtr.Name)).Group
Next lgConnector
End If
End If
NextShp:
On Error GoTo 0
Next oCell
End With
End Sub

Once we have the basic shapes, we can focus in what can be done to resemble a CAD application. Mostly, we need a Command entry area, a Command History area, a drawing area, some menus,… and little more. Lets face how to achive all this functionality.

So, get a new blank worksheet, add an ActiveX label control (named lbXYZ for tracking the cursor position), two ActiveX textbox controls (named txtCommand and txtHistory), and throw the following code into its coding section (ALT+F11):

[sourcecode language=”vb”]

Option Explicit
Private Const g_Base As Long = 0
‘!!!!!!!!!!

Public Type tPoint
X As Double
Y As Double
Z As Double
End Type

Public Type tPoly ‘also for 3D face?…
‘Id As Long ‘4 bytes

‘Properties
Layer As Long ‘4 bytes
Group As Long ‘4 bytes
Thickness As Single ‘4 bytes
Color As Long ‘4 bytes
Interior As Long ‘4 bytes

‘Geometry
TypePol As Long ‘8 bytes
Lft As Double ‘8 bytes
Top As Double ‘8 bytes
Height As Double ‘8 bytes
Width As Double ‘8 bytes
Rotation As Double ‘8 bytes
Closed As Boolean

Pointº As Integer ‘2 bytes
Point() As tPoint ‘Pointº * 24 bytes
Bulge() As Double ‘Pointº * 8 bytes
Offset As Double ‘8 bytes

Commentº As Long ‘4 bytes
Comment As String ‘Commentº bytes
End Type

Public Type tSpline
‘Id As Long ‘4 bytes

‘Properties
Layer As Long ‘4 bytes
Group As Long ‘4 bytes
Thickness As Single ‘4 bytes
Color As Long ‘4 bytes
Interior As Long ‘4 bytes

‘Geometry
‘TypePol As Long ‘8 bytes
Lft As Double ‘8 bytes
Top As Double ‘8 bytes
Height As Double ‘8 bytes
Width As Double ‘8 bytes
Rotation As Double ‘8 bytes
Closed As Boolean

Pointº As Integer ‘2 bytes
Point() As tPoint ‘Pointº * 24 bytes
Bulge() As Double ‘Pointº * 8 bytes
Offset As Double ‘8 bytes

Commentº As Long ‘4 bytes
Comment As String ‘Commentº bytes
End Type

Public Type tArc
‘Id As Long ‘4 bytes

‘Properties
Layer As Long ‘4 bytes
Group As Long ‘4 bytes
Thickness As Single ‘4 bytes
Color As Long ‘4 bytes
Interior As Long ‘4 bytes

‘Geometry
Lft As Double ‘8 bytes
Top As Double ‘8 bytes
Height As Double ‘8 bytes
Width As Double ‘8 bytes
SemiaxisA As Double ‘8 bytes ‘clockwise “> 0”, “< 0″ counter-clockwise
SemiaxisB As Double ‘8 bytes
StartAngle As Double ‘8 bytes
EndAngle As Double ‘8 bytes
Rotation As Double ‘8 bytes
Offset As Double ‘8 bytes
Closed As Boolean

Commentº As Long ‘4 bytes
Comment As String ‘Commentº bytes
End Type

‘Public Type tMesh
‘ ‘Id As Long ‘4 bytes

‘ ‘Properties
‘ Layer As Long ‘4 bytes
‘ Group As Long ‘4 bytes
‘ Thickness As Single ‘4 bytes
‘ Color As Long ‘4 bytes
‘ Interior As Long ‘4 bytes

‘ ‘Geometry
‘ ‘TypePol As Long ‘8 bytes
‘ Lft As Double ‘8 bytes
‘ Top As Double ‘8 bytes
‘ Height As Double ‘8 bytes
‘ Width As Double ‘8 bytes
‘ Rotation As Double ‘8 bytes

‘ PointAº As Integer ‘2 bytes
‘ SideA() As tPoint ‘PointAº * 24 bytes
‘ BulgeA() As Double ‘PointAº * 8 bytes

‘ PointBº As Integer ‘2 bytes
‘ SideB() As tPoint ‘PointBº * 24 bytes
‘ BulgeB() As Double ‘PointBº * 8 bytes

‘ Commentº As Long ‘4 bytes
‘ Comment As String ‘Commentº bytes
‘End Type

Public Type tText
‘Id As Long ‘4 bytes

‘Properties
Layer As Long ‘4 bytes
Group As Long ‘4 bytes
Thickness As Single ‘4 bytes
Color As Long ‘4 bytes
Interior As Long ‘4 bytes

‘Geometry
Lft As Double ‘8 bytes
Top As Double ‘8 bytes
Height As Double ‘8 bytes
Width As Double ‘8 bytes
Ground As tPoly ‘*** bytes
Rotation As Double ‘8 bytes
Autofit As Boolean ‘8 bytes
AlignmentH As Long ‘4 bytes
AlignmentV As Long ‘4 bytes
size As Single ‘4 bytes

‘Text
Textº As Long ‘4 bytes
Text As String ‘Textº bytes

Commentº As Long ‘4 bytes
Comment As String ‘Commentº bytes
End Type

Viewportº As Long
Viewport() As tPoly

Layerº As Long
Layer() As String * 256

Polyº As Long
Poly() As tPoly

Splineº As Long
Spline() As tSpline

Arcº As Long
Arc() As tArc

Textº As Long
Text() As tText
End Type

‘VarType(varName) vbVarType
‘Value Constant
‘ 0 vbEmpty
‘ 1 vbNull
‘ 10 vbError
‘ 8192 vbArray

‘ 17 vbByte
‘ 11 vbBoolean
‘ 2 vbInteger
‘ 3 vbLong
‘ 20 vbLongLong ‘(defined only on implementations that support a LongLong value type)
‘ 4 vbSingle
‘ 5 vbDouble
‘ 8 vbString

‘ 7 vbDate
‘ 14 vbDecimal
‘ 6 vbCurrency
‘ 13 vbDataObject
‘ 36 vbUserDefinedType
‘ 9 vbObject
‘ 12 vbVariant

Private aCmd() As String
Private aShrt() As String
Private PtrCmd() As Long
Private bEnableEvents As Boolean

‘– LISTENERS ——————-
Public bClickListener As Boolean
Public bSelectListener As Boolean
Public bTextListener As Boolean
Public oPointListener As tPoint
Public strShpListener As String

Public lgListen As Long ‘Counter for number of clicks it has to listen to before TRUE (zero for undefined)
Public msoAutoshapeTypeValue As Long ‘Autoshape type to draw
‘——————————–

‘– MOUSE ———————–
Public LastX As Long
Public LastY As Long
Public LastZ As Long
‘——————————–
Private Sub txtCommand_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
‘ txtComman.Select
End Sub
‘Set for txtHistory and txtCommand:
‘ Multiline = True
‘ SelectionHide = False
‘ Scrollbars
Private Sub txtCommand_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
With txtHistory
.Value = .Value & vbNewLine & txtCommand.Value
‘txtHistory. autoscroll to last line
‘In VB6: .SelectionStart = .Text.length
‘In VB6: .ScrollToCaret()
lgLen = lgLen + Len(txtCommand.Value)
.SelStart = lgLen ‘Len(.Value)
End With
txtCommand.Value = vbNullString ‘Clear content
ElseIf KeyCode = 32 Then
With txtCommand
‘Look for command if no spaces before:
If .Value = vbNullString Then
‘Repeat last command
.Value = LastCmd & VBA.Chr(32)
ElseIf VBA.InStrRev(.Value, VBA.Chr(32), Len(.Value) – 1) = 0 Then
LastCmd = VBA.Trim\$(.Value)
‘Run associated command function
‘Application.Run(“fcmd_” & LastCmd)
End If
End With
End If
End Sub
Private Sub Worksheet_Activate()
‘Do
‘ Me.lbXYZ.Caption = “X=” & MouseX & “;” & “Y = ” & MouseY ‘ & “;” & “Z = ” & MouseZ
‘ DoEvents
‘Loop While bNoFollow
End Sub
Private Sub Worksheet_Deactivate()
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
‘Select near entities…
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Me.lbXYZ.Caption = “X=” & MouseX & “;” & “Y = ” & MouseY ‘ & “;” & “Z = ” & MouseZ
Me.txtCommand.Activate
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.lbXYZ.Caption = “X=” & MouseX & “;” & “Y = ” & MouseY ‘ & “;” & “Z = ” & MouseZ
End Sub

As you can be see, there are a short number of public variables used all along the worksheet and the userforms, so information can be passed from one procedure to another and to set conditions to roll on the alternatives.

Also, it is insinued that we need an object structure to store all the drawing information (Lines, Polylines, Arcs, Splines, Texts, Meshes,…) so I/O operations can be performed. Export/Import format can be anyone, KML, DXF,… but it has to be coded as an apart.

Entering COMMANDS

Sooner than later we’ll have to deal on a method that lets us enter CAD commands. They have to be introduced on txtCommand ActiveX control, waiting for commands to be entered through keyboard, but first we must gain focus for it, avoiding Excel ActiveCell’s default focus. This only can be done via code.

A not comprehensive list of CAD commands can be obtained from http://academics.triton.edu/faculty/fheitzman/commands.html, and also the complete list of command shortcuts aliases: https://www.autodesk.com/shortcuts/autocad.

A table (year 2018) of 406 commands is shown here:

It’s cristal clear that all this commands have to be programmed, as few can be achieved directly via Excel Shape methods. So there is still plenty to do, coding function procedures for the commands, i.e. for 3DFACE command:

[sourcecode language=”vb”]
‘ Creates a three-dimensional face
Dim strRetVal As String
Dim lgRetVal As Long
‘Dim oPolygon() As tPoint
Dim lgPoint As Long
Dim bPoint As Boolean
For lgPoint = 0 To 3
‘Do
‘ strRetVal = VBA.InputBox(Prompt:=”Invisible edge/:”, _
Default:=”First” & ” point of 3D face>:”)
‘ bPoint = fTextToPoint(strRetVal, oPoint)
‘ oPolygon(g_Base + lgPoint) = oPoint
‘Loop Until bPoint
Next lgPoint
‘If Not fCoplanar(oPolygon(g_Base + 3), oPolygon(g_Base + 0), oPolygon(g_Base + 1), oPolygon(g_Base + 2)) Then
‘ lgRetVal = vba.msgbox(“Points are not coplanar, modify Z to be coplanar?”, vbYesNo + vbExclamation, “W A R N I N G”)
‘ If lgRetVal = vbYes Then
‘ modify Z to be coplanar…
‘ Else
‘ Exit Function
‘ End If
‘End If
‘Create 3D face polygon
‘…
End Function

In a CAD application, there are also dockbars (or floating menus) to enter commands via mouse clicks. In order to do so, a Userform can be arranged to look like a floating menu (turning ShowModal property to False).

Drawing area

Before going further, we must set some conventions, mostly on how user shapes will be named, and for my convenience I’ve followed the following criteria (can be adapted to one’s needings):

• Shape name should start with “#” character, followed by its assigned name (Id code) represented by a number.
• If shape is not in layer “0” then insert, at the end of the name, the layer name preceded by “@” character.

Finally we need a drawing area that can be easily recognised via code. So lets name it with special carácter “•” (ALT+7) in the beggining. In order to be functional, we need to track mouse position and act as a listener. To achieve this we can fool Excel with a temporal “•Tmp” Excel.Shape, on top of drawing area, in order to get that Click listener, associating a global macro to start the listener, and another specific one to the “•Tmp” shape in order to stop the listening once it’s clicked. The shape will be only set as visible when the listener bClickListener is active, so that it does not interfere to changing cell selection when not needed.

[sourcecode language=”vb”]
Public Sub sListening()
bClickListener = True
With ActiveSheet
strShpListener = “•Tmp”
.Shapes(strShpListener).Visible = True
Do
.lbXYZ.Caption = “X=” & MouseX & “, ” & “Y = ” & MouseY ‘ & “, ” & “Z = ” & MouseZ
DoEvents
Loop While bClickListener
End With
End Sub

Public Sub sListener()
With ActiveSheet
bClickListener = False
‘Actualize Mouse position
.lbXYZ.Caption = “X=” & MouseX & “, ” & “Y = ” & MouseY ‘ & “, ” & “Z = ” & MouseZ
.txtCommand.Value = “”
.Shapes(strShpListener).Visible = False
End With

With every new shape that is added we need to properly set the OnAction property in order to take control back each time a shape is clicked. To do this we can use the procedure builder that is exposed in this post. The procedure that we are going to set in the OnAction should, at least, determine if SHFT or CTRL keys are pressed (for multiple selection), and send/store the shape name, the unique Id code, and basic properties of the shape, and then return focus to txtCommand. If needed, it should set visible (with transparency) a txtShape control in order to operate on the shape properties.

We need some public variables to store the edition status: aItem() As tCAD_Item (UDT where to store properties for that shape); aSelected() As String (where to store the Id of the -selected- shapes); btxtShape for enabling or disabling the direct edition of  the shape; ….

The best part of all of this development is that it can be easily adapted to work on a userform, so better capacities can be achieved, using API to draw on the userform.

A very basic skechup of this application concept could be downloaded if WordPress let upload XLMS or even ZIP files, which is not the case. So for now, only the code posted 😉

Shall continue this post… look for xlCAD2

Procedures identification

Here is a module “Invisible Basic”, writen by John C. Gunther, that identifies procedures in modules. From there on, they can be ported.

```' Invisible Basic: A utility for the obfuscation of VBA code
' in Excel Workbooks. See the Invisible Basic User's Guide
' (InvisibleBasic.html) for a detailed description of why
' this is useful.
'
' Copyright (c) 2005, John C. Gunther.
'
' Redistribution and use in source and binary forms, with
' or without modification, are permitted provided that the
' following conditions are met:
'
' - Redistributions of source code must retain the above
' copyright notice, this list of conditions and the following
' disclaimer.
'
' - Redistributions in binary form must reproduce the above
' copyright notice, this list of conditions and the following
' disclaimer in the documentation and/or other materials
' provided with the distribution
'
' - Neither the name of the Invisible Basic Consortium nor
' the names of its contributors may be used to endorse or
' promote products derived from this software without
' specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
' CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
' WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
' PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
' COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
' INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
' DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
' SUBSTITURE GOODS OR SERVICES; LOSS OF USE, DATA, OR
' PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
' ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
' LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
' ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
' IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' Note: the licence conditions above were copied from the
' BSD open source license template available at
'

Option Explicit

Public Const INVISIBLE_BASIC_VERSION As Double = 3#
Public Const INVISIBLE_BASIC_URL As String = "http://invisiblebasic.sourceforge.net"

' Token types: as a program's source code is scanned, it is
' separated into a stream of tokens each with one of these
' types:
Private Const TT_IDENTIFIER As Integer = 1 'variable names, keywords, etc.
Private Const TT_STRING As Integer = 2 ' string literal ("myString")
Private Const TT_NUMBER As Integer = 3 ' numerical literal (1.23)
Private Const TT_COMMENT As Integer = 4 ' VBA comment text
Private Const TT_WHITESPACE As Integer = 5 ' space or tab
Private Const TT_GUID As Integer = 6 ' global universal identifier
' ({C62A69F0-16DC-11CE-9E98-00AA00574A4F})
Private Const TT_OTHER As Integer = 7 ' everything else

' Name of the file that contains the list of visible (not obfuscated)
' Excel/VBA keywords, reserved Excel object model names, etc.
Private Const IB_VISIBLE_KEYWORDS_FILENAME = "visible_names.txt"

' establish classes of characters helpful in tokenization:

Private Const alphaChars As String = "abcdefghijklmnopqrstuvwxyz"
Private Const underscore As String = "_"
Private Const digits As String = "0123456789"
Private Const dQuote As String = """"
Private Const GUID_START As String = "{" ' "Global Universal ID"
Private Const GUID_END As String = "}" ' (occurs in UserForm headers)
' Note: by including underscore as whitespace, parsing of continued
' lines (ending in " _") is facilitated. VBA does not allow identifiers to begin with
' underscores, so this does not cause ambiguities with the lexical
' analysis of identifiers.
Private Const wsChars As String = " " & vbTab & vbNewLine & underscore
Private Const firstNumericChars As String = digits
Private Const numericChars As String = firstNumericChars & "."
Private Const firstCommentChar As String = "'"
Private Const doubleComment As String = firstCommentChar & firstCommentChar
Private Const line_continuation_chars As String = " " & underscore
Private Const firstIdentifierChars As String = alphaChars
Private Const identifierChars As String = alphaChars & underscore & digits
' e.g. in the event procedure myButton_Click, "_" delimits the
' control name from the event name:
Private Const userform_event_delimiter As String = underscore
' if this character preceeds an indentifier within visible_names.txt, it flags
' that identifier as a userform control attribute.
Private Const userform_control_attribute_flag As String = underscore
Private Const object_attribute_delimiter As String = "." 'object attribute delimiter (e.g. the "." in myLabel.Caption)

' These keywords, when encountered in source code, are
' recognized by Invisible Basic as directives that define if
' identifiers will be obfucated ("invisible") or retained as is
' ("visible")

Private Const VISIBLE_KEYWORD As String = "#visible" ' for single lines
' for delimiting visible blocks:
Private Const BEGIN_VISIBLE_KEYWORD As String = "#begin_visible"
Private Const END_VISIBLE_KEYWORD As String = "#end_visible"

' this is added to the end of the workbook file name to get
' the default new, obfuscated, workbook's filename (e.g.
' myWorkbook.xls becomes saved invisibly, if user accepts
' the initial default name, as myWorkbook_ib.xls):

Private Const IB_FILENAME_SUFFIX As String = "_ib.xls"
' invisible basic overwrites this file without confirmation, so using
' the .tmp (temporary file) file type is essential.
Private Const IB_SECRET_DECODER_SUFFIX As String = "_secretDecoder.tmp"

' depth of #begin_visible ... #end_visible nesting:
Private m_visible_depth As Long

' returned when a specified identifier isn't found:
Private Const NO_SUCH_ID As String = ""

' lists of names that will remain in original format
' (visible), and of those that will be obuscated (made invisible)
Private visible_names As New Collection
Private invisible_names As New Collection

' lists of userform attribute names; userform attributes are used to
' identify userform control names either 1) via their use in event
' procedure names (e.g. the Click attribute identifies myButton as a
' control name in the event procedure myButton_Click) or 2) via the
' direct use of the attribute in code (e.g., the Caption attribute
' identifies myLabel as a control name in the code line:
' myLabel.Caption = "myLable Caption"). Such control names are
' automatically declared as "visible names" by Invisible Basic,
' and not obfuscated.
'
' Why do we even need this, you ask. Unlike most VBA variables,
' UserForm control names are NOT defined in the source code; because I
' could not figure out how to change these (non-source defined) names
' programmatically, I instead must be sure they are NOT changed in the
' source code (or else names would get out of synch, breaking the
' UserForm). Hence the need for these special "visible attribute"
' rules to recognize such control names.
'
' Pre 2.0 versions didn't have this feature, and thus required manual
' user intervention to declare such control names visible.

Private userform_attribute_names As New Collection

' if True, each obfuscated final code line will be preceeded with
' a comment containing the original, unobfuscated, line
' it came from (for trouble-shooting).

Private Const IB_NameOfInvisibleBasicMenu As String = "Invisible&Basic"
Private Const IB_NameOfExcelWorksheetMenubar As String = _

Private Const IB_TEMP_FILENAME_PREFIX = "InvBas_Temp_" ' example temp filename: InvBas_Temp_1.tmp

' these declarations are used only by the visit_url function,
' used by the help command to open the Help file. Help command
' only works on Windows platforms.

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWDEFAULT As Long = 10

' end of declarations for visit_url

' These constants (sans the "IB_" prefix) are defined in the
' Microsoft Visual Basic for Applications Extensibility Library.

' So that users do not have to add a reference to that library, we
' define copies of those constants here. Another reason for doing this
' is that there can be more than one of these libraries on a single
' machine, and if a reference to the wrong version is employed, the
' code breaks with a rather cryptic "type mismatch" error (the type of
' VBComponent used by Excel differs from the type used by the
' VBComponent in the Extensibility library if the extensibility
' library is from a newer version of Excel)

' If (as seems very unlikely) Microsoft ever changes these constants,
' these lines would have to be changed.

Private Const IB_vbext_ct_StdModule As Long = 1
Private Const IB_vbext_ct_ClassModule As Long = 2
Private Const IB_vbext_ct_MSForm As Long = 3
Private Const IB_vbext_ct_Document As Long = 100

' End of Microsoft VBA Extensibility library constants

' circular buffer of recently seen tokens (facilitates
' recognition of userform control names):
Private Const N_BUFFERED_TOKENS As Integer = 3
Private prevTokens(0 To N_BUFFERED_TOKENS - 1) As String
Private tokenIndex As Integer

' These are used for encoding name, value pairs into VB collections

Private Const NAME_ID As Integer = 1 ' represent the offsets into an array storing name, value pair
Private Const VALUE_ID As Integer = 2 ' (VB collections will not allow you to store user defined types)

Private Function PS() As String ' e.g. a "\" on Windows
PS = Application.PathSeparator
End Function

Public Property Get interleave_original_code_as_comments() As Boolean
End Property

End Property

' VBA within Excel 97 lacks "Debug.Assert". For compatibility with
' all major Excel versions, we therefore emulate it:
Private Sub assert(condition As Boolean)
If (Not condition) Then Stop
End Sub

' Does an old-style "Rem" comment begin at the specified position in the string?
'
' Note: Rem is a keyword, and thus cannot be used as a variable name
' in compilable VBA code--this fact simplifies the test below.
Private Function isRemComment(s As String, iStart As Integer) As Boolean
isRemComment = ("rem" = LCase(Trim(Mid(s, iStart, Len("rem ")))))
End Function

' Returns integer type of a token assumed to start at give
' position in the given string

' Note: Invisible Basic's lexical analysis is, by design, very simple
' and suitable only for this code obfuscation task. For example, the
' "E" in scientific notation numeric literals will be treated like a
' variable that is always visible (e.g. 1.2E10 is analyzed as the number
' 1.2, the always-visible name E, and the number 10). It all comes out OK in
' the end, but just be aware that the string of tokens seen by
' Invisible Basic is NOT the same as what Visual Basic sees.

Private Function token_type(s As String, _
iStart As Integer) As Integer
Dim c As String
Dim result As Integer
assert 1 <= iStart And iStart <= Len(s)
c = LCase(Mid(s, iStart, 1))
If (InStr(1, wsChars, c) <> 0) Then
result = TT_WHITESPACE
ElseIf (firstCommentChar = c Or isRemComment(s, iStart)) Then
' this branch must preceed identifier branch or "Rem" comments will look like identifiers
result = TT_COMMENT
ElseIf (InStr(1, firstIdentifierChars, c) <> 0) Then
result = TT_IDENTIFIER
ElseIf (c = dQuote) Then
result = TT_STRING
ElseIf (c = GUID_START) Then
result = TT_GUID
ElseIf (InStr(1, firstNumericChars, c) <> 0) Then
result = TT_NUMBER
Else
result = TT_OTHER
End If

token_type = result

End Function

' Returns the string position 1 character past the end of the
' token that starts at the given position in the given string.

Private Function end_of_token(s As String, _
iStart As Integer) As Integer
Dim iEnd As Integer
Dim tt As Integer
Dim matchChars As String
Dim invertMatch As Boolean
Dim matched As Boolean
Dim c As String

tt = token_type(s, iStart)

Select Case (tt)
Case TT_IDENTIFIER
matchChars = identifierChars
invertMatch = False
Case TT_STRING
matchChars = dQuote
invertMatch = True ' all chars until next double quote
Case TT_GUID
matchChars = GUID_END
invertMatch = True
Case TT_NUMBER
matchChars = numericChars
invertMatch = False
Case TT_COMMENT
matchChars = ""
invertMatch = True ' match everything until end of line
Case TT_WHITESPACE
matchChars = wsChars
invertMatch = False
Case TT_OTHER
' any character that can NOT be viewed as the first char of
' one of the above token types
matchChars = firstIdentifierChars & firstNumericChars & _
firstCommentChar & dQuote & wsChars & GUID_START
invertMatch = True
End Select

iEnd = iStart + 1

Do While (iEnd <= Len(s))
c = LCase(Mid(s, iEnd, 1))
matched = InStr(1, matchChars, c) <> 0
If (invertMatch) Then matched = Not matched

If (Not matched) Then Exit Do

iEnd = iEnd + 1

Loop

' end of string or GUID should include the closing double
' quote or end of GUID character (close curley brace), so
' increase by one to include these final characters.

' Note: improperly terminated quotes or GUIDs should be impossible
' in "compilable" VBA source code. In the event that the closing
' character is missing, iEnd will already be one past the last
' character of the input line/string, so no need to advance it.

If ((tt = TT_STRING And c = dQuote) Or _
(tt = TT_GUID And c = GUID_END)) Then
iEnd = iEnd + 1
End If

end_of_token = iEnd

End Function

' returns a meaningless, sequential, variable name (that is
' also reasonably short).

Private Function invisible_variable_name(var_id As Long) As String
Dim result As String
Dim i As Long
Dim L1 As Integer
Dim L2 As Integer

assert var_id > 0
result = ""
'
' this algorithm obtains a valid, short, and meaningless identifier by
' expressing the given integer variable id as a "mixed base"
' number whose "digits" are the characters valid in an identifier.

' Specifically, if you think of the variable id integer as expressed as:

' var_id = i0 + L1* (i1 + L2*i2 + L2^2*i3 + L2^3*i4 + ... )

' (by a slight generalization of the basic ideas of "base X" numbers
' you can show that any positive integer can be expressed in such a
' "mixed L1/L2 base" form)

' where L1 is the length of the valid initial identifier characters
' string; L2 is the length of the valid non-initial identifier
' character string; i0 is an integer index (0..L1-1) into the initial
' identifier char string, and i1, i2, ... are indexes (0...L2-1) into
' the non-initial identifier char string. Then the chars associated
' with these indexes determine the chars in a valid identifier (variable
' name) uniquely determined by var_id.

i = var_id
L1 = Len(firstIdentifierChars)
L2 = Len(identifierChars)
result = Mid(firstIdentifierChars, 1 + i Mod L1, 1)
i = Fix(i / L1)
Do While (i > 0)
result = result & Mid(identifierChars, 1 + i Mod L2, 1)
i = Fix(i / L2)
Loop

invisible_variable_name = result

End Function

' Associates an appropriate obfuscated name with each member
' of the invisible names collection
'
' Also excludes names from the invisible names collection
' that are also on the visible names collection.

Private Sub define_obfuscated_names()
Dim iName As Long
Dim vName As String
Dim cNew As New Collection
Dim iObfuscated_Name As Long

iObfuscated_Name = 1
For iName = 1 To invisible_names.Count
If (lookup_identifier(visible_names, CStr(invisible_names.Item(iName)(NAME_ID))) _
= NO_SUCH_ID) Then
Do ' keep looking until we get a name that is not on either
' the visible or invisible list; this loop executes once, on
' average, because collisions are unlikely Note: Assuring the
' new name isn't on the invisible list is required to avoid
' errors when renaming module, class and userform names.
vName = invisible_variable_name(iObfuscated_Name)
iObfuscated_Name = iObfuscated_Name + 1
Loop Until _
lookup_identifier(visible_names, vName) = NO_SUCH_ID And _
lookup_identifier(invisible_names, vName) = NO_SUCH_ID
'else identifier is on visible list, so elide it from invisible list
End If
Next iName

Set invisible_names = cNew

End Sub

' returns the (possibly obfuscated, transformed) variable
' name given the original variable name

Private Function var_name(plaintextVarname As String) As String
Dim result As String
result = lookup_identifier(invisible_names, LCase(plaintextVarname))
If (result = NO_SUCH_ID) Then
' just keep the original name except converted to lowercase
result = LCase(plaintextVarname)
End If
var_name = result
End Function

' clears all of the elements in the lookup table
Private Sub reset_lookup_table(lookup_table As Collection)
Set lookup_table = New Collection
End Sub

' returns the value associated with given name, or NO_SUCH_ID if there
' is not such a (name, value) pair in the collection.
Private Function lookup_identifier(c As Collection, sName As String) As String
Dim result As String
On Error GoTo not_found
result = c.Item(LCase(sName))(VALUE_ID)
GoTo end_of_function
not_found:
result = NO_SUCH_ID
end_of_function:
lookup_identifier = result
End Function

Private Sub remove_identifier(c As Collection, sName As String)
If (lookup_identifier(c, sName) <> NO_SUCH_ID) Then
c.Remove LCase(sName)
End If
End Sub

' adds the name, value pair to the collection if the name is
' not already on the collection.

Private Sub add_identifier(c As Collection, sName As String, sValue As String)
Dim name_value_pair(NAME_ID To VALUE_ID) As String

If (NO_SUCH_ID = lookup_identifier(c, sName)) Then
name_value_pair(NAME_ID) = sName
name_value_pair(VALUE_ID) = LCase(sValue)
End If

End Sub

' location of the last substring within the given string, or 0 if
' substring doesn't occur within given string.

Private Function last_substring_position(s As String, subS As String) As Integer
Dim iFound As Integer
Dim iNext As Integer

iFound = 0
iNext = InStr(1, s, subS)
Do While (iNext > 0)
iFound = iNext
iNext = InStr(iFound + 1, s, subS)
Loop

last_substring_position = iFound

End Function

' location of the event delimiter ("_") within the token, or 0 if none.

Private Function event_delimiter_position(token As String) As Integer
event_delimiter_position = last_substring_position(token, userform_event_delimiter)
End Function

' Returns the part of an event procedure token associated with the
' name of an event. For example, with an event procedure token of
' "myButton_Click", returns "Click"

' if the token isn't in the general format of an event procedure name,
' (e.g. it doesn't contain an underscore) it returns NO_SUCH_ID

Private Function event_part(token As String) As String
Dim iPosition As Integer
Dim result As String

iPosition = event_delimiter_position(token)
If (iPosition = 0) Then
result = NO_SUCH_ID
Else
result = Right(token, Len(token) - (iPosition + Len(userform_event_delimiter) - 1))
End If

event_part = result

End Function

' returns the part of an event procedure name associated with the
' name of the object (e.g. myButton_Click as token would return myButton)

Private Function object_part(token As String) As String
Dim iPosition As Integer
Dim result As String

iPosition = event_delimiter_position(token)
If (iPosition = 0) Then
result = NO_SUCH_ID
Else
result = Left(token, iPosition - 1)
End If

object_part = result

End Function

' does the token represent an event procedure name (e.g. myButton_Click) ?
Private Function is_event_procedure(token As String) As Boolean
Dim sEvent As String
Dim result As String
sEvent = event_part(token)
If (sEvent = NO_SUCH_ID) Then
result = False
ElseIf (NO_SUCH_ID = lookup_identifier(userform_attribute_names, sEvent)) Then
result = False
Else
result = True
End If
is_event_procedure = result
End Function

' does the given string begin with the specified prefix?
Private Function has_prefix(s As String, prefix As String) As Boolean
has_prefix = (Left(s, Len(prefix)) = prefix)
End Function

' does the given string end with the specified suffix?
Private Function has_suffix(s As String, suffix As String) As Boolean
has_suffix = (Right(s, Len(suffix)) = suffix)
End Function

' sets token buffer to the default, "do nothing", token sequence
Private Sub reset_token_buffer()
Dim i As Integer
For i = LBound(prevTokens) To UBound(prevTokens)
prevTokens(i) = " " ' use whitespace because leading whitespace cannot change how a program is parsed
Next i ' (the default "" isn't a valid token and can therefore cause problems)
tokenIndex = LBound(prevTokens)
End Sub

' write the token into the circular token buffer
Private Sub remember_token(token As String)
tokenIndex = (tokenIndex + 1) Mod N_BUFFERED_TOKENS
prevTokens(tokenIndex) = token
End Sub

' returns the last token stored in the token buffer
Private Function last_token() As String
last_token = prevTokens(tokenIndex)
End Function

' returns next-to-the-last token stored in the token buffer
Private Function next_to_last_token() As String
Dim result As String
If (tokenIndex = LBound(prevTokens)) Then
result = prevTokens(UBound(prevTokens)) ' wrap-around to last element
Else
result = prevTokens(tokenIndex - 1) ' no-wrap-around needed
End If
next_to_last_token = result
End Function

' does the token represent an attribute (event or property) of a
' control contained on a userform?
Private Function is_userform_attribute(token As String) As Boolean
is_userform_attribute = (NO_SUCH_ID <> lookup_identifier(userform_attribute_names, token))
End Function

' Is the token one that, when it preceeds another token (separated
' only by whitespace) indicates that that token represents an
' explicitly declared name.
'
' Examples (the variable x is explicitly declared because it is
' preceeded by Dim, Private, or Function):
'
' dim x as Double
' private x as Variant
' private function x()

Private Function preceeds_declared_name(token As String) As Boolean
Dim result As Boolean

Select Case LCase(token)

Case "friend", "enum", "declare", "static", "byref", "byval", "get", "let", "set", "dim", _
"function", "sub", "type", "const", "private", "public", "global", "paramarray", _
"optional", "property"

result = True
Case Else
result = False
End Select

preceeds_declared_name = result
End Function
' is the token one that, when it follows another token separated only
' by whitespace, implies that token is an explicitly declared name?

' Example (the name x is explicitly declared because it is followed
' by "as"):
'
' type myType
' x as Integer
' end type

Private Function follows_declared_name(token As String) As Boolean
Dim result As Boolean
Select Case LCase(token)
Case "as", "lib"
result = True
Case Else
result = False
End Select
follows_declared_name = result
End Function

' adds ids contained in the string (representing a single, though possibly
' continued, line of input source text) to appropriate lookup tables
' used to determine which variable names remain unchanged, and which
' are obfuscated (replaced with variable names meaningless to humans).

Private Sub register_ids(s As String)
Dim iStart As Integer
Dim iEnd As Integer
Dim visible As Boolean
Dim obfuscated_id As Long
Dim token As String

reset_token_buffer ' cross-source-statement token sequences are not of interest

If InStr(1, LCase(s), BEGIN_VISIBLE_KEYWORD) <> 0 Then
m_visible_depth = m_visible_depth + 1
End If
If InStr(1, LCase(s), END_VISIBLE_KEYWORD) <> 0 Then
m_visible_depth = m_visible_depth - 1
End If

If InStr(1, LCase(s), VISIBLE_KEYWORD) > 0 Then
' single line #visible keyword makes ids on this line visible, no
' matter what our visible depth is
visible = True
Else
' no line specific keyword, so based on if we are within
' a #begin_visible ... #end_visible bracketed region
visible = m_visible_depth > 0
End If

iStart = 1
Do While (iStart <= Len(s))
iEnd = end_of_token(s, iStart)
token = LCase(Mid(s, iStart, iEnd - iStart))

If (token_type(token, 1) = TT_IDENTIFIER) Then
If (last_token() = userform_control_attribute_flag) Then
' token is flagged as representing a userform-related event,
' such as Click (or control property such as Caption)
'
' Example token sequence: "_" followed by "Click" will
' register "Click" as a userform attribute. Note that "_Click"
' isn't processed as a single token because "_" isn't a valid
' first character of a variable name in VBA.
ElseIf (is_event_procedure(token)) Then
' example token: myButton_Click will make itself and myButton visible if _Click is listed in visible_names.txt
ElseIf (is_userform_attribute(token) And _
last_token() = object_attribute_delimiter And token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
' example: myLabel.Caption will make myLabel a visible name if
' "_Caption" is listed in visible_names.txt (the leading _
' flags Caption as a userform control attribute (event or property))
ElseIf (visible) Then
Else
' note: if an identifier gets added to both visible and
' invisible lists, it will considered visible (and get removed
' from the invisible list in a separate step later on).
If (token_type(last_token(), 1) = TT_WHITESPACE) Then
If (preceeds_declared_name(next_to_last_token())) Then
End If

If (follows_declared_name(token) And _
token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
End If
End If
End If
' else not an identifier, so it can never be added to lookup tables
' used to determine token visibility.
End If

remember_token token ' stores last few token in a circular buffer for easier parsing

iStart = iEnd
Loop

End Sub

' the length of a string, excluding and leading/trailing double quotes
Private Function length_sans_quotes(s As String) As Integer
Dim result As Integer
result = Len(s)
If (has_prefix(s, dQuote)) Then result = result - Len(dQuote)
If (has_suffix(s, dQuote)) Then result = result - Len(dQuote)
length_sans_quotes = result
End Function

' length of the given prefix within a specified string, or 0 if that
' prefix is not at the beginning of the specified string
Private Function length_of_prefix(s As String, prefix As String) As Integer
Dim result As Integer
If (has_prefix(s, prefix)) Then
result = Len(prefix)
Else
result = 0
End If
length_of_prefix = result
End Function
' strips leading, trailing, double quotes from a given string
' (if no such quotes present, returns original string)
Private Function NQ(s As String) As String
NQ = Mid(s, 1 + length_of_prefix(s, dQuote), length_sans_quotes(s))
End Function

' adds double quotes around the given string
Private Function Q(s As String) As String
Q = dQuote & s & dQuote
End Function

' returns an obfuscated, functionally equivalent, source code line
' for the given source code line
Private Function obfuscated_line(s As String) As String
Dim result As String
Dim iStart As Integer
Dim iEnd As Integer
Dim token As String

result = ""

iStart = 1

Do While (iStart <= Len(s)) iEnd = end_of_token(s, iStart) token = Mid(s, iStart, iEnd - iStart) Select Case (token_type(token, 1)) Case TT_IDENTIFIER result = result & var_name(token) Case TT_WHITESPACE If (InStr(token, line_continuation_chars & vbNewLine) > 0) Then
' line continuation characters and newlines are analyzed as
' part of whitespace tokens, but they need to be preserved
' because VBA has line length constraints that could break code
' if long continued lines were collapsed into a single line.
result = result & line_continuation_chars & vbNewLine
Else
result = result & " "
End If
Case TT_NUMBER
result = result & token
Case TT_STRING
result = result & token
Case TT_COMMENT
If (has_prefix(token, doubleComment)) Then
' double comments are retained (for copywrite notices, etc.)
result = result & Right(token, Len(token) - Len(firstCommentChar))
' else just ignore/elide the comment
End If
Case TT_GUID
result = result & token
Case TT_OTHER
result = result & token
Case Else
assert False ' should have been type "other"
End Select
iStart = iEnd
Loop

' trim to drop any leading whitespace (makes lines all flush left)
obfuscated_line = Trim(result)

End Function

' reads each line from the specified sourcecode file, and
' registers any identifiers contained in the file on the
' appropriate (visible or invisible) lookup table.

Private Sub register_identifiers(fName As String)
Dim fid As Integer
Dim sLine As String
Dim errNo As Long
On Error GoTo error_exit

fid = freefile()
Open fName For Input As #fid

' read each (possibly continued) line, registering its ids
Do While Not EOF(fid)
sLine = get_continued_line(fid)
register_ids sLine
Loop

Close fid
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close fid
Err.Raise errNo

end_of_sub:
End Sub

' is the line one that is continued on the next line (ends in
' the VBA line continuation character sequence, " _")
Private Function is_continued_line(sLine As String) As Boolean
is_continued_line = has_suffix(sLine, line_continuation_chars)
End Function

' adds another line to an existing series of "vbNewLine
' separated" lines, returning the so-extended series of lines.

Private Function add_line(sOld As String, sNew As String) As String
Dim result As String
If (sOld = "") Then
result = sNew
Else
result = sOld & vbNewLine & sNew
End If
End Function

' returns a (possibly continued) source code line from the given
' input file.
Private Function get_continued_line(f_in As Integer) As String
Dim result As String
Dim sTmp As String
result = ""
Do ' read & concatenate continued lines
Line Input #f_in, sTmp
Loop Until EOF(f_in) Or Not is_continued_line(sTmp)

get_continued_line = result

End Function

' obfuscates the given sourcecode file by removing comments,
' replacing meaningful names with meaningless names, etc.

' A side benefit: it tends to reduce the size of the source code
' files, due to comment elimination and the fact that
' obfuscated names are usually substantially shorter than
' the original names.

Private Sub obfuscate_sourcecode_file( _
f_plain As String, f_obfuscated As String)
Dim f_in As Integer
Dim f_out As Integer
Dim sLine As String
Dim sObfuscated As String
Dim errNo As Long
On Error GoTo error_exit

f_in = freefile()
Open f_plain For Input As #f_in
f_out = freefile()
Open f_obfuscated For Output As #f_out

' obfuscate, and then write, each original input source code
' file line into the obfuscated source code output file
Do While Not EOF(f_in)
sLine = get_continued_line(f_in)
sObfuscated = obfuscated_line(sLine)
Print #f_out, firstCommentChar & sLine
Print #f_out, sObfuscated ' empty obfuscated lines retained--helpful when debugging.
ElseIf (sObfuscated <> "") Then
Print #f_out, sObfuscated
' else elide lines that are empty after obfuscation
End If

Loop

Close f_in
Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_in
On Error Resume Next
Close f_out
Err.Raise errNo

end_of_sub:

End Sub

' returns a temporary file name given a file number
Private Function temp_file_name(wb As Workbook, _
iFile As Integer, Optional extension = ".tmp") As String
temp_file_name = wb.Path & PS() & IB_TEMP_FILENAME_PREFIX & _
CStr(iFile) & extension
End Function

' returns a random module name suitable for use as a VBA code module
Private Function random_module_name() As String
' highly unlike this name will conflict with any existing names
random_module_name = "qzx" & _
Format(10 ^ 6 * Rnd(), "000000") & Format(10 ^ 6 * Rnd(), "000000")
End Function

' writes source code in a given VBComponent into a specified file
' (overwrites any existing file contents)

Private Sub write_component_code(vbc As Object, f As String)
Dim f_out As Integer
Dim iLine As Long
Dim errNo As Long
On Error GoTo error_exit

f_out = freefile()
Open f For Output As #f_out

For iLine = 1 To vbc.CodeModule.CountOfLines
Print #f_out, vbc.CodeModule.Lines(startLine:=iLine, Count:=1)
Next iLine

Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_out
Err.Raise errNo

end_of_sub:

End Sub

' reads source code in a given file into the specified component
' (overwrites any existing code in the component)

Private Sub read_component_code(vbc As Object, f As String)
Dim f_in As Integer
Dim sLine As String
Dim iLine As Long
Dim errNo As Long
On Error GoTo error_exit

vbc.CodeModule.DeleteLines startLine:=1, Count:=vbc.CodeModule.CountOfLines

' vbc.CodeModule.AddFromFile has unpleasant side-effects related to module name
' changes, so we just add the lines one at a time instead:
f_in = freefile()
Open f For Input As #f_in
iLine = 1
Do While Not EOF(f_in) ' read each source code line and insert into component
Line Input #f_in, sLine
vbc.CodeModule.InsertLines iLine, sLine
iLine = iLine + 1
Loop

Close f_in
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_in
Err.Raise errNo

end_of_sub:

End Sub

' Writes out a "cheat sheet" that gives you the original name of each
' obfuscated name in an obfuscated workbook.
'
' The cheat sheet is helpful in debugging obfuscated programs (allows
' you to translate the names that appear on a single obfuscated line,
' etc.).
'
' Assumes that invisible_names list is fully populated.
'

Private Sub write_invisible_names(wb As Workbook, fName As String)
Dim iPair As Long ' index of name, value pair on invisible names list
Dim f_out As Integer
Dim errNo As Long
On Error GoTo error_exit

f_out = freefile()
Open fName For Output As #f_out

Print #f_out, "Hidden" & vbTab & "Original"
For iPair = 1 To invisible_names.Count ' for each name, value pair on invisible names list
Print #f_out, invisible_names(iPair)(VALUE_ID) & vbTab & invisible_names(iPair)(NAME_ID)
Next iPair

Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_out
Err.Raise errNo

end_of_sub:

End Sub

' obfuscates all VBA source code modules, classes and UserForms

Private Sub obfuscate_workbook(wb As Workbook)
Dim vbc As Object
Dim iFile As Integer
Dim tmpFile As String
Dim old_display_status_bar As Boolean
Dim newName As String

old_display_status_bar = Application.DisplayStatusBar
Application.DisplayStatusBar = True

Application.StatusBar = "Saving Invisibly: initializing..."
reset_lookup_table visible_names
reset_lookup_table invisible_names
reset_lookup_table userform_attribute_names
reset_token_buffer
' the E "identifier" appears within numeric literals
' expressed in scientific notation, and thus must never be
' obfuscated (this "non-obfuscation of e" is needed because
' our lexical analysis of numbers is otherwise too simple to
' get numeric literals expressed in scientific notation right).
register_ids "e '#visible"

' register all built-in visible identifiers stored in
' a special text file shipped with the application
' (Excel/VBA keywords and user defined universal keywords)

assert Dir(ThisWorkbook.Path & PS() & IB_VISIBLE_KEYWORDS_FILENAME) <> ""
m_visible_depth = 1
register_identifiers ThisWorkbook.Path & PS() & IB_VISIBLE_KEYWORDS_FILENAME
m_visible_depth = 0

' first pass: store each code module in a temp file,
' register that file's visible identifiers, and then delete
' the code component.

For iFile = 1 To wb.VBProject.VBComponents.Count
Set vbc = wb.VBProject.VBComponents(iFile)
Select Case vbc.Type
Case IB_vbext_ct_StdModule, IB_vbext_ct_ClassModule, IB_vbext_ct_MSForm
' the name of a module, class, or userform is obfuscated
' (normal case). Register the name as "invisible"
m_visible_depth = 0
register_ids "Dim " & vbc.Name ' Dim makes it look like name is "user declared"
Case IB_vbext_ct_Document
' document (e.g. Worksheet) code names remain visible because
' there isn't an easy way to RELIABLY change them
' programmatically (surprisingly, setting vbc.Name doesn't do it)
register_ids vbc.Name & " '#visible"
Case Else
' if Microsoft adds a new type, play it safe by keeping
' names unchanged ("visible").
register_ids vbc.Name & " '#visible"
End Select
Application.StatusBar = "Saving Invisibly: Pass 1 of 2, VBComponent " & CStr(iFile) & " of " & CStr(wb.VBProject.VBComponents.Count)
write_component_code vbc, temp_file_name(wb, iFile)
m_visible_depth = 0 ' invisible unless otherwise noted
reset_token_buffer
register_identifiers temp_file_name(wb, iFile)
Next iFile

define_obfuscated_names 'choose obscure ids for invisible names

' second pass obfuscates by replacing registered, non-visible
' variable ids with meaningless ids, stripping comments, etc, and
' then reading the so-obfuscated code back into each component.

tmpFile = temp_file_name(wb, wb.VBProject.VBComponents.Count + 1)
For iFile = 1 To wb.VBProject.VBComponents.Count
Set vbc = wb.VBProject.VBComponents(iFile)

newName = obfuscated_line(vbc.Name)
' this "if" (to prevent changing name when name isn't obfuscated)
' was added because I don't trust that name changes in such cases, even to the same
' name, are reliable.
If (LCase(newName) <> LCase(vbc.Name)) Then vbc.Name = newName

Application.StatusBar = "Saving Invisibly: Pass 2 of 2, VBComponent " & CStr(iFile) & " of " & CStr(wb.VBProject.VBComponents.Count)
reset_token_buffer
obfuscate_sourcecode_file temp_file_name(wb, iFile), tmpFile
Kill tmpFile
Kill temp_file_name(wb, iFile)
Next iFile

Application.StatusBar = _
"Writing ""secret decoder"" file: " & ib_suffixed_filename(wb, IB_SECRET_DECODER_SUFFIX) & "..."
write_invisible_names wb, ib_suffixed_filename(wb, IB_SECRET_DECODER_SUFFIX)

Application.StatusBar = False ' restore status bar status quo
Application.DisplayStatusBar = old_display_status_bar

End Sub

' If this function returns True, the two strings are guaranteed
' to represent different physical files (regardless of what
' default paths might be added to any file name strings that do not
' have explicitly specified full pathnames)

Private Function are_different_files(f1_in As String, f2_in As String) As Boolean
Dim f1 As String
Dim f2 As String
Dim result As Boolean

f1 = Trim(LCase(f1_in))
f2 = Trim(LCase(f2_in))

If (Not has_prefix(f1, PS())) Then f1 = PS() & f1
If (Not has_prefix(f2, PS())) Then f2 = PS() & f2

' if the last half of either filename string equals the other,
' the filename COULD represent the same physical file
If (has_suffix(f1, f2) Or has_suffix(f2, f1)) Then
result = False
Else
' filenames definitely represent different files
result = True
End If
are_different_files = result
End Function

' obfuscates the given workbook, saving it into the specified file

Public Sub obfuscate_workbook_as(wb As Workbook, fileName As String)

assert are_different_files(wb.fullName, fileName)

' saving under a new name breaks connection with original file,
' assuring that original unobfuscated workbook isn't damaged.
' (even if we crash and user then accidentally saves the
' so-damaged workbook, originally named file is still safe)
wb.SaveAs fileName
obfuscate_workbook wb
wb.SaveAs fileName ' save again under the new name

End Sub

' default filename in which to store "invisible" version
Private Function ib_suffixed_filename(wb As Workbook, suffix As String) As String
Dim dot_position As Integer
Dim result As String
dot_position = last_substring_position(wb.Name, ".")
If (dot_position = 0) Then
result = wb.Path & PS() & wb.Name & suffix
Else
result = wb.Path & PS() & Left(wb.Name, dot_position - 1) & suffix
End If
ib_suffixed_filename = result
End Function

' Save the active workbook invisibly in a user-selected workbook
Private Sub ib_save_invisibly_as()
Dim fileName As String
Dim wb As Workbook
On Error GoTo error_exit

Set wb = ActiveWorkbook
If (Not wb.saved) Then
MsgBox "Workbook """ & ActiveWorkbook.Name & """ has unsaved changes. " & _
"To help prevent accidental source code losses, workbooks " & _
"with unsaved changes cannot be saved invisibly. " & vbNewLine & vbNewLine & _
"Save your original workbook, then try again. ", _
vbCritical, "Workbooks with unsaved changes cannot be saved invisibly."
GoTo end_of_sub
End If
' present a "save as" type filename dialog
fileName = Application.GetSaveAsFilename( _
InitialFilename:=ib_suffixed_filename(wb, IB_FILENAME_SUFFIX), _
FileFilter:="Microsoft Excel Workbook (*.xls),*.xls,All Files (*.*),*.*", _
Title:="Select file into which workbook will be saved invisibly")

' Because there is too much potential for total code loss, we do not
' allow user to overwrite the original workbook with the obfuscated
' workbook:

If (Not are_different_files(wb.fullName, fileName)) Then
MsgBox "The selected filename (" & fileName & _
") must be clearly different from the current workbook's filename (" & wb.fullName & _
"). Try again, next time choosing a different name.", _
vbCritical, "Save Invisibly As Filename Must Differ from Original Filename"
ElseIf (fileName <> "False") Then
obfuscate_workbook_as wb, fileName
End If

GoTo end_of_sub
error_exit:
Application.StatusBar = False ' resume default status bar behavior
MsgBox "Error #" & CStr(Err.Number) & " during ""Save Invisibly As"": " & Err.Description, _
vbCritical, "Invisible Basic Save Invisibly As Error"
end_of_sub:
End Sub

' Top level "Save Invisibly As..." command

Public Sub invisible_basic_save_invisibly_as() '#visible
ib_save_invisibly_as
End Sub

' Top level "Debugging Save Invisibly As..." command

Public Sub invisible_basic_debugging_save_invisibly_as() '#visible
ib_save_invisibly_as
End Sub

Private Sub visit_url(url As String)
ShellExecute GetDesktopWindow(), "Open", url, 0, 0, SW_SHOWMAXIMIZED
End Sub

' Just shows the HTML file that contains the InvisibleBasic help file
Public Sub invisible_basic_show_help() '#visible
visit_url ThisWorkbook.Path & PS() & "InvisibleBasic.html"
End Sub

Public Sub invisible_basic_web_site() '#visible
visit_url INVISIBLE_BASIC_URL
End Sub

MsgBox "Invisible Basic Version " & CStr(INVISIBLE_BASIC_VERSION) & vbNewLine & _
"A Source Code Obfuscator for Excel/VBA" & vbNewLine & _
vbNewLine & _
vbNewLine & _
"Web Site: " & INVISIBLE_BASIC_URL & vbNewLine _

End Sub

Dim cbp As CommandBarPopup ' new invisible basic menu bar
Dim cbb As CommandBarButton ' new menu item added to this bar

Type:=msoControlPopup)

cbp.tooltiptext = _
"Source code obfuscation utility for Excel/VBA applications."

cbb.caption = "&Save Invisibly As..."
cbb.DescriptionText = "Saves copy of workbook whose VBA code is replaced with equivalant, but hard-to-read, code."
cbb.onAction = "invisible_basic_save_invisibly_as"

cbb.caption = "&Debugging Save Invisibly As..."
cbb.DescriptionText = "Same as Save Invisibly As except interleaves original source code as comments (for debugging)."
cbb.onAction = "invisible_basic_debugging_save_invisibly_as"

cbb.caption = "&Help..."
cbb.DescriptionText = "Invisible Basic Help"
cbb.onAction = "invisible_basic_show_help"

cbb.caption = "Invisible Basic &Web Site"
cbb.DescriptionText = "Invisible Basic Web Site"
cbb.onAction = "invisible_basic_web_site"

End Sub

' removes the Invisible Basic menu from Excel
On Error Resume Next
End Sub

' Simple test of Invisible Basic. Test requires that the test
' workbook, IB_Test.xls, be in the same folder as the Add-in is.
'
' The test makes the test workbook invisible, then runs a test
' routine within the (then obfuscated) test workbook.
'
' You may see two "OK to overwrite" prompts (answer Yes)
' and you should see "Hello Invisible Basic" (four times)
' if the test passes. If you don't see "Hello Visible Basic",
' four times, the test has failed.
'
Public Sub ib_test()
Dim wb As Workbook
Dim fTest As String
Dim fObf As String
Dim iPass As Integer

assert event_part("myButton_Click") = "Click"
assert object_part("myButton_Click") = "myButton"
assert event_part("myButtonClick") = ""
assert event_part("myButton_20_Click") = "Click"
assert object_part("myButton_20_Click") = "myButton_20"

For iPass = 1 To 2
If (iPass = 1) Then
Else
End If

fTest = ThisWorkbook.Path & PS() & "IB_Test.xls"
fObf = ThisWorkbook.Path & PS() & "IB_Test_Obf.xls"
' Open the test workbook
Workbooks.Open fTest
Set wb = Workbooks(Workbooks.Count)

' Save it invisibly as a new workbook
obfuscate_workbook_as wb, fObf

' the test module exercies code in the obfuscated modules in IB_Test
' and compares results with expected results.
Evaluate "IBTest.testModule.ibt_test()"
wb.close SaveChanges:=False
Next iPass
End Sub
```

VBA reserved words

Keywords

Keywords are special words that are reserved, because they are used by the compiler to determine the structure of your code, so they cannot be used for variables, or subroutine or user defined function (UDF) names. Also, reserved words are displayed in [Blue] color by default in the Code editor, but not VBA globals, which stay black color.

This table was composed from the VBE object explorer, and broaden with more-info links of two sources, bettersolutions and  excelfunctions blogs. I reordered and grouped the items by their function, so it has a comprehensible structure.

If you want the table I’d created to automate the generation of the needed VBA code, you can grab from this pCloud file.

This is a non exclusive list with Excel reserved words:

``` Abs
Accelerator
Access
AccessMode
Action
Activate
ActivateMicrosoftApp
ActivateNext
ActivatePrevious
ActiveCell
ActiveChart
ActiveDialog
ActivePane
ActivePrinter
ActiveSheet
ActiveWindow
ActiveWorkbook
After
Alias
Alignment
AltStartupPath
AlwaysSuggest
Amount
And
Any
App
AppActivate
Appearance
Append
AppendLast
Application
ApplyDataLabels
ApplyNames
ApplyOutlineStyles
Arc
Arcs
Area
Area3DGroup
AreaGroup
AreaGroups
Areas
Arg0
Arg1
Arg10
Arg11
Arg12
Arg13
Arg14
Arg15
Arg16
Arg17
Arg18
Arg19
Arg2
Arg20
Arg21
Arg22
Arg23
Arg24
Arg25
Arg26
Arg27
Arg28
Arg29
Arg3
Arg30
Arg31
Arg4
Arg5
Arg6
Arg7
Arg8
Arg9
ArgName
Arrange
ArrangeStyle
Array
ArrowNumber
As
Asc
ascb
ascw
Atn
attribute
Attributes
Author
AutoComplete
AutoCorrect
AutoFill
AutoFilter
AutoFilterMode
AutoFit
AutoFormat
Automatic
AutomaticStyles
AutoOutline
AutoPage
AutoScaling
AutoSize
AutoText
AutoUpdate
Axes
Axis
AxisBetweenCategories
AxisGroup
AxisObj
AxisTitle
B
Background
Backward
Bar3DGroup
BarGroup
BarGroups
Base
BasedOn
BaseField
BaseItem
BasicCode
BCCRecipients
Beep
Before
begin
BF
Binary
BlackAndWhite
Blue
Bold
Boolean
Border
BorderAround
Borders
Bottom
BottomMargin
BottomRightCell
BringToFront
Build
BuiltIn
BuiltinDocumentProperties
BuiltInFace
Button
Buttons
ButtonText
By
ByRef
ByRow
ByVal
Calculate
CalculateBeforeSave
Calculation
Call
Caller
Cancel
CancelButton
CanPlaySounds
CanRecordSounds
CapitalizeNamesOfDays
Caption
caption
Case
Category
CategoryLabels
CategoryLocal
CategoryNames
CategoryTitle
CBool
cbyte
CCRecipients
CCur
CDate
CDbl
cdec
CDecl
Cell
Cell1
Cell2
CellDragAndDrop
Cells
CenterFooter
CenterHorizontally
CenterVertically
Centimeters
CentimetersToPoints
ChangeFileAccess
ChangeScenario
ChangingCell
ChangingCells
Channel
Character
Characters
CharCode
Chart
ChartArea
ChartGroup
ChartGroups
ChartObject
ChartObjects
Charts
ChartSize
ChartTitle
ChartWizard
ChartWizardDisplay
ChDir
ChDrive
CheckBox
CheckBoxes
Checked
CheckSpelling
ChildField
ChildItems
choose
Chr
chrb
chrw
CInt
CircularReference
Class
ClassType
Clear
ClearArrows
ClearContents
ClearFormats
ClearNotes
ClearOutline
clientheight
clientleft
clienttop
clientwidth
ClipboardFormats
CLng
Close
Closed
Collate
Color
ColorButtons
ColorIndex
ColorPalette
Colors
Column
Column3DGroup
ColumnAbsolute
ColumnDifferences
ColumnFields
ColumnGrand
ColumnGroup
ColumnGroups
ColumnIndex
ColumnInput
ColumnLevels
ColumnOffset
ColumnRange
Columns
ColumnSize
ColumnWidth
Comma
command
CommandUnderlines
Compare
Comparison
ConflictResolution
ConsecutiveDelimiter
Consolidate
ConsolidationFunction
ConsolidationOptions
ConsolidationSources
Const
Constant
Constants
ConstrainNumeric
Container
ContainsBIFF
ContainsPICT
ContainsRTF
ContainsVALU
Contents
Context
Conversion
Convert
Converter
ConvertFormula
Copies
Copy
CopyFace
CopyFile
CopyFromRecordset
CopyObjectsWithCells
CopyPicture
CopyToRange
Corners
Cos
Count
CreateBackup
CreateNames
CreateObject
CreatePublisher
CreateSummary
Creator
Criteria1
Criteria2
CriteriaRange
Crosses
CrossesAt
CrtBorder
CrtInterior
CSng
CStr
CurDir
Currency
CurrentArray
CurrentPage
CurrentRegion
Cursor
CustomDictionary
CustomDocumentProperties
CustomListCount
Cut
CutCopyMode
CVar
CVDate
CVErr
Data
DataBodyRange
DataEntryMode
DataFields
DataLabel
DataLabelRange
DataLabels
DataRange
DataSeries
DataSeriesIn
DataSheet
DataType
Date
Date1904
datediff
datepart
DateSerial
DateValue
Day
ddb
DDEAppReturnCode
DDEExecute
DDEInitiate
DDEPoke
DDERequest
DDETerminate
Debug
Declare
Default
DefaultButton
DefaultFilePath
DefBool
defbyte
DefCur
DefDate
DefDbl
defdec
DefInt
DefLng
DefObj
DefSng
DefStr
DefVar
Delete
DeleteChartAutoFormat
DeleteCustomList
DeleteNumberFormat
DeleteReplacement
deletesetting
Delimiter
Delivery
Dependents
DepthPercent
Description
Deselect
Destination
DestName
Dialog
DialogBox
DialogFrame
Dialogs
DialogSheet
DialogSheets
Dim
Dir
DirectDependents
Direction
DirectPrecedents
DismissButton
DisplayActiveCell
DisplayAsIcon
DisplayAutomaticPageBreaks
DisplayBlanksAs
DisplayClipboardWindow
DisplayDrawingObjects
DisplayEquation
DisplayFormat
DisplayFormula
DisplayFormulaBar
DisplayFormulas
DisplayFullScreen
DisplayGridlines
DisplayHorizontalScrollBar
DisplayInfoWindow
DisplayNames
DisplayNote
DisplayNoteIndicator
DisplayOutline
DisplayProtection
DisplayRecentFiles
DisplayRightToLeft
DisplayRSquared
DisplayScrollBars
DisplayStatusBar
DisplayVerticalScrollBar
DisplayWorkbookTabs
DisplayZeros
Do
DoEvents
Double
DoubleClick
DoughnutGroup
DoughnutGroups
DoughnutHoleSize
Down
DownBars
Draft
Drawing
DrawingObject
DrawingObjects
Drawings
Drive
DropDown
DropDownLines
DropDowns
DropLines
Duplicate
Each
EarliestTime
EchoOn
Edit
Editable
EditBox
EditBoxes
EditDirectlyInCell
Edition
EditionOptions
EditionRef
Elevation
Else
ElseIf
Empty
EnableAnimations
EnableAutoComplete
EnableAutoFilter
EnableCancelKey
Enabled
EnableOutlining
EnablePivotTable
EnableTipWizard
Enclosures
End
end
EndIf
EndStyle
EntireColumn
EntireRow
environ
EOF
Eqv
Erase
Erl
Err
Error
ErrorBar
ErrorBars
eval
Evaluate
Events
Excel4IntlMacroSheet
Excel4IntlMacroSheets
Excel4MacroSheet
Excel4MacroSheets
ExclusiveAccess
execute
ExecuteExcel4Macro
Exit
Exp
Explicit
Explosion
Expression
Extend
External
ExtraTitle
F
False
Field
FieldInfo
File
FileAttr
FileConverters
FileCopy
FileDateTime
FileFilter
FileFormat
FileLen
Filename
FileNumber
FillAcrossSheets
FillDown
FillLeft
FillRight
FillUp
FilterIndex
FilterMode
Find
FindFile
FindNext
FindPrevious
FirstPageNumber
FirstSliceAngle
FitToPagesTall
FitToPagesWide
Fix
FixedDecimal
FixedDecimalPlaces
Floor
Focus
Font
FontStyle
FooterMargin
For
Format
FormatName
Formula
FormulaArray
FormulaHidden
FormulaLocal
FormulaR1C1
FormulaR1C1Local
Formulas
Forward
ForwardMailer
FreeFile
FreezePanes
From
FromReferenceStyle
FullName
Function
FunctionWizard
fv
Gallery
GapDepth
GapWidth
Get
getallsettings
GetAttr
GetCustomListContents
GetCustomListNum
GetObject
GetOpenFilename
GetSaveAsFilename
getsetting
Global
Goal
GoalSeek
GoSub
Goto
Graph
Green
GridlineColor
GridlineColorIndex
Gridlines
Group
GroupBox
GroupBoxes
GroupBy
GroupLevel
GroupObject
GroupObjects
Groups
HasArray
HasAutoFormat
HasAxis
HasDataLabel
HasDataLabels
HasDropLines
HasErrorBars
HasFormula
HasHiLoLines
HasLegend
HasMailer
HasMajorGridlines
HasMinorGridlines
HasRoutingSlip
HasSeriesLines
HasTitle
HasUpDownBars
Height
HeightPercent
Help
HelpButton
HelpContextID
HelpFile
Hex
Hidden
HiddenFields
HiddenItems
Hide
HiLoLines
HorizontalAlignment
Hour
IconFileName
IconIndex
IconLabel
Id
If
IgnoreRelativeAbsolute
IgnoreRemoteRequests
IgnoreUppercase
iif
IMEStatus
Imp
Import
ImportChart
ImportData
In
Inches
InchesToPoints
Include
IncludeAlignment
IncludeBorder
IncludeFont
IncludeNumber
IncludePatterns
IncludeProtection
Index
IndexLocal
InitialFilename
InnerDetail
Input
InputB
InputBox
InputType
Insert
InsertFile
Installed
InStr
InStrB
Int
Integer
Interactive
Intercept
InterceptIsAuto
Interior
International
Intersect
InvertIfNegative
ipmt
irr
Is
IsArray
IsDate
IsEmpty
IsError
IsGap
IsMissing
IsNull
IsNumeric
IsObject
Italic
Item
Iteration
Justify
Key
Key1
Key2
Key3
Keys
Keywords
Kill
Label
LabelRange
Labels
LargeButtons
LargeChange
LargeScroll
LatestEdition
LatestTime
Launch
LBound
LCase
Left
LeftB
LeftColumn
LeftFooter
LeftMargin
Legend
LegendEntries
LegendEntry
LegendKey
Len
LenB
Length
Let
Lib
LibraryPath
Like
Line
Line3DGroup
LineGroup
LineGroups
Lines
LineStyle
List
ListArray
ListBox
ListBoxes
ListCount
ListFillRange
ListIndex
ListNames
ListNum
Loc
Local
LocationInTable
Lock
Locked
LockedText
LOF
Log
Long
LookAt
LookIn
Loop
LSet
LTrim
MacID
Macro
MacroOptions
MacroType
MacScript
Mailer
MailLogoff
MailLogon
MailSession
MailSystem
MajorGridlines
MajorTickMark
MajorUnit
MajorUnitIsAuto
MajorVersion
MarkerBackgroundColor
MarkerBackgroundColorIndex
MarkerForegroundColor
MarkerForegroundColorIndex
MarkerStyle
MatchByte
MatchCase
MathCoprocessorAvailable
Max
MaxChange
MaxColumns
MaximumScale
MaximumScaleIsAuto
MaxIterations
MaxRows
me
MemoryFree
MemoryTotal
MemoryUsed
Merge
Message
Mid
MidB
Min
MinimumScale
MinimumScaleIsAuto
MinorGridlines
MinorTickMark
MinorUnit
MinorUnitIsAuto
MinorVersion
MinusValues
Minute
mirr
MkDir
Mod
Mode
Module
Modules
Month
MouseAvailable
Move
MoveAfterReturn
MoveAfterReturnDirection
MsgBox
MultiLine
MultiSelect
MultiUse
MultiUserEditing
Name
NameIsAuto
NameLocal
Names
NavigateArrow
NetworkTemplatesPath
new
NewEnum
NewName
NewSeries
NewWindow
Next
NextLetter
Not
Note
NoteText
Nothing
Notify
Now
nper
npv
Null
Number
NumberFormat
NumberFormatLocal
NumCategoryLabels
NumSeriesLabels
Object
Oct
Of
Offset
OLEObject
oleobjectblob
OLEObjects
OLEType
OmitBackground
OmitColumn
OmitRow
On
OnAction
OnCalculate
OnData
OnDoubleClick
OnEntry
OnKey
OnRepeat
OnSave
OnSheetActivate
OnSheetDeactivate
OnTime
OnUndo
OnWindow
Open
OpenText
OperatingSystem
Operation
Operator
Option
Optional
OptionButton
OptionButtons
Or
Order
Order1
Order2
Order3
OrderCustom
OrganizationName
Orientation
Origin
Other
OtherChar
Outline
OutlineFont
OutlineLevel
Output
Oval
Ovals
Overlap
PageBreak
PageBreaks
PageField
PageFields
PageRange
PageSetup
Pane
Panes
PaperSize
ParamArray
Parent
ParentField
ParentItem
ParentItems
ParentShowDetail
ParentWorksheet
Parse
ParseLine
partition
Paste
PasteFace
PasteSpecial
Path
PathName
PathSeparator
Pattern
PatternColor
PatternColorIndex
Period
Periods
Perspective
PhoneticAccelerator
Picture
Pictures
PictureType
PictureUnit
Pie3DGroup
PieGroup
PieGroups
PivotField
PivotFields
PivotItem
PivotItems
PivotTable
PivotTables
PivotTableWizard
Placement
Play
PlotArea
PlotBy
PlotOrder
PlotVisibleOnly
pmt
Point
Points
Position
Post
ppmt
Precedents
PrecisionAsDisplayed
PrefixCharacter
Preserve
Preview
Previous
PreviousSelections
Print
PrintArea
PrintGridlines
PrintNotes
PrintObject
PrintOut
PrintPreview
PrintQuality
PrintTitleColumns
PrintTitleRows
PrintToFile
Priority
Private
Procedure
Prompt
PromptForSummaryInfo
Property
Protect
ProtectContents
ProtectDrawingObjects
Protection
ProtectionMode
ProtectScenarios
ProtectStructure
ProtectWindows
Public
Pushed
Put
pv
qbcolor
Quit
R1C1
Random
Randomize
Range
Range1
Range2
RangeSelection
rate
Recipients
Record
RecordMacro
RecordRelative
Rectangle
Rectangles
Red
ReDim
Reference
ReferenceStyle
RefersTo
RefersToLocal
RefersToR1C1
RefersToR1C1Local
RefersToRange
RefreshDate
RefreshName
RefreshTable
RegisteredFunctions
RegisterXLL
RelativeTo
Rem
Remove
RemoveAllItems
RemoveItem
RemoveSubtotal
Repeat
Replace
Replacement
ReplacementList
ReplaceText
ReportType
Reserved
Reset
ResetTipWizard
Reshape
Resize
Resource
Restore
ResultCells
Resume
Return
ReturnReceipt
ReturnType
ReturnWhenDone
ReversePlotOrder
RevisionNumber
RGB
Right
RightAngleAxes
RightB
RightFooter
RightMargin
RmDir
Rnd
Root
Rotation
RoundedCorners
Route
Routed
RouteWorkbook
RoutingSlip
Row
RowAbsolute
Rowcol
RowDifferences
RowFields
RowGrand
RowHeight
RowIndex
RowInput
RowLevels
RowOffset
RowRange
Rows
RowSize
RSet
RTrim
Run
RunAutoMacros
Save
SaveAs
SaveAsOldFileFormat
SaveChanges
SaveCopyAs
Saved
SaveData
savesetting
ScaleType
Scenario
Scenarios
Schedule
ScreenUpdating
Script
scriptengine
Scroll
ScrollBar
ScrollBars
ScrollColumn
ScrollRow
ScrollWorkbookTabs
SearchDirection
SearchOrder
Second
Seek
Select
Selected
SelectedSheets
Selection
Semicolon
SendDateTime
Sender
SendKeys
SendMail
SendMailer
SendToBack
Series
SeriesCollection
SeriesLabels
SeriesLines
Set
SetAttr
SetBackgroundPicture
SetDefaultChart
SetEchoOn
SetInfoDisplay
Sgn
Shared
Sheet
SheetBackground
Sheets
SheetsInNewWorkbook
Shell
Shift
ShortcutKey
Show
ShowAllData
ShowConflictHistory
ShowDataForm
ShowDependents
ShowDetail
ShowErrors
ShowLegendKey
ShowLevels
ShowPages
ShowPrecedents
ShowRevisionHistory
ShowToolTips
Sin
Single
Size
SizeWithWindow
SkipBlanks
sln
SmallChange
SmallScroll
Smooth
Sort
SortMethod
SortSpecial
SoundNote
Source
SourceData
SourceName
Sources
SourceType
Space
Spc
SpecialCells
Spinner
Spinners
Split
SplitColumn
SplitHorizontal
SplitRow
SplitVertical
Sqr
StandardFont
StandardFontSize
StandardHeight
StandardWidth
Start
StartRow
StartupPath
startupposition
Static
Status
StatusBar
Step
Stop
Str
StrComp
StrConv
Strict
Strikethrough
String
Structure
Style
Styles
Sub
Subject
SubscribeTo
Subscript
Subtotal
Subtotals
SubType
Summary
SummaryBelowData
SummaryColumn
SummaryRow
Superscript
SurfaceGroup
switch
syd
SyncHorizontal
SyncVertical
Tab
Table
TableDestination
TableName
TableRange1
TableRange2
TabRatio
Tan
Template
TemplatesPath
Text
TextBox
TextBoxes
TextLocal
TextQualifier
TextToColumns
Then
ThisWorkbook
TickLabelPosition
TickLabels
TickLabelSpacing
TickMarkSpacing
Time
Timer
TimeSerial
TimeValue
Title
To
ToAbsolute
ToLeft
Toolbar
ToolbarButton
ToolbarButtons
Toolbars
Top
Topic
TopLeftCell
TopMargin
TopRow
ToRecipients
ToReferenceStyle
ToRight
TotalLevels
TotalList
TowardPrecedent
TrackStatus
TransitionExpEval
TransitionFormEntry
TransitionNavigKeys
Transpose
Trend
Trendline
Trendlines
Trim
True
TwoInitialCapitals
Type
TypeName
typeof
UBound
UCase
Underline
Undo
Ungroup
Union
Unique
Unknown
Unlock
Unprotect
Until
Up
UpBars
Update
UpdateFromFile
UpdateRemoteReferences
UsableHeight
UsableWidth
UsedRange
UserInterfaceOnly
UseRowColumnNames
UserStatus
UseStandardHeight
UseStandardWidth
Val
Value
Values
ValueTitle
Variant
VarName
VarType
VaryByCategories
vb_creatable
vb_exposed
vb_name
vb_predeclaredid
vbAbort
vbAbortRetryIgnore
vbApplicationModal
vbArchive
vbArray
vbBoolean
vbByte
vbCancel
vbCritical
vbCurrency
vbDataObject
vbDate
vbDecimal
vbDefaultButton1
vbDefaultButton2
vbDefaultButton3
vbDirectory
vbDouble
vbEmpty
vbError
vbExclamation
vbHidden
vbHiragana
vbIgnore
vbInformation
vbInteger
vbKatakana
vbLong
vbLowerCase
vbNarrow
vbNo
vbNormal
vbNull
vbObject
vbOK
vbOKCancel
vbOKOnly
vbProperCase
vbQuestion
vbRetry
vbRetryCancel
vbSingle
vbString
vbSystem
vbSystemModal
vbUpperCase
vbUserDefinedType
vbVariant
vbVolume
vbWide
vbYes
vbYesNo
vbYesNoCancel
Verb
Version
version
Vertex
VerticalAlignment
Vertices
Visible
VisibleFields
VisibleItems
VisibleRange
Volatile
Wait
Walls
WallsAndGridlines2D
WeekDay
Weight
Wend
What
Where
Which
While
Whole
Width
Window
WindowNumber
Windows
WindowsForPens
WindowState
WindowStyle
With
withevents
Word
Workbook
Workbooks
Worksheet
Worksheets
WrapText
Write
WriteReserved
WriteReservedBy
X1
X2
xl24HourClock
xl3DArea
xl3DBar
xl3DColumn
xl3DEffects1
xl3DEffects2
xl3DLine
xl3DPie
xl3DSurface
xl4DigitYears
xlA1
xlAbove
xlAbsolute
xlAbsRowRelColumn
xlAccounting1
xlAccounting2
xlAccounting3
xlAccounting4
xlAll
xlAllAtOnce
xlAllExceptBorders
xlAlternateArraySeparator
xlAnd
xlArea
xlAscending
xlAutoActivate
xlAutoClose
xlAutoDeactivate
xlAutoFill
xlAutomatic
xlAutomaticUpdate
xlAutoOpen
xlAverage
xlAxis
xlBar
xlBelow
xlBIFF
xlBitmap
xlBlanks
xlBMP
xlBoth
xlBottom
xlBottom10Items
xlBottom10Percent
xlBuiltIn
xlButton
xlByColumns
xlByRows
xlCancel
xlCap
xlCategory
xlCenter
xlCenterAcrossSelection
xlCGM
xlChangeAttributes
xlChart
xlChart4
xlChartAsWindow
xlChartInPlace
xlChartSeries
xlChartShort
xlChartTitles
xlChecker
xlChronological
xlCircle
xlClassic1
xlClassic2
xlClassic3
xlClipboard
xlClipboardFormatBIFF
xlClipboardFormatBIFF2
xlClipboardFormatBIFF3
xlClipboardFormatBIFF4
xlClipboardFormatBinary
xlClipboardFormatBitmap
xlClipboardFormatCGM
xlClipboardFormatCSV
xlClipboardFormatDIF
xlClipboardFormatDspText
xlClipboardFormatEmbeddedObject
xlClipboardFormatEmbedSource
xlClipboardFormatMovie
xlClipboardFormatNative
xlClipboardFormatObjectDesc
xlClipboardFormatPICT
xlClipboardFormatPrintPICT
xlClipboardFormatRTF
xlClipboardFormatScreenPICT
xlClipboardFormatStandardFont
xlClipboardFormatStandardScale
xlClipboardFormatSYLK
xlClipboardFormatTable
xlClipboardFormatText
xlClipboardFormatToolFace
xlClipboardFormatToolFacePICT
xlClipboardFormatVALU
xlClipboardFormatWK1
xlClosed
xlCodePage
xlColor1
xlColor2
xlColor3
xlColumn
xlColumnField
xlColumnItem
xlColumns
xlColumnSeparator
xlColumnThenRow
xlCombination
xlCommand
xlConsolidation
xlConstants
xlContents
xlContinuous
xlCopy
xlCorner
xlCount
xlCountNums
xlCountryCode
xlCountrySetting
xlCrissCross
xlCross
xlCSV
xlCSVMac
xlCSVMSDOS
xlCSVWindows
xlCurrencyBefore
xlCurrencyCode
xlCurrencyDigits
xlCurrencyMinusSign
xlCurrencyNegative
xlCurrencySpaceBefore
xlCurrencyTrailingZeros
xlCustom
xlCut
xlDash
xlDashDot
xlDashDotDot
xlDatabase
xlDataField
xlDataItem
xlDate
xlDateOrder
xlDateSeparator
xlDay
xlDayCode
xlDBF2
xlDBF3
xlDBF4
xlDebugCodePane
xlDecimalSeparator
xlDefaultAutoFormat
xlDelimited
xlDescending
xlDesktop
xlDialogActivate
xlDialogActiveCellFont
xlDialogAlignment
xlDialogApplyNames
xlDialogApplyStyle
xlDialogAppMove
xlDialogAppSize
xlDialogArrangeAll
xlDialogAssignToObject
xlDialogAssignToTool
xlDialogAttachText
xlDialogAttachToolbars
xlDialogAutoCorrect
xlDialogAxes
xlDialogBorder
xlDialogCalculation
xlDialogCellProtection
xlDialogChartTrend
xlDialogChartWizard
xlDialogCheckboxProperties
xlDialogClear
xlDialogColorPalette
xlDialogColumnWidth
xlDialogCombination
xlDialogConsolidate
xlDialogCopyChart
xlDialogCopyPicture
xlDialogCreateNames
xlDialogCreatePublisher
xlDialogCustomizeToolbar
xlDialogDataLabel
xlDialogDataSeries
xlDialogDefineName
xlDialogDefineStyle
xlDialogDeleteFormat
xlDialogDeleteName
xlDialogDemote
xlDialogDisplay
xlDialogEditboxProperties
xlDialogEditColor
xlDialogEditDelete
xlDialogEditionOptions
xlDialogEditSeries
xlDialogErrorbarX
xlDialogErrorbarY
xlDialogExtract
xlDialogFileDelete
xlDialogFileSharing
xlDialogFillGroup
xlDialogFillWorkgroup
xlDialogFilter
xlDialogFindFile
xlDialogFont
xlDialogFontProperties
xlDialogFormatAuto
xlDialogFormatChart
xlDialogFormatCharttype
xlDialogFormatFont
xlDialogFormatLegend
xlDialogFormatMain
xlDialogFormatMove
xlDialogFormatNumber
xlDialogFormatOverlay
xlDialogFormatSize
xlDialogFormatText
xlDialogFormulaFind
xlDialogFormulaGoto
xlDialogFormulaReplace
xlDialogFunctionWizard
xlDialogGallery3dArea
xlDialogGallery3dBar
xlDialogGallery3dColumn
xlDialogGallery3dLine
xlDialogGallery3dPie
xlDialogGallery3dSurface
xlDialogGalleryArea
xlDialogGalleryBar
xlDialogGalleryColumn
xlDialogGalleryCustom
xlDialogGalleryDoughnut
xlDialogGalleryLine
xlDialogGalleryPie
xlDialogGalleryScatter
xlDialogGoalSeek
xlDialogGridlines
xlDialogLabelProperties
xlDialogListboxProperties
xlDialogMacroOptions
xlDialogMailLogon
xlDialogMailNextLetter
xlDialogMainChart
xlDialogMainChartType
xlDialogMove
xlDialogNew
xlDialogNote
xlDialogObjectProperties
xlDialogObjectProtection
xlDialogOpen
xlDialogOpenMail
xlDialogOpenText
xlDialogOptionsCalculation
xlDialogOptionsChart
xlDialogOptionsEdit
xlDialogOptionsGeneral
xlDialogOptionsTransition
xlDialogOptionsView
xlDialogOutline
xlDialogOverlay
xlDialogOverlayChartType
xlDialogPageSetup
xlDialogParse
xlDialogPasteSpecial
xlDialogPatterns
xlDialogPivotFieldGroup
xlDialogPivotFieldProperties
xlDialogPivotFieldUngroup
xlDialogPivotShowPages
xlDialogPivotTableWizard
xlDialogPlacement
xlDialogPrint
xlDialogPrinterSetup
xlDialogPrintPreview
xlDialogPromote
xlDialogProperties
xlDialogProtectDocument
xlDialogPushbuttonProperties
xlDialogReplaceFont
xlDialogRoutingSlip
xlDialogRowHeight
xlDialogRun
xlDialogSaveAs
xlDialogSaveCopyAs
xlDialogSaveNewObject
xlDialogSaveWorkbook
xlDialogSaveWorkspace
xlDialogScale
xlDialogScenarioCells
xlDialogScenarioEdit
xlDialogScenarioMerge
xlDialogScenarioSummary
xlDialogScrollbarProperties
xlDialogSelectSpecial
xlDialogSendMail
xlDialogSeriesAxes
xlDialogSeriesOrder
xlDialogSeriesX
xlDialogSeriesY
xlDialogSetBackgroundPicture
xlDialogSetPrintTitles
xlDialogSheet
xlDialogShowDetail
xlDialogShowToolbar
xlDialogSize
xlDialogSort
xlDialogSortSpecial
xlDialogSplit
xlDialogStandardFont
xlDialogStandardWidth
xlDialogStyle
xlDialogSubscribeTo
xlDialogSubtotalCreate
xlDialogSummaryInfo
xlDialogTable
xlDialogTabOrder
xlDialogTextToColumns
xlDialogUnhide
xlDialogVbaInsertFile
xlDialogVbaProcedureDefinition
xlDialogView3d
xlDialogWindowMove
xlDialogWindowSize
xlDialogWorkbookCopy
xlDialogWorkbookInsert
xlDialogWorkbookMove
xlDialogWorkbookName
xlDialogWorkbookNew
xlDialogWorkbookOptions
xlDialogWorkbookProtect
xlDialogWorkbookTabSplit
xlDialogWorkbookUnhide
xlDialogWorkgroup
xlDialogWorkspace
xlDialogZoom
xlDiamond
xlDIF
xlDifferenceFrom
xlDirect
xlDisabled
xlDistributed
xlDivide
xlDot
xlDouble
xlDoubleAccounting
xlDoubleClosed
xlDoubleOpen
xlDoubleQuote
xlDoughnut
xlDown
xlDownThenOver
xlDownward
xlDrawingObject
xlDRW
xlDXF
xlEditionDate
xlEntireChart
xlEPS
xlErrDiv0
xlErrNA
xlErrName
xlErrNull
xlErrNum
xlErrorHandler
xlErrors
xlErrRef
xlErrValue
xlExcel2
xlExcel2FarEast
xlExcel3
xlExcel4
xlExcel4IntlMacroSheet
xlExcel4MacroSheet
xlExcel4Workbook
xlExclusive
xlExponential
xlExtended
xlExternal
xlFill
xlFillCopy
xlFillDays
xlFillDefault
xlFillFormats
xlFillMonths
xlFillSeries
xlFillValues
xlFillWeekdays
xlFillYears
xlFilterCopy
xlFilterInPlace
xlFirst
xlFitToPage
xlFixedValue
xlFixedWidth
xlFloating
xlFloor
xlFormats
xlFormula
xlFormulas
xlFreeFloating
xlFullPage
xlFunction
xlGeneral
xlGeneralFormatName
xlGray16
xlGray25
xlGray50
xlGray75
xlGray8
xlGrid
xlGridline
xlGrowth
xlGrowthTrend
xlGuess
xlHairline
xlHGL
xlHidden
xlHide
xlHigh
xlHorizontal
xlHourCode
xlIBeam
xlIcons
xlImmediatePane
xlIndex
xlInfo
xlInside
xlInteger
xlInterpolated
xlInterrupt
xlIntlMacro
xlJustify
xlLandscape
xlLast
xlLastCell
xlLeft
xlLeftBrace
xlLeftBracket
xlLeftToRight
xlLegend
xlLightDown
xlLightHorizontal
xlLightUp
xlLightVertical
xlLine
xlLinear
xlLinearTrend
xlList1
xlList2
xlList3
xlListSeparator
xlLocalFormat1
xlLocalFormat2
xlLocalSessionChanges
xlLogarithmic
xlLogical
xlLong
xlLotusHelp
xlLow
xlLowerCaseColumnLetter
xlLowerCaseRowLetter
xlMacintosh
xlMacrosheetCell
xlManual
xlManualUpdate
xlMAPI
xlMax
xlMaximized
xlMaximum
xlMDY
xlMedium
xlMetric
xlMicrosoftAccess
xlMicrosoftFoxPro
xlMicrosoftMail
xlMicrosoftPowerPoint
xlMicrosoftProject
xlMicrosoftSchedulePlus
xlMicrosoftWord
xlMin
xlMinimized
xlMinimum
xlMinusValues
xlMinuteCode
xlMixed
xlModule
xlMonth
xlMonthCode
xlMonthNameChars
xlMove
xlMoveAndSize
xlMovingAvg
xlMSDOS
xlMultiply
xlNarrow
xlNext
xlNextToAxis
xlNo
xlNoButtonChanges
xlNoCap
xlNoChange
xlNoChanges
xlNoDockingChanges
xlNoDocuments
xlNoMailSystem
xlNoncurrencyDigits
xlNone
xlNonEnglishFunctions
xlNormal
xlNorthwestArrow
xlNoShapeChanges
xlNotes
xlNotPlotted
xlNotYetRouted
xlNumber
xlNumbers
xlOff
xlOLEEmbed
xlOn
xlOneAfterAnother
xlOpaque
xlOpen
xlOpenSource
xlOr
xlOtherSessionChanges
xlOutside
xlOverThenDown
xlPageField
xlPageItem
xlPaper10x14
xlPaper11x17
xlPaperA3
xlPaperA4
xlPaperA4Small
xlPaperA5
xlPaperB4
xlPaperB5
xlPaperCsheet
xlPaperDsheet
xlPaperEnvelope10
xlPaperEnvelope11
xlPaperEnvelope12
xlPaperEnvelope14
xlPaperEnvelope9
xlPaperEnvelopeB4
xlPaperEnvelopeB5
xlPaperEnvelopeB6
xlPaperEnvelopeC3
xlPaperEnvelopeC4
xlPaperEnvelopeC5
xlPaperEnvelopeC6
xlPaperEnvelopeC65
xlPaperEnvelopeDL
xlPaperEnvelopeItaly
xlPaperEnvelopeMonarch
xlPaperEnvelopePersonal
xlPaperEsheet
xlPaperExecutive
xlPaperFanfoldLegalGerman
xlPaperFanfoldStdGerman
xlPaperFanfoldUS
xlPaperFolio
xlPaperLedger
xlPaperLegal
xlPaperLetter
xlPaperLetterSmall
xlPaperNote
xlPaperQuarto
xlPaperStatement
xlPaperTabloid
xlPaperUser
xlPart
xlPCT
xlPCX
xlPercent
xlPercentDifferenceFrom
xlPercentOf
xlPercentOfColumn
xlPercentOfRow
xlPercentOfTotal
xlPIC
xlPICT
xlPicture
xlPie
xlPivotTable
xlPlaceholders
xlPlotArea
xlPLT
xlPlus
xlPlusValues
xlPolynomial
xlPortrait
xlPower
xlPowerTalk
xlPrevious
xlPrimary
xlPrinter
xlProduct
xlPublisher
xlPublishers
xlR1C1
xlReference
xlRelative
xlRelRowAbsColumn
xlRight
xlRightBrace
xlRightBracket
xlRoutingComplete
xlRoutingInProgress
xlRowField
xlRowItem
xlRows
xlRowSeparator
xlRowThenColumn
xlRTF
xlRunningTotal
xlScale
xlScreen
xlScreenSize
xlSecondary
xlSecondCode
xlSelect
xlSemiautomatic
xlSemiGray75
xlSendPublisher
xlSeries
xlShared
xlShort
xlShowLabel
xlShowLabelAndPercent
xlShowPercent
xlShowValue
xlSimple
xlSingle
xlSingleAccounting
xlSingleQuote
xlSolid
xlSortLabels
xlSortValues
xlSquare
xlStack
xlStandardSummary
xlStar
xlStDev
xlStDevP
xlStError
xlStretch
xlStrict
xlSubscriber
xlSubscribers
xlSubtract
xlSum
xlSYLK
xlSyllabary
xlTableBody
xlTemplate
xlText
xlTextBox
xlTextMac
xlTextMSDOS
xlTextPrinter
xlTextValues
xlTextWindows
xlThick
xlThin
xlThousandsSeparator
xlTIF
xlTiled
xlTimeSeparator
xlTitleBar
xlToLeft
xlToolbar
xlToolbarButton
xlTop
xlTop10Items
xlTop10Percent
xlTopToBottom
xlToRight
xlTransparent
xlTriangle
xlUp
xlUpperCaseColumnLetter
xlUpperCaseRowLetter
xlUpward
xlUserResolution
xlVALU
xlValue
xlValues
xlVar
xlVarP
xlVertical
xlVeryHidden
xlVisible
xlWait
xlWatchPane
xlWeekday
xlWeekdayNameChars
xlWhole
xlWide
xlWindows
xlWJ2WD1
xlWK1
xlWK1ALL
xlWK1FMT
xlWK3
xlWK3FM3
xlWKS
xlWMF
xlWorkbook
xlWorkbookTab
xlWorks2FarEast
xlWorksheet
xlWorksheet4
xlWorksheetCell
xlWorksheetShort
xlWPG
xlWQ1
xlX
xlXYScatter
xlY
xlYear
xlYearCode
xlYes
xlZero
Xor
XPos
XValues
XYGroup
XYGroups
Y1
Y2
Year
YPos
Zoom
ZOrder
Checkbox
CommandButton
ComboBox
Frame
Image
Label
ListBox
MultiPage
OptionButton
RefEdit
ScrollBar
SpinButton
TabStrip
TextBox
ToggleButton
UserForm
Sheet
Chart
_setfocus
_afterupdate
_beforedragover
_beforedroporpaste
_beforeupdate
_change
_click
_dblclick
_enter
_exit
_error
_keydown
_keyup
_keypress
_mousedown
_mouseup
_mousemove
_removecontrol
_spinup
_spindown
_layout
_dropbuttonclick
_deactivate
_initialize
_queryclose
_terminate
_Value
_Caption
_Picture
_Visible
_List
_Text
jan
feb
mar
apr
may
jun
jul
aug
sep
oct
nov
dec
January
February
March
April
May
June
July
August
September
October
November
December
vb_globalnamespace
AM
PM
collection
Byte
assert
shape
vbBack
vbCr
vbCrLf
vbFormFeed
vbLf
vbNewLine
vbNullChar
vbNullString
vbObjectError
vbTab
vbVerticalTab
vbBinaryCompare
vbDatabaseCompare
vbTextCompare
Workbook_Activate
Workbook_AfterXmlExport
Workbook_AfterXmlImport
Workbook_BeforeClose
Workbook_BeforePrint
Workbook_BeforeSave
Workbook_BeforeXmlExport
Workbook_BeforeXmlImport
Workbook_Deactivate
Workbook_NewSheet
Workbook_Open
Workbook_PivotTableCloseConnection
Workbook_PivotTableOpenConnection
Workbook_SheetActivate
Workbook_SheetBeforeDoubleClick
Workbook_SheetBeforeRightClick
Workbook_SheetCalculate
Workbook_SheetChange
Workbook_SheetDeactivate
Workbook_SheetPivotTableUpdate
Workbook_SheetSelectionChange
Workbook_Sync
Workbook_WindowActivate
Workbook_WindowDeactivate
Workbook_WindowResize
Excel
Office
MsoSyncEventType
xmlMap
XlXmlImportResult
XlXmlExportResult
Worksheet_Activate
Worksheet_BeforeDoubleClick
Worksheet_BeforeRightClick
Worksheet_Calculate
Worksheet_Change
Worksheet_Deactivate
Worksheet_PivotTableUpdate
Worksheet_SelectionChange
Chart_Activate
Chart_BeforeDoubleClick
Chart_BeforeRightClick
Chart_Calculate
Chart_Deactivate
Chart_DragOver
Chart_DragPlot
Chart_MouseDown
Chart_MouseMove
Chart_MouseUp
Chart_Resize
Chart_Select
Chart_SeriesChange
VBProject
VBComponents
VBComponent
CodeModule
Raise
startLine
CountOfLines
InsertLines
DeleteLines
Comment
go
```

Saving a Spreadsheet Range as a image file

The following code will save a spreadsheet range as a bitmap:

```Option Explicit

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Const CF_BITMAP = 2
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As PicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GetClipboardData Lib "user32"  _
(ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Sub SaveImage(rng As Range, strFileName As String)
Dim hwnd As Long
Dim hPtr As Long
hwnd = FindWindow("xlmain", Application.Caption)
rng.CopyPicture xlScreen, xlBitmap
OpenClipboard hwnd
hPtr = GetClipboardData(CF_BITMAP)
SavePicture CreateBitmapPicture(hPtr), strFileName
CloseClipboard
End Sub

Function CreateBitmapPicture(ByVal hBmp As Long) As IPicture
Dim lngR As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid

With IID_IDispatch
.Data1 = &H20400;
.Data4(0) = &HC0;
.Data4(7) = &H46;
End With

With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
End With

lngR = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
Set CreateBitmapPicture = IPic
End Function

```

To use it pass the range you want to display and a filename to use e.g.

```SaveImage Sheet1.Range("A1:A8"), "C:Documents and settingsmarkdesktoptest.bmp"

```

Incidentally if you used VB6 and compiled to a COM addin you would only need:

`SavePicture Clipboard.GetData(vbCFBitmap), "C:Documents and settingsmarkdesktoptest2.bmp"`
If we want to save as JPG file
```Sub SelectedRangeToImage()
Dim tmpChart As Chart
Dim n As Long
Dim shCount As Long
Dim sht As Worksheet
Dim sh As Shape
Dim fileSaveName As Variant
Dim pic As Variant
'Create temporary chart as canvas
Set sht = Selection.Worksheet
Selection.Copy
sht.Pictures.Paste.Select
Set sh = sht.Shapes(sht.Shapes.Count)
tmpChart.ChartArea.Clear
tmpChart.Name = "PicChart" & (Rnd() * 10000)
Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
tmpChart.ChartArea.Width = sh.Width
tmpChart.ChartArea.Height = sh.Height
tmpChart.Parent.Border.LineStyle = 0
'Paste range as image to chart
sh.Copy
tmpChart.ChartArea.Select
tmpChart.Paste
'Save chart image to file
fileSaveName = Application.GetSaveAsFilename(fileFilter:="Image (*.jpg), *.jpg")
If fileSaveName <> False Then
tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
End If
'Clean up
sht.Cells(1, 1).Activate
sht.ChartObjects(sht.ChartObjects.Count).Delete
sh.Delete
End Sub
```

VBA UserForms

Contents:

Caveats… Please note that this is not “Excel VBA 101” – I assume you are already familiar with VBA and in particular Excel. I developed this primarily for Excel 2000 and 2002/XP, and some parts are not applicable to Excel 97.

Thanks… to everybody who helped with proofreading, debugging and other suggestions.

Introduction – What is a userform?

A userform is a custom dialogue box that you can use when MsgBox and InputBox are just not enough. Userforms can be used for displaying as well as inputting data. You could even build an entire user interface using userforms, and never let the user touch the spreadsheet itself.

Most of the things that you can see in Windows dialogue boxes can be replicated in userforms – commandbuttons, option buttons, checkboxes, textboxes, comboboxes – plus a whole lot of other, more rarely used controls like graphs, calendars, etc.

This tutorial is an introduction to basic userform concepts, as well as commonly used userform techniques. I’ll explain some of the more general ideas “verbally”, but I’m also including a sample file where you can see how it all works in practice, so the tutorial text itself won’t have many code samples.

I’ve put this together mainly for Excel, but the principles (and most of the code) would also apply to other MS Office applications. The main difference would be in the parts that transfer data between userform and your document.

Getting started

1. Create a form. Open the Visual Basic Editor (Tools…Macros… or Alt+F11). Add a userform by choosing Insert…Userform from the menu bar, or right-click in the project explorer and do the same thing from there.
2. Add controls. When you create a userform, a new floating toolbox window will appear, called the Controls Toolbox. (If it doesn’t, you can find it in the View menu.) This shows the most common types of controls. Click on one that you like, and simply draw the control in your userform.
3. More controls. Many more controls are available but not immediately visible. Right-click on the Controls Toolbox and choose Additional Controls. You can add calendars, spreadsheets, graphs, etc.
4. Add event procedures. Events allow the form and its controls to respond to what the user does. Event procedures sit in the code module associated with the userform (its class module). You can access the code by double-clicking on the form/control, or right-clicking on the form/control and choosing “View Code”, or right-clicking on its icon in the project explorer. See the events below.
5. Show the form. To show the userform, open the form’s class module and hit F5, like you’d do for running a macro, or click the Play button on the toolbar. Note that pressing F5 in a class module does not run the sub that your cursor is in, but the userform itself.
6. Debug. As with macros, F8 allows you to step through the code line by line.

Forms toolbar controls vs. Control toolbox controls

If you have used controls in Excel, you may have used controls from the Forms toolbar, rather than the Controls toolbox. The two sometimes look very similar, but work quite differently behind the scenes. Ozgrid has a fairly good overview of the differences.

Finding out more

If you want to know more after reading this tutorial, there are three easy ways:

1. The example file I’ve included. It has examples for the commands I’ve mentioned here, in particular all the FAQs, and some more.
2. Help. The VBA help files for userform-related commands are fairly good. Take a look at their examples, too.
3. Object browser (F2). Shows you what properties and methods are available for a certain object. Pressing F1 here shows the Help section for that object/method/property.

Properties

Forms and controls have properties (like size, location, etc). You can change these while setting up the form, and most of them can also be changed at runtime (via code). The values you choose while setting up the form will be default values, and runtime changes will only be valid while the form is loaded (see Life cycle of a form below).

The two most important properties of objects are .Name and .Value:

• Name is useful for referring to the controls. You can refer to controls by their index number, but that yields code that is difficult to understand and debug, so using names is generally preferable.
• Value is what you use to actually input or output data. Value means slightly different things for different controls – for optionbuttons and checkboxes it is True/False, for textboxes the text they contain, etc. Value can be used both for input and for output.

For example:

```txtFirstName.Text = Range("A1").Value
Range("B1").Value = optVegetarian.Value

```

A good habit

Give your forms and controls descriptive and systematic names. You’ll often find it helpful to give each type of control a prefix: frm for forms (frmMain and frmDetails), opt for option buttons etc. This makes your code easier to read, and also allows you to use some techniques that would otherwise be more complicated (see Looping through controls below).

http://www.xoc.net/standards/rvbanc.asp has a lot more detail on naming variables and objects.

Referring to controls and forms, and Me

When referring to the controls of a userform from code in its class module, you can refer to them by name: txtFirstName.Value = “John”. For controls in other userforms, the name of the control is preceded by the name of the form (e.g. frmEmployees.lstDepartments).

The same approach is valid for public variables declared in the form’s class module – these behave essentially as properties of the form (e.g. frmInputs.AllDone). Note that you cannot declare a variable as Global in the class module of a userform.

Me is a shortcut for referring to the userform from its class module (e.g. Me.Height). For example, referring to TextBox1 in UserForm1:

```
Me.TextBox1.Text ="Example"
'in the userform's class module, or:
UserForm1.TextBox1.Text ="Example"
'in a different module

```

The life cycle of a userform – showing and closing, etc.

To show your form manually, press F5 in the form window or in its class module. If there is a Userform_Initialize procedure in the module (see Events), that will run first.

To show and hide your form via code (for example, you might want a commandbutton on frmIntro to hide frmIntro and show frmMain instead), use the .Show and .Hide methods.

Behind the scenes, there’s more than just showing and hiding going on. Before a form is shown, it needs to be loaded into memory. If you show a form that hasn’t been loaded, it will load automatically.

Indeed, any reference to the form, or to a variable or control or property of the form, will force it to load, and therefore trigger the Initialize event.

If you want to initialise the form without showing it, you can load it like this:

```Load frmMain

```

After hiding a form, it will still be loaded. If you show it again, the Initialize procedure will not run again. (The Activate procedure will, however.) To clear the form from memory, you have to unload it. When the user closes a form with the close button, the form is automatically unloaded.

So the sequence is: Load – Show – … – Hide – Unload.

Unload clears all variables in the form’s module – it is comparable to stopping a procedure. Any values that the user has entered will be lost, and controls will revert to their default values that you have entered using the Properties window. If you want to save their values, you need to do so before unloading the form.

Modal vs modeless

Forms can be shown in one of two “modes” – modal or modeless. Modal forms do not allow the user to do anything else in Excel while the form is visible – like a MsgBox. Modeless forms allow the user to move around in Excel, do other things, and then return to the form.

Forms can be shown in one of two “modes” – modal or modeless. Modal forms do not allow the user to do anything else in Excel while the form is visible – like a MsgBox. Modeless forms allow the user to move around in Excel, do other things, and then return to the form.

Code execution will also continue in the background while a modeless form is shown. You can make your code wait until the form has been closed using a loop that checks whether the form has been closed:

```
Do Until frmOther.Visible = False
DoEvents
Loop

```

The default setting is modal (NB: the opposite of the case in VB6). Once a form is shown as modal, you cannot change it to modeless – you have to hide the form and then show it again, specifying that you want it modeless.

Modeless forms are only available from Excel2000 onwards.

Events

This is where things get interactive. Events allow the form and its controls to respond to what the user does. You are probably familiar with events from Excel VBA – Workbook_Open, Worksheet_Change etc. While you can do a lot in Excel without events, forms are pretty useless without them.

• Common events for forms include Initialize, Activate, QueryClose, and Click.
• Common events for controls include AfterUpdate, Change, Click, Enter and Exit.

To insert an event procedure, right-click on the object and choose “View code”. An event procedure is created automatically for that control’s standard event. To create a procedure for a different event, choose the event you want from the drop-down menu at the top right of the VBE window. Alternatively, go to the form’s class module and choose the object from the left drop-down and the event from the right drop-down.

Userform_Initialize

The most important event for forms is the Initialize event. Initialize is pretty much the first thing that happens to a form – the Initialize event is triggered as soon as the form starts loading, either because it is called by code or by the user (by hitting F5 or F8).

This is where you would initialise variables and controls. For example, you can update textboxes with latest values from the spreadsheet, change the default value of a textbox to today’s date, etc.

QueryClose and Terminate

The equivalent “end of life” events for a form are two: QueryClose and Terminate. QueryClose occurs first, and gives you the chance to cancel it (and not close the form); Terminate is final and not possible to cancel.

So the sequence of events is: Initialize – …- QueryClose – Terminate.

Userform_Activate

If you hide a form without unloading it, and then show it again, Initialize won’t run again. Instead, the Activate event occurs. Activate is triggered every time the form gets focus. This happens each time the form is shown. If you have several forms visible at the same time, the Activate event is also triggered every time you switch between forms.

Events with parameters

As with Excel events, some events have parameters, which give you more information about how and why the event was triggered – the UserForm_KeyDown event tells you which key was pressed, etc. When you create an event procedure for one of those events using the drop-down menus in VBE, the procedure is automatically set up to properly capture all the parameters.

Some parameters are read-only, whereas others are read/write. For example, the Userform_QueryClose event, which occurs before a form is closed, has a Cancel parameter. Setting Cancel = True within the procedure cancels the event, and the form is not closed.

FAQ: How can I pass data between userforms?

There are two main approaches to passing data between forms. Either you pass data directly from form to form (which means that the two forms are loaded in memory simultaneously) or you store the data somewhere and then access it later from the other form.

Passing from form to form can be done from either the “source” form or the “target” form. Remember that this has to be done before the source form is unloaded. Also remember that when referring to controls in another form, you need to specify the form name:

```txtName.Value = frmTheOtherForm.txtName.Value

```

Passing data directly from form to form will trigger the Initialize event of the other form (unless that form is already visible) since you are referencing its controls’ properties. If the Initialize event procedure in its turn includes code that shows the form, or calls other subs, this can easily trigger a lot of code, and get difficult to debug, so I’d use this approach with relatively simple forms only.

In comparison, storing the data in a variable allows more flexibility and control. The data could be stored either in a public variable, in a worksheet cell (so that it can be saved when the file is closed) or in a name in the worksheet.

The sample file has examples of both approaches.

FAQ: How can I do … with all the … in my form?

For example, how can I add up the values of all textboxes? uncheck all checkboxes? etc.

You can loop through all the controls in your form, pick out those that are of the right type, and apply the relevant code to those.

As with most things, there are several ways of doing this… using TypeName, TypeOf or control names.

TypeName()

TypeName returns a string – “TextBox” for textboxes, “CommandButton” for commandbuttons etc. The typename of a control is generally the same as the control’s default name & caption, but without the number. For example, when you add a new textbox to your form, it is called TextBox1 by default.

TypeName is case-sensitive, and if you make a typo, you get no error message – the code simply won’t work properly.

TypeOf

TypeOf is a fancier way of doing the same thing. Instead of a string, it returns the object type directly, referencing the object library. You can find the library and type of an object through the Object Browser. For example, the type of a textbox is MSForms.Textbox.

The main practical advantage of TypeOf is that it makes your code easier to debug. Typos get caught when you try to compile the module, and TypeOf supports Intellisense – start typing If TypeOf ctl Is, and you’ll get a dropdown list with all the available choices.

“If TypeOf … Is … Then” is considered a special case of If statements, and is covered in VBA help under If.

Control name

If you have named your controls consistently, you can use the Name property to identify them, with the help of the Left() function. This “low-tech” approach is somewhat more flexible – you could use this to identify a subset of all textboxes. If, for example, your form has 10 textboxes (txtTeamName, txtTeamNumber, txtMember1, txtMember2, …, txtMember10) you could use this approach to identify and empty all textboxes whose name starts with txtMember.

Examples

The three alternative If statements in this example would all achieve more or less the same thing (assuming the names of your textboxes all start with “txt”):

```
Dim ctl As Control
For Each ctl In Me.Controls
If TypeOf ctl Is MSForms.Textbox Then
'or
'If TypeName(ctl) ="TextBox" Then
'or
'If Left(ctl.Name, 3) ="txt" Then
'do something with the textbox
ctl.Text ="Hello"
End If
Next ctl

```

There’s an example in the sample file above, too.

FAQ: How can I get data into my listbox?

RowSource

You can link a listbox directly to a range in your worksheet. This is similar to having a listbox in the worksheet. Any changes you make to that range will immediately be reflected in the listbox. The link is read-only: you cannot change items in the listbox to change the worksheet.

Note that the parameter for RowSource is a string and not a range:

```lstNames.RowSource = Range("Names").Address

```

List / Column

You can set list items using the List and Column properties. The two are essentially the same, except for their orientation: the syntax is List(row, column) and Column(column, row). Both can be used to copy an entire array to the listbox, or to set individual items.

```lstNames.List = Range("Names").Value

```

AddItem adds a single row to the listbox, and can put a value in the first column of the new row. For multicolumn listboxes, you’ll have to use List or Column to put in values in the rest of the columns.

```With lstNames
.List(0, 0) ="John"
.List(0, 1) ="Smith"
End With

```

You’ll find examples of all these three methods in the sample file.

FAQ: How can I create a progress bar for my loop?

One easy way to create a progress bar is to create a form with two labels (call them lblBackground and lblProgressBar for example). Make lblBackground as wide as you want the progress bar to be, and set the width of lblProgressBar equal to 0 to start with. Also make sure that lblProgressBar is in front of lblBackground. Then increase the width of lblBar as you run the loop.

```Me.lblProgressBar.Width = p * Me.lblBackground.Width
'where p is the proportion of the loop that's done, for example 0.75

```

Again, there’s an example in the sample file.

VBA Code Compilers

First point to state is the VBA SDK 6.x site, on how to upgrade Visual Basic 6
to Visual Basic 6.5 with VBA’s SDK + VB.NET. Don’t know where it came from, but looks really insteresting. You can get your own VBA system on your application.
Then, there is this book (avaliable at the archive.org library), about hardcore of Visual Basic. It really exposes harcore for VB, like raw COM creation… and other weird things like that. I get to this following this post, and before that I was pursuing the Nativecode thing that is exposed there, from the Unviewable application. Also it seems that this also shares some kind of operation.
Orlando has always get me wondering how he get’s Excel to EXE compiled, and some other nice tools.
Want to get the most on Office VBA?, then borrow this book, avaliable via the archive.org library.
Following is a recopilation of what comercial software can do right now in Excel workbook protection tools, focused on the base features of the products which affect the security and misbehavior of protected solutions.
There are other decompilers for VBA:
• To simply unlock the xls/xlsm file, just go here.
• https://github.com/bontchev/pcodedmp

For Visual Basic programs compiled to .NET (e.g. with Visual Studio .NET 2003 or later), see DotNetDecompilers.

• https://www.decalage.info/vba_tools and http://decalage.info/vba_emulation
• JosephCo wrote a decompiler called Exdec.
• VBDis 3/4/5 by DoDi. Version 3 (for VB version 3) was the most successful, because it has the most information in the “executable” (including comments!). VBDis 3 is available from this page.
• Decompiler Technologies (formerly Visual Basic Right Back) is a decompilation service.
• http://www.vb-decompiler.com: VB Decompiler Forum. Even includes some specifics on building a VB5/VB6 decompiler.
• http://www.vb-decompiler.org: decompiles pcode, “high level assembler” for native code. Proprietary software, but free (as in beer) “Lite” version is available.
• VBDE by Iorior dumps GUI information about VB executables; some decompilation ability
• WKTVBDebugger VB debugger by WTK
• http://www.decompiler-vb.netVBReFormer is a decompiler for native Visual Basic applications. It shows design code data (forms, controls, etc.), allows the modification of design properties directly on the binary, can disassemble native code, and can decompile native code (as much as that is possible).
• Another one here, http://www.vbdecompiler.co.uk/
• VBEditor by Hexman recovers Gui Information
• R.A.C.E. by Sarge recovers Gui Information, and P-Code opcodes.
• P32Dasm by Darker is a P-Code decompiler which decompiles to P-Code tokens.
• Semi VB Decompiler by vbgamer45 recovers gui information, and P-Code tokens. For VB 5 and 6. Does not recompile native code.
• VB Parser – Recovers P-Code tokens.
• VBRezQ recovers the project file and forms.
• http://vbdebug.cjb.net for a Visual Basic debugger (p-code programs only) by Mr Silver and Mr Snow.
• VB Shrink by Cute-Bits is a tool that strips non essential info from the executable, to make it more difficult to decompile
• VB EXE Obfuscator by Jory
• Decompiler Defeater (see DeFeater)
• Visual Basic MAK Compiler Pro (aka make_mak) by Christian Germelmann has a check box decompDefeat; the author claims “your apps will be immune against ‘reverse engeneering'”.
• See also Master the Black Art of the VB Interpreter, Ash Rofail. In Visual Basic Programmer’s Journal, Dec 1996, pp 58-64.
• The paper Visual Basic Reversed – A decompiling approach by Andrea Geddon has lots of details about the internals of VB5 and VB6 native (machine code) compiled programs. This is not a peer reviewed academic paper, and is written from a cracking point of view.
• decompiler.com (bad link!) had some good links on this page, now only available from archive.orghttp://www.decompiler.com/viewtopic.php?t=2 (from the Software Reviews forum, Software Listings topic). There was also other good information in forums and the like; this site was heavily Visual Basic oriented. Several tools were available for download. Offline since late 2003.

Digiwise’s Post:

WhiteHatXL’s analysis:

DataSafeXL:
PROS: A newbie in Excel cannot reach the content of the protected workbook.
CONS: The product is programmed in vba. The tool relies on standard MS Excel protection methods like workbook/worksheet protection and vba project password plus the vba code obfuscating. You do not need to be C programmer to pass over such protection.
“For maximum VBA security, use the Microsoft Excel 2007-2010 format (“.xlsm”) and add a VBA password to your file which contains random alphanumeric characters and is at least 15 characters long.”
This advice from their help file just kills me!
Looks like the guy who wrote this product has been learning vba programming by the way.
SUMMARY: Junk. The product is on a student project level.Spreadsheet Sentry:
PROS: The tool is programmed in C++, uses strong encryption to protect formulas in cells. In protected solution formulas are encrypted, stored in cells and not readable.
CONS: Takes WAY too much time to encode a workbook even for middle size model.
Protected solutions work veeeery sloooow. Calculation time is wasted for encryption/decryption every formula in calculation chain.
The tool doesn’t protect VBA code.
SUMMARY: Protection works. The tool appropriates for small workbooks without VBA macros.LockXLS:
This is the most controversial product in the review. After the first glance I wanted to give “the perfect” mark, but see what I have finally found ….
PROS: The tool is programmed in C++. In protected solution everything works like in original workbook. Average user cannot see formulas in cells and vba code in protected workbook. Protects xla files. Lots of features.
CONS: The product uses unmodified, original workbooks in protected solutions and relies on hackers’ methods to take customer away from seeing the content of the workbook (Hooks Excel windows and blocks Excel’s COM objects methods calls). The tool is trying to stub all Excel’s security breaches, which is impossible with an unmodified, original workbook.
When a protected solution has been started on an end customer computer, the spreadsheet becomes as unprotected as newborn baby.
5 lines of C code extract the original workbook from the protected solution, doesn’t matter whether it’s xls or exe file.
To prove the vulnerability of LockXLS solutions, just e-mail a protected solution to WhiteHatXL at yahoo dot com , the original workbook will be returned.
SUMMARY: Fake. This product is not for a workbook protection.Secure Calc (former ExcelShield):
These guys have ignored my requests for a trial version, so I have evaluated the product by the simple example from their site—It may work different for complex spreadsheets.
PROS: The tool uses strong encryption for formulas, removes formulas from cells, has calculation engine to evaluate protected formulas.
CONS: Engine is written in .NET environment in pure managed code, which is not good for a protection tool. Source code may be reached by Reflector and reverse engineered. No VBA Protection.
The calc engine is not included into protected solution and should be preinstalled on customer computer separately. Each time, after typing new data into cell, the customer has to click the ‘Calculate’ button, which is available through the main Excel menu. This is very annoying.
SUMMARY: Protection works. It looks good enough, if you do not need to protect vba code.xCell Compiler:
PROS: The tool is programmed in C++, compiles formulas into binary code and removes them from cells, protects vba code. Has calculation engine to evaluate protected formulas. Has a lot of features.
CONS: The tool has limitations declared on their web site. A protected solution doesn’t support adding/removing columns/rows/sheets. Sorting for ranges with formulas doesn’t work.
SUMMARY: Protection works. Good, if you do not use features mentioned in limitations.

Excel Translator:
I was unable to get the neither trial version nor example of protected workbook. Very “strong” protection!

Converter XL to Exe:
PROS: Free, Free, Free!!!
CONS: This tool is not for a workbook protection.
SUMMARY: Toy.