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:

https://www.youtube.com/watch?v=irbshkdVFao

Here the author points out the three basic problems that are not usually considered with collisions:

  • excessive computations (dt too small, that’s when no collisions at fixed time increments)
  • miss collisions (dt too large, that’s when space travelled at one fixed time increment is larger than the collision range for two particles)
  • lack of position precission when calculating the collisions at fixed spaced moments.

More equations and explanation is given at this site.

Further on, it could be brought some attention to drag resistance, and even Magnus effects, in order to refine the precission of the movements.

Following is some of the Physic functions already implemented:

Option Explicit

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

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

Public Function fXYZ(Optional ByVal X As Double = 0, _
                     Optional ByVal Y As Double = 0, _
                     Optional ByVal Z As Double = 0) As tXYZ
    With fXYZ
        .X = X
        .Y = Y
        .Z = Z
    End With
End Function

Public Function fVector(Optional ByVal dbModule As Double = 0, _
                        Optional ByVal ß As Double = 0, _
                        Optional ByVal Ø As Double = 0) As tXYZ
    With fVector
        .X = (dbModule * Cos(ß) * Cos(Ø))
        .Y = (dbModule * Cos(ß) * Sin(Ø))
        .Z = (dbModule * Sin(ß))
    End With
End Function

Public Function fVectorModule(ByRef oVector As tXYZ) As Double
    With oVector
        fVectorModule = VBA.Sqr(.X ^ 2 + .Y ^ 2 + .Z ^ 2)
    End With
End Function

Public Function fToDouble(ByRef vVariable As Variant) As Double()
    Dim aDouble() As Double
    Dim lgElement As Long

    If IsArray(vVariable) Then
        ReDim aDouble(LBound(vVariable) To UBound(vVariable))
        For lgElement = LBound(vVariable) To UBound(vVariable)
            aDouble(lgElement) = VBA.CDbl(vVariable(lgElement))
        Next lgElement
        fToDouble = aDouble()
    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, _
                      dbMediaDensity:=0.1, _
                      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, ß, Ø)

    If dbMediaDensity  0 Then
        '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
        Set oShpFrm = .Shapes.AddShape(Type:=msoShapeRectangle, _
                                       Left:=20, _
                                       Top:=20, _
                                       Width:=400, _
                                       Height:=400)
        'oShpFrm.Name = "Frame"
        With oShpFrm
            TopBox = .Top
            BottBox = TopBox + .Height
            LeftBox = .Left
            RightBox = LeftBox + .Width
        End With

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

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

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

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

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

            If CCDist  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

Public Sub NCradle()
    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")
    BallA = Array("Ncradle1", "Ncradle2", "Ncradle3", "Ncradle4", "Ncradle5")

    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 aDbl() As Double
    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)
                aDbl(lgR, lgC) = VBA.Val(vArray(lgR, lgC))
            Next lgC
        Next lgR
        fNewArrayDbl = aDbl()
    
        Erase aDbl()
    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 aDbl() As Double
    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)
                aDbl(lgR) = VBA.CDbl(VBA.Val(vArray(lgR)))
            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)
                    aDbl(lgR, lgC) = VBA.CDbl(VBA.Val(vArray(lgR, lgC)))
                Next lgC
            Next lgR
        End If
        fNewVectorDbl = aDbl()
    
        Erase aDbl()
    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 sArray_Load
    Call sGaussJordan(mArray())
End Sub

Private Sub sArray_Load()
    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

VBA CAD

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.

‘[HKEY_CLASSES_ROOT\AutoCAD.Application\CurVer]
‘@=”AutoCAD.Application.21″

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application.21]

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application.21\CLSID]
‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application]
‘@=”AutoCAD Application”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application\CLSID]
‘@=”{0D327DA6-B4DF-4842-B833-2CFF84F0948F}”

‘[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AutoCAD.Application\CurVer]
‘@=”AutoCAD.Application.21″

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
Private oCadDoc As Object 'AutoCAD.AutoCADDrawing or BricscadApp.AcadDocument

Opening a drawing in CAD. Linking to objects

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
Private oCadDoc As Object 'AutoCAD.AutoCADDrawing or BricscadApp.AcadDocument

Private Function fCADOpen(ByRef oCadApp As Object, _
                          ByRef oCadDoc As Object, _
                          Optional ByRef strFullPath_File As String = vbNullString) As Boolean
' Get CAD instance and CAD drawing document

    'Check if AutoCAD application is open. If not, create a new instance and make it visible.
    On Error Resume Next
    Set oCadApp = GetObject(, "AutoCAD.Application") '(, "BricscadApp.Application") '= New BricscadApp.AcadApplication in Early binding
    If oCadApp Is Nothing Then
    ' or also:
    'If Err.Description > vbNullString Then
    '    Err.Clear
        Set oCadApp = CreateObject("AutoCAD.Application") '("BricscadApp.Application")
        oCadApp.Visible = True
    End If

    'Check if there is an AutoCAD object.
    If oCadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
        fCADOpen = False: GoTo ExitProc
    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"
    'Set oCadDoc = oCadApp.Documents.Open (strFullPath_File)
    Set oCadDoc = oCadApp.ActiveDocument
    If oCadDoc Is Nothing Then
        Set oCadDoc = oCadApp.Documents.Add
    End If
    On Error GoTo 0

    If oCadDoc Is Nothing Then fCADOpen = False: GoTo ExitProc

    'Check if the active space is paper space and change it to model space.
    With oCadDoc
        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)
    If strFullPathFile_CAD = vbNullString Then
        strFullPathFile_CAD = VBA.Environ("UserProfile") & "\Documents\Unknown.dwg"
    End If

    oCadDoc.SaveAs strFullPathFile_CAD
    oCadApp.Documents.Close

    oCadApp.Quit

    Set oCadDoc = Nothing
    Set oCadApp = Nothing
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 oCADText As Object 'AutoCAD.AutoCADApplication.AcadText or BricscadApp.AcadText
Dim TxtStr As String

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

Set oCADText = oCadDoc.ModelSpace.AddText(TxtStr, P, Height)

Set oCADText = Nothing
End Sub

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

'Declaring the necessary variables.
Dim oCadPol As Object 'AcadLWPolyline
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", _
Default:=Selection.Address(True, True), _
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
Call fCADOpen(oCadApp, oCadDoc)

'Draw the polyline either at model space or at paper space.
'If oCadDoc.ActiveSpace = acModelSpace Then
Set oCadPol = oCadDoc.ModelSpace.AddLightWeightPolyline(dblCoordinates)
'Else
' Set oCadPol = oCadDoc.PaperSpace.AddLightWeightPolyline(dblCoordinates)
'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.
oCadPol.Closed = False
oCadPol.Update

'Zooming in to the drawing area.
oCadApp.ZoomExtents

'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 oCad3DPol As Object 'BricscadApp.Pol3D
Dim oCircle(0 To 0) As Object 'BricscadApp.Circle
Dim oSolidPol As Object 'BricscadApp.Solid3D

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 CircleRadius 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 rgRadius As Excel.Range
Dim rgCoordinates As Excel.Range

' Get coordinates data
'Set rgCoordinates = Application.InputBox(Prompt:="Select range of points", _
Title:="Select data", _
Default:=Selection.Address(True, True), _
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.
Set oCircle(0) = oCadDoc.ModelSpace.AddCircle(CircleCenter, CircleRadius)

' 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.
Regions = oCadDoc.ModelSpace.AddRegion(oCircle)

' Create the "solid polyline".
Set oSolidPol = oCadDoc.ModelSpace.AddExtrudedSolidAlongPath(Regions(0), oCad3DPol)

' 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
oCad3DPol.Delete
End If
End If

' Zooming in to the drawing area.
oCadApp.ZoomExtents

' Release the objects.
Set oCircle(0) = Nothing
Set oSolidPol = Nothing
Set oCad3DPol = 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:

https://www.youtube.com/watch?v=iCeOEQVUWZ0

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

https://www.youtube.com/watch?v=GzC2K-kn31o

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

An Excel CAD (xlCAD)

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 oAdjustment As Excel.Adjustments
Dim msoAutoshapeTypeValue As Long
Dim sgHeight As Single
Dim sgWidth As Single
Dim sgLeft As Single
Dim sgTop As Single
Dim lgAdjustment As Long
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
Set oShp = .Shapes.AddShape(Type:=msoAutoshapeTypeValue, _
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
.Text = oShp.Adjustments.Count
.Font.Color = 1
‘.Font.Name = “Garamond”
‘.Font.size = 12
End With
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
End With
‘oCell.Offset(0, 2).Value = oShp.Adjustments.Count
‘If oShp.Adjustments.Count > 0 Then
‘ For lgAdjustment = 1 To oShp.Adjustments.Count
‘ ‘Add adjustment counter
‘ Set oShpConnector = .Shapes.AddShape(msoShapeRectangle, _
‘ oShp.Left, _
‘ oShp.Top + oShp.Heigth, _
‘ oShp.Left + oShp.Width, _
‘ oShp.Top)
‘ Next lgAdjustment
‘End If

oShp.Name = “#” & msoAutoshapeTypeValue

If oShp.ConnectionSiteCount > 0 Then
lgConnector = 0
For lgConnector = 1 To oShp.ConnectionSiteCount
‘Add connector Pointers
Set oShpConnector = .Shapes.AddConnector(msoConnectorCurve, _
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

‘Add connector markers
Set oShpCtr = .Shapes.AddShape(Type:=msoShapeOval, _
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
.Line.EndArrowheadStyle = msoArrowheadTriangle

‘ rough approximation of the Excel 2007 preset line style #17
.Line.Weight = 2
.Line.ForeColor.RGB = RGB(192, 80, 77)
.Shadow.Type = msoShadow6
.Shadow.IncrementOffsetX -4.5
.Shadow.IncrementOffsetY -4.5
.Shadow.ForeColor.RGB = RGB(192, 192, 192)
.Shadow.Transparency = 0.5
.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

‘Add Connector to Group
‘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.

CAD Paper space

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

‘Comments
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

‘Comments
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

‘Comments
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

‘ ‘Comments
‘ 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

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

Public Type tCAD
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()
bNoFollow = True
‘Do
‘ Me.lbXYZ.Caption = “X=” & MouseX & “;” & “Y = ” & MouseY ‘ & “;” & “Z = ” & MouseZ
‘ DoEvents
‘Loop While bNoFollow
End Sub
Private Sub Worksheet_Deactivate()
bNoFollow = False
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
LastCell = ActiveCell.Address(True, True)
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:

Command Shortcut Parameters Description
3D Creates three-dimensional polygon mesh objects
3DARRAY Creates a three-dimensional array
3DCLIP Invokes the interactive 3D view and opens the Adjust Clipping Planes window
3DCORBIT Invokes the interactive 3D view and enables you to set the objects in the 3D view into continuous motion
3DDISTANCE Invokes the interactive 3D view and makes objects appear closer or farther away
3DFACE Creates a three-dimensional face
3DMESH Creates a free-form polygon mesh
3DORBIT ORBIT Rotates the view in 3D space, but constrained to horizontal and vertical orbit only
3DPAN Invokes the interactive 3D view and enables you to drag the view horizontally and vertically
3DPOLY Creates a polyline with straight line segments using the CONTINUOUS linetype in three-dimensional space
3DSIN Imports a 3D Studio (3DS) file
3DSOUT Exports to a 3D Studio (3DS) file
3DSWIVEL Invokes the interactive 3D view and simulates the effect of turning the camera
3DZOOM Invokes the interactive 3D view so you can zoom in and out on the view
ABOUT Displays information about AutoCAD
ACISIN Imports an ACIS file
ACISOUT Exports AutoCAD solid objects to an ACIS file
ACTRECORD ARR Starts the Action Recorder
ACTSTOP ARS Stops the Action Recorder and provides the option of saving the recorded actions to an action macro file
ACTUSERINPUT ARU Pauses for user input in an action macro
ACTUSERMESSAGE ARM Inserts a user message into an action macro
ADCCLOSE Closes AutoCAD DesignCenter
ADCENTER ADC Manages and inserts content such as blocks, xrefs, and hatch patterns
ADCNAVIGATE Directs the Desktop in AutoCAD DesignCenter to the file name, directory location, or network path you specify
ALIGN AL Aligns objects with other objects in 2D and 3D
AMECONVERT Converts AME solid models to AutoCAD solid objects
ANALYSISZEBRA ZEBRA Projects stripes onto a 3D model to analyze surface continuity.
APERTURE Controls the size of the object snap target box
APPLOAD AP Load Application
ARC A Creates an arc
AREA AA Calculates the area and perimeter of objects or of defined areas
ARRAY AR Creates multiple copies of objects in a pattern
ARX Loads, unloads, and provides information about ObjectARX applications
ATTDEF ATT Redefines a block and updates associated attributes
ATTDISP Globally controls attribute visibility
ATTEDIT ATE Changes attribute information in a block
ATTEXT Extracts attribute data
ATTIPEDIT ATI Changes the textual content of an attribute within a block
ATTREDEF Redefines a block and updates associated attributes
AUDIT Evaluates the integrity of a drawing
BACKGROUND Sets up the background for your scene
BASE Sets the insertion base point for the current drawing
BCLOSE BC Closes the Block Editor
BEDIT BE Opens the block definition in the Block Editor
BHATCH Fills an enclosed area or selected objects with a hatch pattern
BLIPMODE Controls the display of marker blips
BLOCK B Creates a block definition from selected objects
BLOCKICON Generates preview images for blocks created with Release 14 or earlier
BMPOUT Saves selected objects to a file in device-independent bitmap format
BOUNDARY BO Creates a region or a polyline from an enclosed area
BOX Creates a three-dimensional solid box
BPARAMETER PARAM Adds a parameter with grips to a dynamic block definition
BREAK BR Breaks the selected object between two points
BROWSER Launches the default Web browser defined in your system’s registry
BSAVE BS Saves the current block definition
BVSTATE BVS Creates, sets, or deletes a visibility state in a dynamic block
CAL Evaluates mathematical and geometric expressions
CAMERA CAM Sets a camera and target location to create and save a 3D perspective view of objects
CHAMFER CHA Bevels the edges of objects
CHANGE Changes the properties of existing objects
CHECKSTANDARDS CHK Checks the current drawing for standards violations
CHPROP Changes the color, layer, linetype, linetype scale factor, lineweight, thickness, and plot style of an object
CIRCLE C Creates a circle
CLOSE Closes the current drawing
COLOR COL Sets the color for new objects
COMMANDLINE CLI Displays the Command Line window
COMPILE Compiles shape files and PostScript font files
CONE Creates a three-dimensional solid cone
CONSTRAINTBAR CBAR A toolbar-like UI element that displays the available geometric constraints on an object
CONVERT Optimizes 2D polylines and associative hatches created in AutoCAD Release 13 or earlier
COPY CO Copies objects a specified distance in a specified direction
COPYBASE Copies objects with a specified base point
COPYCLIP Copies objects to the Clipboard
COPYHIST Copies the text in the command line history to the Clipboard
COPYLINK Copies the current view to the Clipboard for linking to other OLE applications
CTABLESTYLE CT Sets the name of the current table style
CUTCLIP Copies objects to the Clipboard and erases the objects from the drawing
CYLINDER CYL Creates a 3D solid cylinder
DATAEXTRACTION DX Extracts drawing data and merges data from an external source to a data extraction table or external file
DATALINK DL The Data Link dialog box is displayed
DATALINKUPDATE DLU Updates data to or from an established external data link
DBCCLOSE Closes the dbConnect Manager
DBCONNECT DBC Provides an interface to external database tables
DBLIST Lists database information for each object in the drawing
DDEDIT ED Edits single-line text, dimension text, attribute definitions, and feature control frames
DDPTYPE Specifies the display mode and size of point objects
DDVPOINT VP Sets the 3D viewing direction.
DELAY Provides a timed pause within a script
DIM AND DIM1 Accesses Dimensioning mode
DIMALIGNED Creates an aligned linear dimension
DIMANGULAR DAN Creates an angular dimension
DIMARC DAR Creates an arc length dimension
DIMBASELINE DBA Creates a linear, angular, or ordinate dimension from the baseline of the previous or selected dimension
DIMCENTER DCE Creates the center mark or the centerlines of circles and arcs
DIMCONSTRAINT DCON Applies dimensional constraints to selected objects or points on objects
DIMCONTINUE DCO Creates a dimension that starts from an extension line of a previously created dimension
DIMDIAMETER DDI Creates a diameter dimension for a circle or an arc
DIMDISASSOCIATE DDA Removes associativity from selected dimensions
DIMEDIT DED Edits dimension text and extension lines
DIMJOGGED DJO Creates jogged dimensions for circles and arcs
JOG Creates jogged dimensions for circles and arcs
DIMJOGLINE DJL Adds or removes a jog line on a linear or aligned dimension
DIMLINEAR Creates linear dimensions
DIMORDINATE DOR Creates ordinate dimensions
DIMOVERRIDE DOV Controls overrides of system variables used in selected dimensions
DIMRADIUS DRA Creates a radius dimension for a circle or an arc
DIMREASSOCIATE DRE Associates or re-associates selected dimensions to objects or points on objects
DIMSTYLE D Creates and modifies dimension styles
DIMTEDIT Moves and rotates dimension text
DIST DI Measures the distance and angle between two points
DIVIDE DIV Creates evenly spaced point objects or blocks along the length or perimeter of an object
DONUT DO Creates a filled circle or a wide ring
DRAGMODE Controls the way AutoCAD displays dragged objects
DRAWINGRECOVERY DRM Displays a list of drawing files that can be recovered after a program or system failure
DRAWORDER DR Changes the draw order of images and other objects
DSETTINGS DS Sets grid and snap, polar and object snap tracking, object snap modes, Dynamic Input, and Quick Properties
DSVIEWER Opens the Aerial View window
DVIEW DV Defines parallel projection or perspective views by using a camera and target
DWGPROPS Sets and displays the properties of the current drawing
DXBIN Imports specially coded binary files
EDGE Changes the visibility of three-dimensional face edges
EDGESURF Creates a three-dimensional polygon mesh
ELEV Sets elevation and extrusion thickness properties of new objects
ELLIPSE EL Creates an ellipse or an elliptical arc
ERASE E Removes objects from a drawing
ETRANSMIT ZIP Creates a Self-Extracting or Zipped Transmittal Package.
EXPLODE X Breaks a compound object into its component objects.
EXPORT EXP Saves the objects in a drawing to a different file format
EXPORTPDF EPDF Exports drawing to PDF
EXPRESSTOOLS Activates the installed AutoCAD Express Tools if currently unavailable
EXTEND EX Extends objects to meet the edges of other objects
EXTERNALREFERENCES ER Opens the External References palette
EXTRUDE EXT Extends the dimensions of a 2D object or 3D face into 3D space
FILL Controls the filling of multilines, traces, solids, all hatches, and wide polylines
FILLET F Rounds and fillets the edges of objects
FILTER FI Creates a list of requirements that an object must meet to be included in a selection set
FIND Finds, replaces, selects, or zooms to specified text
FLATSHOT FSHOT Creates a 2D representation of all 3D objects based on the current view
FOG Provides visual cues for the apparent distance of objects
FSMODE FS Creates a selection set of all objects that touch the selected object
GEOCONSTRAINT GCON Applies or persists geometric relationships between objects or points on objects
GEOGRAPHICLOCATION GEO Specifies the geographic location information for a drawing file
NORTH Specifies the geographic location information for a drawing file
GRADIENT GD Fills an enclosed area or selected objects with a gradient fill
GRAPHSCR Switches from the text window to the drawing area
GRID Displays a dot grid in the current viewport
GROUP G Creates and manages saved sets of objects called groups
BH Fills an enclosed area or selected objects with a hatch pattern, solid fill, or gradient fill
HATCH H Fills an enclosed area or selected objects with a hatch pattern, solid fill, or gradient fill
HATCHEDIT HE Modifies an existing hatch or fill
HELP (F1) Displays online help
HIDE HI Regenerates a 3D wireframe model with hidden lines suppressed
HIDEPALETTES POFF Hides currently displayed palettes (including the command line)
HYPERLINK Attaches a hyperlink to a graphical object or modifies an existing hyperlink
HYPERLINKOPTIONS Controls the visibility of the hyperlink cursor and the display of hyperlink tooltips
ID ID Displays the UCS coordinate values of a specified location
IMAGE IM Displays the External References palette
IMAGEADJUST IAD Controls the image display of the brightness, contrast, and fade values of images
IMAGEATTACH IAT Inserts a reference to an image file
IMAGECLIP ICL Crops the display of a selected image to a specified boundary
IMAGEFRAME Controls whether AutoCAD displays the image frame or hides it from view
IMAGEQUALITY Controls the display quality of images
IMPORT IMP Imports files of different formats into the current drawing
INSERT I Inserts a block or drawing into the current drawing
INSERTOBJ IO Inserts a linked or embedded object
INTERFERE INF Creates a temporary 3D solid from the interferences between two sets of selected 3D solids
INTERSECT IN Creates a 3D solid, surface, or 2D region from overlapping solids, surfaces, or regions
ISOPLANE Specifies the current isometric plane
JOIN J Joins similar objects to form a single, unbroken object
LAYER LA Manages layers and layer properties
LAYERSTATE LAS Saves, restores, and manages named layer states
LAYOUT LO Creates and modifies drawing layout tabs
LAYOUTWIZARD Starts the Layout wizard, in which you can designate page and plot settings for a new layout
LEADER Creates a line that connects annotation to a feature
LENGTHEN LEN Changes the length of objects and the included angle of arcs
LIGHT Manages lights and lighting effects
LIMITS Sets and controls the drawing boundaries and grid display
LINE L Creates straight line segments
LINETYPE LT Loads, sets, and modifies linetypes
LIST LI Displays property data for selected objects
LOAD Makes shapes available for use by the SHAPE command
LOGFILEOFF Closes the log file opened by LOGFILEON
LOGFILEON Writes the text window contents to a file
LSEDIT Edits a landscape object
LSLIB Maintains libraries of landscape objects
LSNEW Adds realistic landscape items, such as trees and bushes, to your drawings
LTSCALE LTS Changes the scale factor of linetypes for all objects in a drawing
LWEIGHT LW Sets the current lineweight, lineweight display options, and lineweight units
MARKUP MSM Opens the Markup Set Manager
MASSPROP Calculates and displays the mass properties of regions or solids
MATCHPROP MA Applies the properties of a selected object to other objects
MATLIB Imports and exports materials to and from a library of materials
MEASURE ME Joins similar objects to form a single, unbroken object
MEASUREGEOM MEA Measures the distance, radius, angle, area, and volume of selected objects or sequence of points
MENU Loads a menu file
MENULOAD Loads partial menu files
MENUUNLOAD Unloads partial menu files
MESHSMOOTHLESS LESS Decreases the level of smoothness for mesh objects by one level
MESHSMOOTHMORE MORE Increases the level of smoothness for mesh objects by one level
MESHSPLIT SPLIT Splits a mesh face into two faces
MINSERT Inserts multiple instances of a block in a rectangular array
MIRROR MI Creates a mirrored copy of selected objects
MIRROR3D Creates a mirror image of objects about a plane
MLEADER MLD Creates a multileader object
MLEADERALIGN MLA Aligns and spaces selected multileader objects
MLEADERCOLLECT MLC Organizes selected multileaders that contain blocks into rows or columns, and displays the result with a single leader
MLEADEREDIT MLE Adds leader lines to, or removes leader lines from, a multileader object
MLEADERSTYLE MLS Creates and modifies multileader styles
MLEDIT Edits multiple parallel lines
MLINE ML Creates multiple parallel lines
MLSTYLE Defines a style for multiple parallel lines
MODEL Switches from a layout tab to the Model tab and makes it current
MOVE M Moves objects a specified distance in a specified direction
MSLIDE Creates a slide file of the current viewport in model space, or of all viewports in paper space
MSPACE MS Switches from paper space to a model space viewport
MTEXT MT Creates a multiline text object
T Creates a multiline text object
MULTIPLE Repeats the next command until canceled
MVIEW MV Creates and controls layout viewports
MVSETUP Sets up the specifications of a drawing
NAVSWHEEL WHEEL Displays a wheel that contains a collection of view navigation tools.
NAVVCUBE CUBE Controls the visibility and display properties of the ViewCube tool
NEW Creates a new drawing file
NEWSHOT NSHOT Creates a named view with motion that is played back when viewed with ShowMotion
NEWVIEW NVIEW Creates a named view with no motion
OFFSET O Creates concentric circles, parallel lines, and parallel curves
OLELINKS Updates, changes, and cancels existing OLE links
OLESCALE Displays the OLE Properties dialog box
OOPS Restores erased objects
OPEN Opens an existing drawing file
OPTIONS OP Customizes the program settings
ORTHO Constrains cursor movement
OSNAP OS Sets running object snap modes
PAGESETUP Specifies the layout page, plotting device, paper size, and settings for each new layout
PAN P Adds a parameter with grips to a dynamic block definition
PARAMETERS PAR Controls the associative parameters used in the drawing
PARTIALOAD Loads additional geometry into a partially opened drawing
PARTIALOPEN Loads geometry from a selected view or layer into a drawing
PASTEBLOCK Pastes a copied block into a new drawing
PASTECLIP Inserts data from the Clipboard
PASTEORIG Pastes a copied object in a new drawing using the coordinates from the original drawing
PASTESPEC PA Pastes objects from the Clipboard into the current drawing and controls the format of the data
PCINWIZARD Displays a wizard to import PCP and PC2 configuration file plot settings into the Model tab or current layout
PEDIT PE Edits polylines and 3D polygon meshes
PFACE Creates a three-dimensional polyface mesh vertex by vertex
PLAN Displays the plan view of a user coordinate system
PLINE PL Creates a 2D polyline
PLOT PRINT Plots a drawing to a plotter, printer, or file
PLOTSTYLE Sets the current plot style for new objects, or the assigned plot style for selected objects
PLOTTERMANAGER Displays the Plotter Manager, where you can launch the Add-a-Plotter wizard and the Plotter Configuration Editor
POINT PO Creates a point object
POINTCLOUDATTACH PCATTACH Inserts an indexed point cloud file into the current drawing
POLYGON POL Creates an equilateral closed polyline
POLYSOLID PSOLID Creates a 3D wall-like polysolid
PREVIEW PRE Displays the drawing as it will be plotted
CH Controls properties of existing objects
MO Controls properties of existing objects
PROPERTIES PR Displays Properties palette
PROPERTIESCLOSE Closes the Properties window
PSDRAG Controls the appearance of a PostScript image as it is dragged into position with PSIN
PSETUPIN Imports a user-defined page setup into a new drawing layout
PSFILL Fills a two-dimensional polyline outline with a PostScript pattern
PSIN Imports a PostScript file
PSOUT Creates an encapsulated PostScript file
PSPACE PS Switches from a model space viewport to paper space
PURGE PU Removes unused items, such as block definitions and layers, from the drawing
PYRAMID PYR Creates a 3D solid pyramid
QDIM Quickly creates a dimension
QLEADER LE Creates a leader and leader annotation
QSAVE QSAVE Saves the current drawing
QSELECT Quickly creates selection sets based on filtering criteria
QTEXT Controls the display and plotting of text and attribute objects
QUICKCALC QC Opens the QuickCalc calculator
QUICKCUI QCUI Displays the Customize User Interface Editor in a collapsed state
QUICKPROPERTIES QP Displays open drawings and layouts in a drawing in preview images
QUIT EXIT Exits the program
QVDRAWING QVD Displays open drawings and layouts in a drawing using preview images
QVDRAWINGCLOSE QVDC Closes preview images of open drawings and layouts in a drawing
QVLAYOUT QVL Displays preview images of model space and layouts in a drawing
QVLAYOUTCLOSE QVLC Closes preview images of model space and layouts in the current drawing
RAY Creates a semi-infinite line
RECOVER Repairs a damaged drawing
RECTANG REC Creates a rectangular polyline
REDEFINE Restores AutoCAD internal commands overridden by UNDEFINE
REDO Reverses the effects of the previous UNDO or U command
REDRAW R Refreshes the display in the current viewport
REDRAWALL RA Refreshes the display in all viewports
REFCLOSE Saves back or discards changes made during in-place editing of a reference (an xref or a block)
REFEDIT Selects a reference for editing
REFSET Adds or removes objects from a working set during in-place editing of a reference (an xref or a block)
REGEN RE Regenerates the entire drawing from the current viewport
REGENALL REA Regenerates the drawing and refreshes all viewports
REGENAUTO Controls automatic regeneration of a drawing
REGION REG Converts an object that encloses an area into a region object
REINIT Reinitializes the digitizer, digitizer input/output port, and program parameters file
RENAME REN Changes the names assigned to items such as layers and dimension styles
RENDER RR Creates a photorealistic or realistically shaded image of a 3D solid or surface model
RENDERCROP RC Renders a specified rectangular area, called a crop window, within a viewport
RENDERPRESETS RP Specifies render presets, reusable rendering parameters, for rendering an image
RENDERWIN RW Displays the Render window without starting a rendering operation
RENDSCR Redisplays the last rendering created with the RENDER command
REPLAY Displays a BMP, TGA, or TIFF image
RESUME Continues an interrupted script
REVOLVE REV Creates a 3D solid or surface by sweeping a 2D object around an axis
REVSURF Creates a revolved surface about a selected axis
RMAT Manages rendering materials
ROTATE RO Rotates objects around a base point
ROTATE3D Moves objects about a three-dimensional axis
RPREF RPR Displays or hides the Advanced Render Settings palette for access to advanced rendering settings
RSCRIPT Creates a script that repeats continuously
RULESURF Creates a ruled surface between two curves
SAVE Saves the drawing under the current file name or a specified name
SAVEAS Saves an unnamed drawing with a file name or renames the current drawing
SAVEIMG Saves a rendered image to a file
SCALE SC Enlarges or reduces selected objects, keeping the proportions of the object the same after scaling
SCALESCRIPT SCR Executes a sequence of commands from a script file
SCENE Manages scenes in model space
SCRIPT Executes a sequence of commands from a script
SECTION SEC Uses the intersection of a plane and solids, surfaces, or mesh to create a region
SECTIONPLANE SPLANE Creates a section object that acts as a cutting plane through 3D objects
SELECT Places selected objects in the Previous selection set
SEQUENCEPLAY SPLAY Plays named views in one category
SETUV Maps materials onto objects
SETVAR SET Lists or changes the values of system variables
SHADEMODE SHA Starts the VSCURRENT command
SHAPE Inserts a shape
SHEETSET SSM Opens the Sheet Set Manager
SHELL Accesses operating system commands
SHOWMAT Lists the material type and attachment method for a selected object
SHOWPALETTES PON Restores the display of hidden palettes
SKETCH Creates a series of freehand line segments
SLICE SL Creates new 3D solids and surfaces by slicing, or dividing, existing objects
SNAP SN Restricts cursor movement to specified intervals
SOLDRAW Generates profiles and sections in viewports created with SOLVIEW
SOLID SO Creates solid-filled triangles and quadrilaterals
SOLIDEDIT Edits faces and edges of 3D solid objects
SOLPROF Creates profile images of three-dimensional solids
SOLVIEW Creates floating viewports using orthographic projection to lay out multi- and sectional view drawings of 3D solid and body objects while in a layout
SPELL SP Checks spelling in a drawing
SPHERE Creates a three-dimensional solid sphere
SPLINE SPL Creates a smooth curve that passes through or near specified points
SPLINEDIT SPE Edits a spline or spline-fit polyline
STANDARDS STA Manages the association of standards files with drawings
STATS Displays rendering statistics
STATUS Displays drawing statistics, modes, and extents
STLOUT Stores a solid in an ASCII or binary file
STRETCH S Stretches objects crossed by a selection window or polygon
STYLE ST Creates, modifies, or specifies text styles
STYLESMANAGER Displays the Plot Style Manager
SUBTRACT SU Combines selected 3D solids, surfaces, or 2D regions by subtraction
SURFOFFSET OFFSETSRF Creates a parallel surface or solid by setting an offset distance from a surface
SURFPATCH PATCH Creates a new surface by fitting a cap over a surface edge that forms a closed loop
SYSWINDOWS Arranges windows
TABLE TB Creates an empty table object
TABLESTYLE TS Creates, modifies, or specifies table styles
TABLET Calibrates, configures, and turns on and off an attached digitizing tablet
TABSURF Creates a tabulated surface from a path curve and a direction vector
TEXT DT Creates a single-line text object
TEXTALIGN TA  Aligns multiple text objects vertically, horizontally, or obliquely
TEXTEDIT TEDIT Edits a dimensional constraint, dimension, or text object
TEXTSCR Opens the AutoCAD text window
THICKNESS TH Sets the default 3D thickness property when creating 2D geometric objects
TILEMODE TI Controls whether paper space can be accessed
TIME Displays the date and time statistics of a drawing
TOLERANCE TOL Creates geometric tolerances contained in a feature control frame
TOOLBAR TO Displays, hides, and customizes toolbars
TOOLPALETTES TP Opens the Tool Palettes window
TORUS TOR Creates a donut-shaped 3D solid
TRACE Creates solid lines
TRANSPARENCY Controls whether background pixels in an image are transparent or opaque
TREESTAT Displays information about the drawing’s current spatial index
TRIM TR Trims objects to meet the edges of other objects
U Reverses the most recent operation
UCS Manages user coordinate systems
UCSICON Controls the visibility and placement of the UCS icon
UCSMAN UC Manages defined user coordinate systems.
UNDEFINE Allows an application-defined command to override an internal AutoCAD command
UNDO Reverses the effect of commands
UNION UNI Unions two solid or two region objects.
UNHIDE Displays objects previously hidden with the ISOLATEOBJECTS or HIDEOBJECTS command.
UNISOLATEOBJECTS UNISOLATE Displays objects previously hidden with the ISOLATEOBJECTS or HIDEOBJECTS command.
UNITS UN Controls coordinate and angle display formats and precision.
VBAIDE Displays the Visual Basic Editor
VBALOAD Loads a global VBA project into the current AutoCAD session
VBAMAN Loads, unloads, saves, creates, embeds, and extracts VBA projects
VBARUN Runs a VBA macro
VBASTMT Executes a VBA statement on the AutoCAD command line
VBAUNLOAD Unloads a global VBA project
VIEW V Saves and restores named views, camera views, layout views, and preset views.
VIEWGO VGO Restores a named view.
VIEWPLAY VPLAY Plays the animation associated to a named view.
VIEWRES Sets the resolution for objects in the current viewport
VISUALSTYLES VSM Creates and modifies visual styles and applies a visual style to a viewport.
VLISP Displays the Visual LISP interactive development environment (IDE)
VPCLIP Clips viewport objects
VPLAYER Sets layer visibility within viewports
VPOINT Sets the viewing direction for a three-dimensional visualization of the drawing
VPORTS Divides the drawing area into multiple tiled or floating viewports
VSCURRENT VS Sets the visual style in the current viewport.
VSLIDE Displays an image slide file in the current viewport
WBLOCK W Writes objects or a block to a new drawing file.
WEDGE WE Creates a 3D solid wedge.
WHOHAS Displays ownership information for opened drawing files
WMFIN Imports a Windows metafile<
WMFOPTS Sets options for WMFIN
WMFOUT Saves objects to a Windows metafile
XATTACH XA Inserts a DWG file as an external reference (xref).
XBIND XB Binds one or more definitions of named objects in an xref to the current drawing.
XCLIP XC Crops the display of a selected external reference or block reference to a specified boundary.
XLINE XL Creates a line of infinite length.
XPLODE Breaks a compound object into its component objects
XREF XR Starts the EXTERNALREFERENCES command.
ZOOM Z Increases or decreases the magnification of the view in the current viewport.

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”]
Public Function fcmdCAD_3DFACE() As Boolean
‘ 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
‘ fcmdCAD_3DFACE = False
‘ Exit Function
‘ End If
‘End If
‘Create 3D face polygon
‘…
fcmdCAD_3DFACE = True
End Function

COMMANDS from menus/dockbars

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.
' All rights reserved.
'
' 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
' http://www.opensource.org.licenses/bsd-license.php.
'

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 m_interleave_original_code_as_comments As Boolean

Private Const IB_NameOfInvisibleBasicMenu As String = "Invisible&Basic"
' Excel menu on which the Invisible Basic menu is placed:
Private Const IB_NameOfExcelWorksheetMenubar As String = _
"Worksheet Menu Bar"

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
interleave_original_code_as_comments = m_interleave_original_code_as_comments
End Property

Public Property Let interleave_original_code_as_comments(original_code_as_comments As Boolean)
m_interleave_original_code_as_comments = original_code_as_comments
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
add_identifier cNew, CStr(invisible_names.Item(iName)(NAME_ID)), vName
'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)
c.Add name_value_pair, LCase(sName)
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.
add_identifier userform_attribute_names, token, token
add_identifier visible_names, token, token
ElseIf (is_event_procedure(token)) Then
' example token: myButton_Click will make itself and myButton visible if _Click is listed in visible_names.txt
add_identifier visible_names, token, token
add_identifier visible_names, object_part(token), object_part(token)
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))
add_identifier visible_names, next_to_last_token(), next_to_last_token()
ElseIf (visible) Then
add_identifier visible_names, token, token
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
add_identifier invisible_names, token, token
End If

If (follows_declared_name(token) And _
token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
add_identifier invisible_names, next_to_last_token(), next_to_last_token()
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

' open file for reading
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
add_line = result
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
result = add_line(result, 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)
If (m_interleave_original_code_as_comments) Then
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..."
' start with empty variable name identifier tables
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
read_component_code vbc, 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))

' making each filename start with path separator simplifies the tests:
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
Application.DisplayAlerts = False
wb.SaveAs fileName ' save again under the new name
Application.DisplayAlerts = True

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.DisplayAlerts = True
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
m_interleave_original_code_as_comments = False
ib_save_invisibly_as
End Sub

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

Public Sub invisible_basic_debugging_save_invisibly_as() '#visible
m_interleave_original_code_as_comments = True
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

Public Sub invisible_basic_about() '#visible

MsgBox "Invisible Basic Version " & CStr(INVISIBLE_BASIC_VERSION) & vbNewLine & _
"A Source Code Obfuscator for Excel/VBA" & vbNewLine & _
"Share you spreadsheets. Not your source code." & vbNewLine & _
vbNewLine & _
"Copyright 2006, John C. Gunther. All Rights Reserved." & vbNewLine & _
"Distributed under the terms of the BSD open source license." & vbNewLine & _
vbNewLine & _
"Web Site: " & INVISIBLE_BASIC_URL & vbNewLine _
, vbOKOnly, "About Invisible Basic"

End Sub

' adds or updates the Invisible Basic menu within Excel
Public Sub invisible_basic_add_menu()
Dim cbp As CommandBarPopup ' new invisible basic menu bar
Dim cbb As CommandBarButton ' new menu item added to this bar

Call invisible_basic_remove_menu ' to prevent adding menu twice

Set cbp = Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls.Add( _
Type:=msoControlPopup)

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

Set cbb = cbp.Controls.Add(Type:=msoControlButton)
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"

Set cbb = cbp.Controls.Add(Type:=msoControlButton)
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"

Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&Help..."
cbb.DescriptionText = "Invisible Basic Help"
cbb.onAction = "invisible_basic_show_help"

Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "Invisible Basic &Web Site"
cbb.DescriptionText = "Invisible Basic Web Site"
cbb.onAction = "invisible_basic_web_site"

Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&About Invisible Basic..."
cbb.DescriptionText = "About Invisible Basic"
cbb.onAction = "invisible_basic_about"

End Sub

' removes the Invisible Basic menu from Excel
Public Sub invisible_basic_remove_menu()
On Error Resume Next
Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls( _
IB_NameOfInvisibleBasicMenu).Delete
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
invisiblebasic.interleave_original_code_as_comments = False
Else
invisiblebasic.interleave_original_code_as_comments = True
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.

Word Description
Option Used to define module level settings.
Option_Base Used when changing the default lower bound of an array,
Option Base 1.
Option_Compare_Binary (Advanced) Used to change the string comparison settings,
Option Compare Binary.
Option_Compare_Database (Advanced) Used to change the string comparison settings,
Option Compare Database.
Option_Explicit Used to force variables to be declared before they can be
used, Option Explicit.
Option_Text Used to change the string comparison settings, Option
Compare Text.
Global Can be used to declare a
Public variable that is visible from all the code modules.
Private Used to declare a subroutine that is only visible in that
code module.
Private_Const Used to define symbolic constants.
Private_Enum
Private_Function
Private_Function_Friend
Private_Function_Friend_Static
Private_Function_Static
Private_Property
Private_Property_Get (Advanced) Used with the Property keyword when creating
objects.
Private_Property_Let (Advanced) Used with the Property keyword when creating
objects.
Private_Property_Set (Advanced) Used with the Property keyword when creating
objects.
Private_Sub
Private_Sub_Friend
Private_Sub_Friend_Static
Private_Sub_Static
Private_Type
Private_Declare_Function Used to declare a block of code that can return a value.
Private_Declare_Sub Used to declare a block of code that does not return a
value.
Private_WithEvents (Advanced) Used in class modules to define a variable
that can receive events.
Public Used to declare a subroutine that is visible from all the
code modules.
Public_Const Used to define symbolic constants.
Public_Enum
Public_Function
Public_Function_Friend
Public_Function_Friend_Static
Public_Function_Static
Public_Property
Public_Property_Get (Advanced) Used with the Property keyword when creating
objects.
Public_Property_Let (Advanced) Used with the Property keyword when creating
objects.
Public_Property_Set (Advanced) Used with the Property keyword when creating
objects.
Public_Sub
Public_Sub_Friend
Public_Sub_Friend_Static
Public_Sub_Static
Public_Type
Public_Declare_Function Used to declare a block of code that can return a value.
Public_Declare_Sub Used to declare a block of code that does not return a
value.
Public_WithEvents (Advanced) Used in class modules to define a variable
that can receive events.
Friend (Advanced) Used in class modules to prevent subroutines
from being accessed from external projects.
Friend_Function
Friend_Sub
Friend_Property
Friend_Property_Get (Advanced) Used with the Property keyword when creating
objects.
Friend_Property_Let (Advanced) Used with the Property keyword when creating
objects.
Friend_Property_Set (Advanced) Used with the Property keyword when creating
objects.
Const Used to define symbolic constants.
#Const (Advanced) Used with conditional compilation arguments.
Enum Used to define a user defined enumeration.
Property (Advanced) Used with the Class keyword when creating
objects.
Property_Get (Advanced) Used with the Property keyword when creating
objects.
Property_Let (Advanced) Used with the Property keyword when creating
objects.
Property_Set (Advanced) Used with the Property keyword when creating
objects.
Function Used to declare a block of code that can return a value.
Sub Used to declare a block of code that does not return a
value.
Type (Advanced) Used to define a user defined data structure.
WithEvents (Advanced) Used in class modules to define a variable
that can receive events.
With (Advanced) Used to perform multiple operations on a
single object.
As Used when defining the data type of a variable or
argument.
Byte (Data Type) Used to hold any positive number between 0
and 255.
Boolean (Data Type) Used to hold either the value True or False.
Integer Used to hold any whole number between -32,768 and 32,767.
Long (Data Type) Used to hold any whole number between
-2,147,483,648 and 2,147,486,647.
LongLong (Advanced, Data Type) Used to hold large whole numbers on
a 64 bit system.
Single (Data Type) Used to hold single precision floating point
numbers.
Double (Data Type) Used to hold double precision floating point
numbers.
Currency (Data Type) Used to hold numbers when you do not want any
rounding errors.
String (Data Type) Used to hold string variables that are fixed
length or variable length.
Object (Data Type) Used to contain a reference (or address) to
an actual object.
Variant (Data Type) Used to hold any type of data except
fixed-length strings and user defined types.
ByRef Used to pass variables in and out of subroutines and
functions.
ByVal Used to pass variables into subroutines and functions.
Optional Used to indicate that a variable passed to a subroutine
or function is optional.
Optional_ByRef Used to pass variables in and out of subroutines and
functions.
Optional_ByVal Used to pass variables into subroutines and functions.
ParamArray (Advanced) Used to allow a dynamic number of arguments to
be passed to a subroutine or function.
Declare (Advanced) Used when calling
windows API functionality.
Declare_Function Used to declare a block of code that can return a value.
Declare_Sub Used to declare a block of code that does not return a
value.
Alias (Advanced) Used when declaring an external procedure in a
DLL that has the same name and something else.
Lib (Advanced) Used when calling windows API functionality.
Call Used to allow arguments to be passed in parentheses when
execution moves inside a subroutine or function.
Dim Used when declaring one or more variables.
Static (Advanced, Variables) Used to indicate that a variable
will be preserved between calls.
Static_Function Used to declare a block of code that can return a value.
Static_Sub Used to declare a block of code that does not return a
value.
ReDim (Advanced, Function) Used to initialise or resize an
array.
ReDim_Preserve (Advanced) Used to preserve the items in an array when it
is being resized.
Erase (Advanced) Used to reinitialize the elements in an array.
Me (Advanced) Used as an implicitly declared variable inside
a class module or userform.
End Used to terminate a subroutine, function or property.
End_If
End_Select
End_Sub
End_Function
End_With
End_Property
End_Type
End_Enum
#If (Advanced) Used with conditional compilation arguments.
#Else (Advanced) Used with conditional compilation arguments.
#ElseIf (Advanced) Used with conditional compilation arguments.
#End (Advanced) Used with conditional compilation arguments.
If Used with the Then keyword to allow conditional
branching.
Else Used with the If keyword when using conditional
branching.
ElseIf Used with the If keyword when using conditional
branching.
Then Used with the If keyword in conjunction with conditional
branching.
On Used with the Error keyword when using error handling.
On_Error (Statement) Used to generate an error message.
GoTo
Event (Statement) Used to declare a user defined event.
Resume (Advanced) Used with the On Error keywords when using
error handling.
Resume_Next
RaiseEvent (Advanced) Used to trigger a class module user defined
event.
Return (Advanced) Used with the GoSub keyword to return
execution back to the original line.
Exit Used to exit a subroutine or function early before it
reaches the end.
Exit_Do
Exit_For
Exit_Function
Exit_Property
Exit_Sub
Do Used with the Until or Loop keywords when repeating one
or more statements.
Do_Until Used with the Do keyword when repeating one or more
statements.
Do_While Used with the Do keyword when repeating one or more
statements.
Loop Used with the Do keyword when repeating one or more
statements.
Loop_Until Used with the Do keyword when repeating one or more
statements.
Loop_While Used with the Do keyword when repeating one or more
statements.
While Used with the Do keyword when
repeating one or more statements.
Wend Used with the While keyword when repeating one or more
statements.
For Used with the Next keyword when
repeating one or more statement.
For_Each Used with the For keyword to access the individual
elements in a collection.
Step Used with the For keyword to provide additional
increments and decrements.
Next Used with the For keyword when repeating one or more
statements.
DoEvents
Select Used with the Case keyword in conjunction with
conditional branching.
Select_Case Used with the Select keyword when using conditional
branching.
Case Used with the Select keyword when using conditional
branching.
Stop (Advanced) Used to allow you to save a breakpoint in your
file.
False Used to represent the value 0.
True Used to represent the value -1.
Nothing Used as the default value when an object has not been
initialised.
Empty Used with a Variant data type when a value has not been
assigned.
Null (Advanced, Variant) Used to explicitly indicate an
invalid value or error.
LBound (Advanced, Function) Used to return the lower limit of an
array dimension.
UBound (Advanced, Function) Used to return the upper limit of an
array dimension.
Array Creates an array, containing a supplied set of values.
Filter Returns a subset of a supplied string array, based on
supplied criteria.
Join Joins a number of substrings into a single string.
Split Splits a Text String into a Number of Substrings.
To Used with the For keyword when repeating one or more
statements.
Implements (Advanced) Used with the Class keyword when creating
objects.
Is Compares two object reference variables.
Like Used to compare two strings and provide pattern matching.
LSet (Advanced, Statement) Used to left align a string within
a string variable.
RSet (Advanced, Statement) Used to right align a string within
a string variable.
Mod (Operator) Used to divide two numbers and return the
remainder.
New (Advanced) Used to create a new instance of an object.
And (Operator) Used as the logical ‘AND’ operator.
Or (Operator) Used an the logical ‘OR’ operator.
Not (Operator) Used as the logical ‘NOT’ operator.
TypeOf (Operator) Used to return the data type of an object.
DefBool (Advanced) Used to define certain variables to have a
Boolean data type.
DefByte (Advanced) Used to define certain variables to have a
Byte data type.
DefDate (Advanced) Used to define certain variables to have a
Date data type.
DefDec (Advanced) Used to define certain variables to have a
Variant/Decimal data type.
DefDouble (Advanced) Used to define certain variables to have a
Double data type.
DefInt (Advanced) Used to define certain variables to have a
Integer data type.
DefLng (Advanced) Used to define certain variables to have a
Long data type.
DefLngLng (Added in Office 2010) Used to define certain variables
to have a LongLong data type.
DefLngPtr (Added in Office 2010) Used to define certain variables
to have a LongPtr data type.
DefObj (Advanced) Used to define certain variables to have a
Object data type.
DefSng (Advanced) Used to define certain variables to have a
Single data type.
DefStr (Advanced) Used to define certain variables to have a
String data type.
CBool (Data Type Conversion) Used to
convert an expression to a Boolean.
CByte (Data Type Conversion) Used to convert an expression to a
Byte.
CCur (Data Type Conversion) Used to convert an expression to a
Currency.
CDec (Data Type Conversion) Used to convert an expression to a
Decimal.
CDate (Data Type Conversion) Used to convert an expression to a
Date.
CDbl (Data Type Conversion) Used to convert an expression to a
Double.
CInt (Data Type Conversion) Used to convert an expression to
an Integer.
CLng (Data Type Conversion) Used to convert an expression to a
Long.
CLngLng (Data Type Conversion) Used to convert an expression to a
LongLong.
CLngPtr (Data Type Conversion) Used to convert an expression to a
LongPtr.
CSng (Data Type Conversion) Used to convert an expression to a
Single.
CStr (Data Type Conversion) Used to convert an expression to a
String.
CVar (Data Type Conversion) Used to convert an expression to a
Variant.
Format Applies a format to an expression
and returns the result as a string.
Format$
InStr Returns the position of a substring within a string.
InStrRev Returns the position of a substring within a string,
searching from right to left.
InStrB
Left Returns a substring from the start of a supplied string.
Left$
LeftB
LeftB$
Len Returns the length of a supplied string.
LenB
LCase Converts a
supplied string to lower case text.
Lcase$
LTrim Removes leading spaces from a supplied string.
Ltrim$
Mid Returns a substring from the middle of a supplied string.
Mid$
MidB
MidB$
Replace Replaces a substring within a supplied text string.
Right Returns a substring from the end of a supplied string.
Right$
RightB
RightB$
RTrim Removes trailing spaces from a supplied string.
Rtrim$
Space Creates a string consisting of a specified number of
spaces.
Space$
StrComp Compares two strings and returns an integer representing
the result of the comparison.
StrConv Converts a string into a specified format.
String Creates a string consisting of a number of repeated
characters.
String$
StrReverse Reverses a supplied string.
Trim Removes leading and trailing spaces from a supplied
string.
Trim$
UCase Converts a supplied string to upper case text.
Ucase$
Asc Returns an integer representing the code for a supplied
character.
AscB
AscW
Chr Returns the character corresponding to a supplied
character code.
Chr$
ChrB
ChrB$
ChrW
ChrW$
IsArray Tests if a supplied variable is an array.
IsDate Tests if a supplied expression is a date.
IsEmpty Tests if a supplied variant is Empty.
IsError Tests if a supplied expression represents an error.
IsMissing Tests if an optional argument to a procedure is missing.
IsNull Tests if a supplied expression is Null.
IsNumeric Tests if a supplied expression is numeric.
IsObject Tests if a supplied variable represents an object
variable.
CVErr Produces an Error data type for a
supplied error code.
Error Returns the error message corresponding to a supplied
error code.
Erl
Err
Error$
Choose Selects a value from a list of arguments.
IIf Evaluates an expression and returns one of two values,
depending on whether the expression evaluates to True or False.
Switch Evaluates a list of Boolean expressions and returns a
value associated with the first true expression.
FormatCurrency Applies a currency format to an
expression and returns the result as a string.
FormatDateTime Applies a date/time format to an expression and returns
the result as a string.
FormatNumber Applies a number format to an expression and returns the
result as a string.
FormatPercent Applies a percentage format to an expression and returns
the result as a string.
Hex Converts a numeric value to hexadecimal notation and
returns the result as a string.
Hex$
Oct Converts a numeric value to octal notation and returns
the result as a string.
Oct$
Str Converts a numeric value to a string.
Str$
Val Converts a string to a numeric value.
Date Returns the current date.
Date$
DateAdd Adds a time interval to a date and/or time.
DateDiff Returns the number of intervals between two dates and/or
times.
DatePart Returns a part (day, month, year, etc.) of a supplied
date/time.
DateSerial Returns a Date from a supplied year, month and day
number.
DateValue Returns a Date from a String representation of a
date/time.
CVDate
Day Returns the day number (from 1 to 31) of a supplied date.
Hour Returns the hour component of a supplied time.
Minute Returns the minute component of a supplied time.
Month Returns the month number (from 1 to 12) of a supplied
date.
MonthName Returns the month name for a supplied month number (from
1 to 12).
Now Returns the current date and time.
Second Returns the second component of a supplied time.
Time Returns the current time.
Time$
Timer Returns the number of seconds that have elapsed since
midnight.
TimeSerial Returns a Time from a supplied hour, minute and second.
TimeValue Returns a Time from a String representation of a
date/time.
Weekday Returns an integer (from 1 to 7), representing the
weekday of a supplied date.
WeekdayName Returns the weekday name for a supplied integer (from 1
to 7).
Year Returns the year of a supplied date.
Abs Returns the absolute value of a
number.
Atn Calculates the arctangent of a supplied number.
Cos Calculates the cosine of a supplied angle.
Exp Calculates the value of ex for a supplied value of x.
Fix Truncates a number to an integer (rounding negative
numbers towards zero).
Int Returns the integer portion of a number (rounding
negative numbers away from zero).
Log Calculates the natural logarithm of a supplied number.
Rnd Generates a random number between 0 and 1.
Randomize
Round Rounds a number to a specified number of decimal places.
Sgn Returns an integer representing the arithmetic sign of a
number.
Sin Calculates the sine of a supplied angle.
Sqr Returns the square root of a number.
Tan Calculates the tangent of a supplied angle.
DDB Calculates the depreciation of an
asset during a specified period, using the Double Declining Balance Method.
FV Calculates the future value of a loan or investment.
IPmt Calculates the interest part of a payment, during a
specific period, for a loan or investment.
IRR Calculates the internal rate of return for a series of
periodic cash flows.
MIRR Calculates the modified internal rate of return for a
series of periodic cash flows.
NPer Calculates the number of periods for a loan or
investment.
NPV Calculates the net present value of an investment.
Pmt Calculates the constant periodic payments for a loan or
investment.
PPmt Calculates the principal part of a payment, during a
specific period, for a loan or investment.
PV Calculates the present value of a loan or investment.
Rate Calculates the interest rate per period for a loan or
investment.
SLN Calculates the straight line depreciation of an asset for
a single period.
SYD Calculates the sum-of-years’ digits depreciation for a
specified period in the lifetime of an asset.
CurDir Returns the current path, as a
string.
CurDir$
Dir Returns the first file or directory name that matches a
specified pattern and attributes.
ChDir
ChDrive
RmDir
MkDir
FreeFile
FileAttr Returns the mode of a file that has been opened using the
Open statement.
FileDateTime Returns the last modified date and time of a supplied
file, directory or folder.
FileLen Returns the length of a supplied file, directory or
folder.
GetAttr Returns an integer, representing the attributes of a
supplied file, directory or folder.
Input
Input$
InputB
InputB$
Seek
EOF
LOF
FileCopy
Kill
CreateObject
GetObject
CallByName
Command
Command$
Shell
InputBox Displays a dialog box prompting the user for input.
MsgBox Displays a modal message box.
Beep
DeleteSetting
GetAIISettings
GetSetting
SaveSetting
Environ
Environ$
IMEStatus
AppActivate
Calendar
Load
Loc
MacID
MacScript
Partition
QBColor
Reset
RGB
SendKeys
SetAttr
Unload
UserForms
ObjPtr
StrPtr
VarPtr
TypeName
VarType
vb3DDKShadow
vb3DFace
vb3DHighlight
vb3DLight
vb3DShadow
vbAbort
vbAbortRetryIgnore
vbActiveBorder
vbActiveTitleBar
vbAlias
vbApplicationModal
vbApplicationWorkspace
vbAppTaskManager
vbAppWindows
vbArchive
vbArray
vbBack
vbBinaryCompare
vbBlack
vbBlue
vbBoolean
vbButtonFace
vbButtonShadow
vbButtonText
vbByte
vbCalGreg
vbCalHijri
vbCancel
vbCr
vbCritical
vbCrLf
vbCurrency
vbCyan
vbDatabaseCompare
vbDataObject
vbDate
vbDecimal
vbDefaultButton1
vbDefaultButton2
vbDefaultButton3
vbDefaultButton4
vbDesktop
vbDirectory
vbDouble
vbEmpty
vbError
vbExclamation
vbFalse
vbFirstFourDays
vbFirstFullWeek
vbFirstJan1
vbFormCode
vbFormControlMenu
vbFormFeed
vbFormMDIForm
vbFriday
vbFromUnicode
vbGeneralDate
vbGet
vbGrayText
vbGreen
vbHidden
vbHide
vbHighlight
vbHighlightText
vbHiragana
vbIgnore
vbIMEAlphaDbl
vbIMEAlphaSng
vbIMEDisable
vbIMEHiragana
vbIMEKatakanaDbl
vbIMEKatakanaSng
vbIMEModeAlpha
vbIMEModeAlphaFull
vbIMEModeDisable
vbIMEModeHangul
vbIMEModeHangulFull
vbIMEModeHiragana
vbIMEModeKatakana
vbIMEModeKatakanaHalf
vbIMEModeNoControl
vbIMEModeOff
vbIMEModeOn
vbIMENoOp
vbIMEOff
vbIMEOn
vbInactiveBorder
vbInactiveCaptionText
vbInactiveTitleBar
vbInfoBackground
vbInformation
vbInfoText
vbInteger
vbKatakana
vbKey0
vbKey1
vbKey2
vbKey3
vbKey4
vbKey5
vbKey6
vbKey7
vbKey8
vbKey9
vbKeyA
vbKeyAdd
vbKeyB
vbKeyBack
vbKeyC
vbKeyCancel
vbKeyCapital
vbKeyClear
vbKeyControl
vbKeyD
vbKeyDecimal
vbKeyDelete
vbKeyDivide
vbKeyDown
vbKeyE
vbKeyEnd
vbKeyEscape
vbKeyExecute
vbKeyF
vbKeyF1
vbKeyF10
vbKeyF11
vbKeyF12
vbKeyF13
vbKeyF14
vbKeyF15
vbKeyF16
vbKeyF2
vbKeyF3
vbKeyF4
vbKeyF5
vbKeyF6
vbKeyF7
vbKeyF8
vbKeyF9
vbKeyG
vbKeyH
vbKeyHelp
vbKeyHome
vbKeyI
vbKeyInsert
vbKeyJ
vbKeyK
vbKeyL
vbKeyLButton
vbKeyLeft
vbKeyM
vbKeyMButton
vbKeyMenu
vbKeyMultiply
vbKeyN
vbKeyNumlock
vbKeyNumpad0
vbKeyNumpad1
vbKeyNumpad2
vbKeyNumpad3
vbKeyNumpad4
vbKeyNumpad5
vbKeyNumpad6
vbKeyNumpad7
vbKeyNumpad8
vbKeyNumpad9
vbKeyO
vbKeyP
vbKeyPageDown
vbKeyPageUp
vbKeyPause
vbKeyPrint
vbKeyQ
vbKeyR
vbKeyRButton
vbKeyReturn
vbKeyRight
vbKeyS
vbKeySelect
vbKeySeparator
vbKeyShift
vbKeySnapshot
vbKeySpace
vbKeySubtract
vbKeyT
vbKeyTab
vbKeyU
vbKeyUp
vbKeyV
vbKeyW
vbKeyX
vbKeyY
vbKeyZ
vbLet
vbLf
vbLong
vbLongDate
vbLongTime
vbLowerCase
vbMagenta
vbMaximizedFocus
vbMenuBar
vbMenuText
vbMethod
vbMinimizedFocus
vbMinimizedNoFocus
vbModal
vbModeless
vbMonday
vbMsgBox
vbMsgBoxHelpButton
vbMsgBoxRight
vbMsgBoxRtlReading
vbMsgBoxSetForeground
vbMsgBoxText
vbNarrow
vbNewLine
vbNo
vbNormal
vbNormalFocus
vbNormalNoFocus
vbNull
vbNullChar
vbNullString
vbObject
vbObjectError
vbOK
vbOKCancel
vbOKOnly
vbProperCase
vbQuestion
vbReadOnly
vbRed
vbRetry
vbRetryCancel
vbSaturday
vbScrollBars
vbSet
vbShortDate
vbShortTime
vbSingle
vbString
vbSunday
vbSystem
vbSystemModal
vbTab
vbTextCompare
vbThursday
vbTitleBarText
vbTrue
vbTuesday
vbUnicode
vbUpperCase
vbUseDefault
vbUserDefinedType
vbUseSystem
vbUseSystemDayOfWeek
vbVariant
vbVerticalTab
vbVolume
vbWednesday
vbWhite
vbWide
vbWindowBackground
vbWindowFrame
vbWindowText
vbYellow
vbYes
vbYesNo
vbYesNoCancel

This is a non exclusive list with Excel reserved words:

 Abs
 Accelerator
 Access
 AccessMode
 Action
 Activate
 ActivateMicrosoftApp
 ActivateNext
 ActivatePrevious
 ActiveCell
 ActiveChart
 ActiveDialog
 ActiveMenuBar
 ActivePane
 ActivePrinter
 ActiveSheet
 ActiveWindow
 ActiveWorkbook
 Add
 AddChartAutoFormat
 AddCustomList
 AddFields
 AddIn
 AddIndent
 AddIns
 AddItem
 AddMenu
 AddReplacement
 Address
 AddressLocal
 AddToTable
 AddVertex
 AdvancedFilter
 After
 AlertBeforeOverwriting
 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
 ArrowHeadLength
 ArrowHeadStyle
 ArrowHeadWidth
 ArrowNumber
 As
 Asc
 ascb
 ascw
 AskToUpdateLinks
 Atn
 attribute
 Attributes
 Author
 AutoComplete
 AutoCorrect
 AutoFill
 AutoFilter
 AutoFilterMode
 AutoFit
 AutoFormat
 AutoLoad
 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
 CenterHeader
 CenterHorizontally
 CenterVertically
 Centimeters
 CentimetersToPoints
 ChangeFileAccess
 ChangeLink
 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
 Comments
 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
 CreateLinks
 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
 dateadd
 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
 Display3DShading
 DisplayActiveCell
 DisplayAlerts
 DisplayAsIcon
 DisplayAutomaticPageBreaks
 DisplayBlanksAs
 DisplayClipboardWindow
 DisplayDrawingObjects
 DisplayEquation
 DisplayExcel4Menus
 DisplayFormat
 DisplayFormula
 DisplayFormulaBar
 DisplayFormulas
 DisplayFullScreen
 DisplayGridlines
 DisplayHeadings
 DisplayHorizontalScrollBar
 DisplayInfoWindow
 DisplayNames
 DisplayNote
 DisplayNoteIndicator
 DisplayOutline
 DisplayProtection
 DisplayRecentFiles
 DisplayRightToLeft
 DisplayRSquared
 DisplayScrollBars
 DisplayStatusBar
 DisplayVerticalScrollBar
 DisplayWorkbookTabs
 DisplayZeros
 Do
 DoEvents
 Double
 DoubleClick
 DoughnutGroup
 DoughnutGroups
 DoughnutHoleSize
 Down
 DownBars
 DownloadNewMail
 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
 HasLinks
 HasMailer
 HasMajorGridlines
 HasMenu
 HasMinorGridlines
 HasPassword
 HasRadarAxisLabels
 HasRoutingSlip
 HasSeriesLines
 HasTitle
 HasUpDownBars
 Header
 HeaderMargin
 Height
 HeightPercent
 Help
 HelpButton
 HelpContextID
 HelpFile
 Hex
 Hidden
 HiddenFields
 HiddenItems
 Hide
 HiLoLines
 HorizontalAlignment
 Hour
 IconFileName
 IconIndex
 IconLabel
 Id
 If
 IgnoreReadOnlyRecommended
 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
 LeftHeader
 LeftMargin
 Legend
 LegendEntries
 LegendEntry
 LegendKey
 Len
 LenB
 Length
 Let
 Lib
 LibraryPath
 Like
 Line
 Line3DGroup
 LineGroup
 LineGroups
 Lines
 LineStyle
 Link
 LinkCombo
 LinkedCell
 LinkedObject
 LinkInfo
 LinkNumber
 Links
 LinkSources
 List
 ListArray
 ListBox
 ListBoxes
 ListCount
 ListFillRange
 ListHeaderRows
 ListIndex
 ListNames
 ListNum
 load
 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
 Menu
 MenuBar
 MenuBars
 MenuItem
 MenuItems
 Menus
 MenuText
 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
 NumberFormatLinked
 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
 OpenLinks
 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
 Password
 PasswordEdit
 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
 PrintHeadings
 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
 RadarAxisLabels
 RadarGroup
 RadarGroups
 Random
 Randomize
 Range
 Range1
 Range2
 RangeSelection
 rate
 Read
 ReadOnly
 ReadOnlyRecommended
 Received
 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
 Reply
 ReplyAll
 ReportType
 Reserved
 Reset
 ResetTipWizard
 Reshape
 Resize
 Resource
 Restore
 ResultCells
 Resume
 Return
 ReturnReceipt
 ReturnType
 ReturnWhenDone
 ReversePlotOrder
 RevisionNumber
 RGB
 Right
 RightAngleAxes
 RightB
 RightFooter
 RightHeader
 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
 SaveLinkValues
 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
 SetLinkOnData
 Sgn
 Shadow
 Shared
 Sheet
 SheetBackground
 Sheets
 SheetsInNewWorkbook
 Shell
 Shift
 ShortcutKey
 ShortcutMenus
 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
 TransitionMenuKey
 TransitionMenuKeyAction
 TransitionNavigKeys
 Transpose
 Trend
 Trendline
 Trendlines
 Trim
 True
 TwoInitialCapitals
 Type
 TypeName
 typeof
 UBound
 UCase
 Underline
 Undo
 Ungroup
 Union
 Unique
 Unknown
 unload
 Unlock
 Unprotect
 Until
 Up
 UpBars
 Update
 UpdateFromFile
 UpdateLink
 UpdateLinks
 UpdateRemoteReferences
 UsableHeight
 UsableWidth
 UsedRange
 UserInterfaceOnly
 UserName
 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
 vbReadOnly
 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
 WritePassword
 WriteReserved
 WriteReservedBy
 WriteResPassword
 X1
 X2
 xl24HourClock
 xl3DArea
 xl3DBar
 xl3DColumn
 xl3DEffects1
 xl3DEffects2
 xl3DLine
 xl3DPie
 xl3DSurface
 xl4DigitYears
 xlA1
 xlAbove
 xlAbsolute
 xlAbsRowRelColumn
 xlAccounting1
 xlAccounting2
 xlAccounting3
 xlAccounting4
 xlAdd
 xlAddIn
 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
 xlCascade
 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
 xlClipboardFormatLink
 xlClipboardFormatLinkSource
 xlClipboardFormatLinkSourceDesc
 xlClipboardFormatMovie
 xlClipboardFormatNative
 xlClipboardFormatObjectDesc
 xlClipboardFormatObjectLink
 xlClipboardFormatOwnerLink
 xlClipboardFormatPICT
 xlClipboardFormatPrintPICT
 xlClipboardFormatRTF
 xlClipboardFormatScreenPICT
 xlClipboardFormatStandardFont
 xlClipboardFormatStandardScale
 xlClipboardFormatSYLK
 xlClipboardFormatTable
 xlClipboardFormatText
 xlClipboardFormatToolFace
 xlClipboardFormatToolFacePICT
 xlClipboardFormatVALU
 xlClipboardFormatWK1
 xlClosed
 xlCodePage
 xlColor1
 xlColor2
 xlColor3
 xlColumn
 xlColumnField
 xlColumnHeader
 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
 xlCurrencyLeadingZeros
 xlCurrencyMinusSign
 xlCurrencyNegative
 xlCurrencySpaceBefore
 xlCurrencyTrailingZeros
 xlCustom
 xlCut
 xlDash
 xlDashDot
 xlDashDotDot
 xlDatabase
 xlDataField
 xlDataHeader
 xlDataItem
 xlDate
 xlDateOrder
 xlDateSeparator
 xlDay
 xlDayCode
 xlDayLeadingZero
 xlDBF2
 xlDBF3
 xlDBF4
 xlDebugCodePane
 xlDecimalSeparator
 xlDefaultAutoFormat
 xlDelimited
 xlDescending
 xlDesktop
 xlDialogActivate
 xlDialogActiveCellFont
 xlDialogAddChartAutoformat
 xlDialogAddinManager
 xlDialogAlignment
 xlDialogApplyNames
 xlDialogApplyStyle
 xlDialogAppMove
 xlDialogAppSize
 xlDialogArrangeAll
 xlDialogAssignToObject
 xlDialogAssignToTool
 xlDialogAttachText
 xlDialogAttachToolbars
 xlDialogAutoCorrect
 xlDialogAxes
 xlDialogBorder
 xlDialogCalculation
 xlDialogCellProtection
 xlDialogChangeLink
 xlDialogChartAddData
 xlDialogChartTrend
 xlDialogChartWizard
 xlDialogCheckboxProperties
 xlDialogClear
 xlDialogColorPalette
 xlDialogColumnWidth
 xlDialogCombination
 xlDialogConsolidate
 xlDialogCopyChart
 xlDialogCopyPicture
 xlDialogCreateNames
 xlDialogCreatePublisher
 xlDialogCustomizeToolbar
 xlDialogDataDelete
 xlDialogDataLabel
 xlDialogDataSeries
 xlDialogDefineName
 xlDialogDefineStyle
 xlDialogDeleteFormat
 xlDialogDeleteName
 xlDialogDemote
 xlDialogDisplay
 xlDialogEditboxProperties
 xlDialogEditColor
 xlDialogEditDelete
 xlDialogEditionOptions
 xlDialogEditSeries
 xlDialogErrorbarX
 xlDialogErrorbarY
 xlDialogExtract
 xlDialogFileDelete
 xlDialogFileSharing
 xlDialogFillGroup
 xlDialogFillWorkgroup
 xlDialogFilter
 xlDialogFilterAdvanced
 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
 xlDialogGalleryRadar
 xlDialogGalleryScatter
 xlDialogGoalSeek
 xlDialogGridlines
 xlDialogInsert
 xlDialogInsertObject
 xlDialogInsertPicture
 xlDialogInsertTitle
 xlDialogLabelProperties
 xlDialogListboxProperties
 xlDialogMacroOptions
 xlDialogMailLogon
 xlDialogMailNextLetter
 xlDialogMainChart
 xlDialogMainChartType
 xlDialogMenuEditor
 xlDialogMove
 xlDialogNew
 xlDialogNote
 xlDialogObjectProperties
 xlDialogObjectProtection
 xlDialogOpen
 xlDialogOpenLinks
 xlDialogOpenMail
 xlDialogOpenText
 xlDialogOptionsCalculation
 xlDialogOptionsChart
 xlDialogOptionsEdit
 xlDialogOptionsGeneral
 xlDialogOptionsListsAdd
 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
 xlDialogScenarioAdd
 xlDialogScenarioCells
 xlDialogScenarioEdit
 xlDialogScenarioMerge
 xlDialogScenarioSummary
 xlDialogScrollbarProperties
 xlDialogSelectSpecial
 xlDialogSendMail
 xlDialogSeriesAxes
 xlDialogSeriesOrder
 xlDialogSeriesX
 xlDialogSeriesY
 xlDialogSetBackgroundPicture
 xlDialogSetPrintTitles
 xlDialogSetUpdateStatus
 xlDialogSheet
 xlDialogShowDetail
 xlDialogShowToolbar
 xlDialogSize
 xlDialogSort
 xlDialogSortSpecial
 xlDialogSplit
 xlDialogStandardFont
 xlDialogStandardWidth
 xlDialogStyle
 xlDialogSubscribeTo
 xlDialogSubtotalCreate
 xlDialogSummaryInfo
 xlDialogTable
 xlDialogTabOrder
 xlDialogTextToColumns
 xlDialogUnhide
 xlDialogUpdateLink
 xlDialogVbaInsertFile
 xlDialogVbaMakeAddin
 xlDialogVbaProcedureDefinition
 xlDialogView3d
 xlDialogWindowMove
 xlDialogWindowSize
 xlDialogWorkbookAdd
 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
 xlExcelLinks
 xlExcelMenus
 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
 xlIntlAddIn
 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
 xlMonthLeadingZero
 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
 xlOLELink
 xlOLELinks
 xlOn
 xlOneAfterAnother
 xlOpaque
 xlOpen
 xlOpenSource
 xlOr
 xlOtherSessionChanges
 xlOutside
 xlOverThenDown
 xlPageField
 xlPageHeader
 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
 xlRadar
 xlReadOnly
 xlReadWrite
 xlReference
 xlRelative
 xlRelRowAbsColumn
 xlRight
 xlRightBrace
 xlRightBracket
 xlRoutingComplete
 xlRoutingInProgress
 xlRowField
 xlRowHeader
 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
 xlTimeLeadingZero
 xlTimeSeparator
 xlTitleBar
 xlToLeft
 xlToolbar
 xlToolbarButton
 xlTop
 xlTop10Items
 xlTop10Percent
 xlTopToBottom
 xlToRight
 xlTransparent
 xlTriangle
 xlUp
 xlUpdateState
 xlUpdateSubscriber
 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
 _addcontrol
 _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
 clearcomments
 shape
 addcomment
 vbBack
 vbCr
 vbCrLf
 vbFormFeed
 vbLf
 vbNewLine
 vbNullChar
 vbNullString
 vbObjectError
 vbTab
 vbVerticalTab
 vbBinaryCompare
 vbDatabaseCompare
 vbTextCompare
 Workbook_Activate
 Workbook_AddinInstall
 Workbook_AddinUninstall
 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_SheetFollowHyperlink
 Workbook_SheetPivotTableUpdate
 Workbook_SheetSelectionChange
 Workbook_Sync
 Workbook_WindowActivate
 Workbook_WindowDeactivate
 Workbook_WindowResize
 Excel
 Office
 MsoSyncEventType
 xmlMap
 XlXmlImportResult
 XlXmlExportResult
 Hyperlink
 Worksheet_Activate
 Worksheet_BeforeDoubleClick
 Worksheet_BeforeRightClick
 Worksheet_Calculate
 Worksheet_Change
 Worksheet_Deactivate
 Worksheet_FollowHyperlink
 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

Save Excel.Range to image file

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)
    Set tmpChart = Charts.Add
    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

Userforms

written by Helen Toomik – Last updated Oct 2004

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.

Advanced topic: Load and unload

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

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 
    .Additem 
    .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 http://www.riis.com/archives/19980503.html on VB decompilation. (Dead link check out archive.org if you want to view that article.)
  • 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.
From: #13 Re: Creating an .exe

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.

Other interesting links to consider: