VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Scripting"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private ScriptVariableNames() As String
Private ScriptVariableValues() As String
Private FunctionNames() As String

Const TTAppend = 0
Const TTAdd = 1
Const TTSubtract = 2
Const TTMultiply = 3
Const TTDevide = 4
Const TTPower = 5
Const TTEquils = 6
Const TTLessThan = 7
Const TTGreaterThan = 8
Const TTNotEquils = 9

Public Sub AddFunctionName(ByVal FunctionName As String)
    If FunctionName <> "" Then
        ReDim Preserve FunctionNames(UBound(FunctionNames) + 1)
        FunctionNames(UBound(FunctionNames)) = FunctionName
    End If
End Sub

' Add item to variable list. '
Public Sub AddVariable(ByVal VariableName As String, ByVal VariableValue As String)
    Dim Index As Integer
    
    Index = FindVariable(VariableName)
    If Index <> 0 Then
        ScriptVariableValues(Index) = VariableValue
    Else
        ReDim Preserve ScriptVariableNames(UBound(ScriptVariableNames) + 1)
        ReDim Preserve ScriptVariableValues(UBound(ScriptVariableNames))
        ScriptVariableNames(UBound(ScriptVariableNames)) = VariableName
        ScriptVariableValues(UBound(ScriptVariableNames)) = VariableValue
    End If
End Sub
Public Function CallFunction(ByVal FunctionName As String, Optional ByVal FunctionParams As String)
    Dim Buffer As String
    Dim FunctionPart() As String
    Dim SepPos As Integer
    Dim Index As Integer
    
    Select Case UCase(FunctionName)
        Case "IIF"
            ReDim FunctionPart(3)
            SepPos = FindSeperater(FunctionParams)
            If SepPos Then
                FunctionPart(1) = Left(FunctionParams, SepPos - 1)
                FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                SepPos = FindSeperater(FunctionParams)
                If SepPos Then
                    FunctionPart(2) = Left(FunctionParams, SepPos - 1)
                    FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                    SepPos = FindSeperater(FunctionParams)
                    If SepPos Then
                        FunctionPart(3) = Left(FunctionParams, SepPos - 1)
                        FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                    Else
                        FunctionPart(3) = FunctionParams
                    End If
                Else
                    FunctionPart(2) = FunctionParams
                End If
            End If
            Buffer = TranslateScriptPart(FunctionPart(1))
            If (Buffer <> "") And (Buffer <> "0") Then
                Buffer = TranslateScriptPart(FunctionPart(2))
            Else
                Buffer = TranslateScriptPart(FunctionPart(3))
            End If
            CallFunction = Buffer
            Exit Function
        Case "ABS"
            SepPos = FindSeperater(FunctionParams)
            If SepPos Then
                Buffer = Format(Abs(Val(TranslateScriptPart(Left(FunctionParams, SepPos - 1)))))
            Else
                Buffer = Format(Abs(Val(TranslateScriptPart(FunctionParams))))
            End If
            CallFunction = Buffer
            Exit Function
        Case "DATEDIFF"
            ReDim FunctionPart(3)
            SepPos = FindSeperater(FunctionParams)
            If SepPos Then
                FunctionPart(1) = Left(FunctionParams, SepPos - 1)
                FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                SepPos = FindSeperater(FunctionParams)
                If SepPos Then
                    FunctionPart(2) = Left(FunctionParams, SepPos - 1)
                    FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                    SepPos = FindSeperater(FunctionParams)
                    If SepPos Then
                        FunctionPart(3) = Left(FunctionParams, SepPos - 1)
                        FunctionParams = Right(FunctionParams, Len(FunctionParams) - SepPos)
                    Else
                        FunctionPart(3) = FunctionParams
                    End If
                Else
                    Debug.Print "Scripting Error - Missing parameter in 'DateDiff'."
                End If
            Else
                Debug.Print "Scripting Error - Missing parameter in 'DateDiff'."
            End If
            
            ' Translate all parameters. '
            For Index = 1 To 3
                FunctionPart(Index) = TranslateScriptPart(FunctionPart(Index))
            Next
            
            If (IsDate(FunctionPart(2))) And (IsDate(FunctionPart(3))) Then
                If FunctionPart(1) = "" Then FunctionPart(1) = "d"
                Buffer = DateDiff(FunctionPart(1), FunctionPart(2), FunctionPart(3))
            Else
                Buffer = ""
                Debug.Print "Scripting Error - Invalid dates for 'DateDiff'."
            End If
            CallFunction = Buffer
            Exit Function
        Case "DATE"
            CallFunction = Date
            Exit Function
    End Select
End Function

' Clear all variables. '
Public Sub ClearVariables()
    ReDim ScriptVariableNames(0)
    ReDim ScriptVariableValues(0)
End Sub
' Get the number of variables. '
Public Function CountVariable() As Integer
    CountVariable = UBound(ScriptVariableNames)
End Function
' If the variable named in variableName exists, return true. '
Public Function ExistsVariable(ByVal VariableName As String) As Boolean
    If FindVariable(VariableName) Then
        ExistsVariable = True
    End If
End Function
Public Function FindSeperater(ByVal ParamString As String) As Integer
    Dim Index As Integer
    Dim Buffer As String
    Dim InString As Boolean
    Dim ParenthesisIndex As Integer
    
    For Index = 1 To Len(ParamString)
        If (Mid(ParamString, Index, 1) = """") Then
            If InString = False Then
                InString = True
            ElseIf (Len(ParamString) - (Index + 1)) > 0 Then
                If Mid(ParamString, Index + 1, 1) = """" Then
                    Index = Index + 1
                Else
                    InString = False
                End If
            Else
                InString = False
            End If
        ElseIf InString = True Then
        ElseIf Mid(ParamString, Index, 1) = "(" Then
            If (Len(ParamString) - (Index + 1)) > 0 Then
                ParenthesisIndex = GetParenthesisEnd(Mid(ParamString, Index + 1, Len(ParamString) - Index))
                Index = Index + ParenthesisIndex
                If ParenthesisIndex = 0 Then
                    Debug.Print "Scripting Error - Open parenthesis without close parenthesis."
                End If
            End If
        ElseIf Mid(ParamString, Index, 1) = "," Then
            FindSeperater = Index
            Exit Function
        End If
    Next
End Function

' Finds a variable index, based on the VariableName. '
Public Function FindVariable(ByVal VariableName As Variant) As Integer
    Dim Index As Integer
    
    For Index = 1 To UBound(ScriptVariableNames)
        If UCase(ScriptVariableNames(Index)) = UCase(VariableName) Then
            FindVariable = Index
            Exit Function
        End If
    Next
End Function
Public Function GetParenthesisEnd(ByVal Script As String) As Integer
    Dim Buffer As String
    Dim InString As Boolean
    Dim ParenthesisCount As Integer
    Dim Index As Integer
    
    For Index = 1 To Len(Script)
        If (Mid(Script, Index, 1) = """") Then
            If InString = False Then
                InString = True
            ElseIf (Len(Script) - Index) >= 1 Then
                If Mid(Script, Index + 1, 1) = """" Then
                    Index = Index + 1
                Else
                    InString = False
                End If
            Else
                InString = False
            End If
        ElseIf (InString = True) Or (Mid(Script, Index, 1) = " ") Then
            ' Do Nothing
        ElseIf Mid(Script, Index, 1) = "(" Then
            ParenthesisCount = ParenthesisCount + 1
        ElseIf Mid(Script, Index, 1) = ")" Then
            If ParenthesisCount <= 0 Then
                GetParenthesisEnd = Index
                Exit Function
            Else
                ParenthesisCount = ParenthesisCount - 1
            End If
        End If
    Next
End Function

Public Sub InitializeInternalFunctions()
    AddFunctionName "IIF"
    AddFunctionName "ABS"
    AddFunctionName "DATEDIFF"
    AddFunctionName "DATE"
End Sub

' Check to see if this is a function. '
Public Function IsFunction(ByVal FunctionName As String) As Boolean
    Dim Index As Long
    
    For Index = 1 To UBound(FunctionNames)
        If UCase(FunctionName) = UCase(FunctionNames(Index)) Then
            IsFunction = True
            Exit Function
        End If
    Next
    IsFunction = False
End Function

Public Function IsStringValue(ByVal Value As String) As Boolean
    Dim Index
    
    If Len(Value) Then
        If (Not Left(Value, 1) Like "#") And (Not Left(Value, 1) = ".") Then
            IsStringValue = True
        Else
            For Index = 1 To Len(Value)
                If (Not Mid(Value, Index, 1) Like "#") And (Not Mid(Value, Index, 1) = ".") Then
                    IsStringValue = True
                End If
            Next
            IsStringValue = False
            Exit Function
        End If
    End If
    IsStringValue = True
End Function

' Gets the variable value for the index pointed to by Index. '
Public Property Get ItemVariable(ByVal Index As Variant) As String
    If IsNumeric(Index) Then
        If (Index > 0) And (Index <= UBound(ScriptVariableNames)) Then
          ItemVariable = ScriptVariableValues(Index)
        End If
    Else
        ItemVariable = ScriptVariableValues(FindVariable(Index))
    End If
End Property
' Sets the define value for the index pointed to by Index, or the name pointed to by index. '
Public Property Let ItemVariable(ByVal Index As Variant, ByVal VariableValue As String)
    If IsNumeric(Index) Then
        If (Index > 0) And (Index <= UBound(ScriptVariableNames)) Then
          ScriptVariableValues(Index) = VariableValue
        End If
    Else
        ScriptVariableValues(FindVariable(Index)) = VariableValue
    End If
End Property
Public Sub PreformAction(ByRef ReturnBuffer As String, ByVal ActionBuffer As String, ByVal TranslateType As Integer)
    
    Select Case TranslateType
        Case TTAppend
            ReturnBuffer = ReturnBuffer & ActionBuffer
        Case TTAdd
            ReturnBuffer = Format(Val(ReturnBuffer) + Val(ActionBuffer))
        Case TTSubtract
            ReturnBuffer = Format(Val(ReturnBuffer) - Val(ActionBuffer))
        Case TTMultiply
            ReturnBuffer = Format(Val(ReturnBuffer) * Val(ActionBuffer))
        Case TTDevide
            If (Val(ReturnBuffer) * Val(ActionBuffer)) <> 0 Then
                ReturnBuffer = Format(Val(ReturnBuffer) / Val(ActionBuffer))
            Else
                ReturnBuffer = "0"
            End If
        Case TTPower
            ReturnBuffer = Format(Val(ReturnBuffer) ^ Val(ActionBuffer))
        Case TTEquils
            If IsStringValue(ReturnBuffer) Then
                ReturnBuffer = Format(CInt(ReturnBuffer = ActionBuffer))
            Else
                ReturnBuffer = Format(CInt(Val(ReturnBuffer) = Val(ActionBuffer)))
            End If
        Case TTLessThan
            If IsStringValue(ReturnBuffer) Then
                ReturnBuffer = Format(CInt(ReturnBuffer < ActionBuffer))
            Else
                ReturnBuffer = Format(CInt(Val(ReturnBuffer) < Val(ActionBuffer)))
            End If
        Case TTGreaterThan
            If IsStringValue(ReturnBuffer) Then
                ReturnBuffer = Format(CInt(ReturnBuffer > ActionBuffer))
            Else
                ReturnBuffer = Format(CInt(Val(ReturnBuffer) > Val(ActionBuffer)))
            End If
        Case TTNotEquils
            If IsStringValue(ReturnBuffer) Then
                ReturnBuffer = Format(CInt(ReturnBuffer <> ActionBuffer))
            Else
                ReturnBuffer = Format(CInt(Val(ReturnBuffer) <> Val(ActionBuffer)))
            End If
    End Select
    
End Sub

' Removes a variable by index, or by name. '
Public Sub RemoveVariable(ByVal Variable As Variant)
    Dim Index As Integer
    Dim Item As Integer
    
    
    If IsNumeric(Variable) Then
      If (Variable > 0) And (Variable <= UBound(ScriptVariableNames)) Then
        Item = Variable
      End If
    Else
        Item = FindVariable(Variable)
    End If
    
    If Item > 0 Then
        For Index = Item To UBound(ScriptVariableNames)
            If Index >= Item Then
                ScriptVariableNames(Index) = ScriptVariableNames(Index + 1)
                ScriptVariableValues(Index) = ScriptVariableValues(Index + 1)
            End If
        Next
        
        ReDim Preserve ScriptVariableNames(UBound(ScriptVariableNames) - 1)
        ReDim Preserve ScriptVariableValues(UBound(ScriptVariableNames))
    End If
End Sub

Public Function RunScript(ByVal Script As String) As String
    Dim Buffer
    Dim ScriptBuffer As String
    Dim StrPos As Long
    Dim EndPos As Long
    
    Buffer = Script
    
    StrPos = InStr(Buffer, "<%")
    'Debug.Print Buffer
    Do While StrPos <> 0
        If Len(Buffer) - (StrPos + 2) > 0 Then
            EndPos = InStr(StrPos + 2, Buffer, "%>")
            If EndPos <> 0 Then
                ScriptBuffer = Mid(Buffer, StrPos + 2, EndPos - (StrPos + 2))
                ScriptBuffer = TranslateScriptPart(ScriptBuffer)
                Buffer = Left(Buffer, StrPos - 1) & ScriptBuffer & Right(Buffer, Len(Buffer) - (EndPos + 1))
                StrPos = StrPos + Len(ScriptBuffer)
            Else
                Debug.Print "Script Error - Missing close code bracket."
                Exit Do
            End If
        End If
        If Len(Buffer) > StrPos Then
            StrPos = InStr(StrPos, Buffer, "<%")
        Else
            StrPos = 0
        End If
    Loop
    
    RunScript = Buffer
End Function
' Translate the part of the script given in Script.  This can be any operation, including function calls, math routines, and compare statements. '
Public Function TranslateScriptPart(ByVal Script As String) As String
    Dim Buffer As String ' This is the current buffer that all the appending of string data, or math functions are carried out on. '
    Dim StringBuffer As String ' This is the buffer used to hold the string before Translated into the current buffer. '
    Dim ActionBuffer As String ' This holds information that I'm not sure of it's purpose yet, it usually is the prefix to a function "[functionname..](xx). '
    Dim InString As Boolean ' This tells me if i am currently in a string (so that i can translate double quotes into a single quote).
    Dim Index As Integer
    Dim ParenthesisIndex As Integer ' Return from the GetParenthesisEnd call. '
    ' Current TranslateTypes are: '
    ' TTAppend TTMultiply TTAdd   '
    ' TTSubtract TTDevide TTPower '
    ' TTNotEquils TTEquils        '
    ' TTLessThan TTGreaterThan    '
    '''''''''''''''''''''''''''''''
    Dim TranslateType As Integer ' This tells me if i need to append string data, do a math equasion, etc. '
    
    For Index = 1 To Len(Script)
        If (Mid(Script, Index, 1) = """") Then
            If InString = False Then
                InString = True
                StringBuffer = ""
            ElseIf (Len(Script) - Index) > 0 Then
                If Mid(Script, Index + 1, 1) = """" Then
                    StringBuffer = StringBuffer & """"
                    Index = Index + 1
                Else
                    InString = False
                    PreformAction Buffer, StringBuffer, TranslateType
                End If
            Else
                InString = False
                PreformAction Buffer, StringBuffer, TranslateType
            End If
        ElseIf InString = True Then
            StringBuffer = StringBuffer & Mid(Script, Index, 1)
        ElseIf Mid(Script, Index, 1) = " " Then
            If ActionBuffer <> "" Then
                If IsStringValue(ActionBuffer) Then
                    PreformAction Buffer, ItemVariable(ActionBuffer), TranslateType
                Else
                    PreformAction Buffer, ActionBuffer, TranslateType
                End If
                ActionBuffer = ""
            End If
        ElseIf Mid(Script, Index, 1) = "(" Then
            If (Len(Script) - Index) > 0 Then
                ParenthesisIndex = GetParenthesisEnd(Mid(Script, Index + 1, Len(Script) - Index))
                If ParenthesisIndex Then
                    If ActionBuffer <> "" Then
                        If IsFunction(ActionBuffer) Then
                            PreformAction Buffer, CallFunction(ActionBuffer, Left(Mid(Script, Index + 1, Len(Script) - Index), ParenthesisIndex - 1)), TranslateType
                            TranslateType = TTAppend
                        Else
                            Debug.Print "Scripting Error - invalid function '" & ActionBuffer & "'."
                        End If
                    Else
                        PreformAction Buffer, TranslateScriptPart(Left(Mid(Script, Index + 1, Len(Script) - Index), ParenthesisIndex - 1)), TranslateType
                        TranslateType = TTAppend
                    End If
                    ActionBuffer = ""
                Else
                    If ActionBuffer <> "" Then
                        Debug.Print "Scripting Error - Script Syntax on function '" & ActionBuffer & "'."
                    Else
                        Debug.Print "Scripting Error - Open parenthesis without close parenthesis."
                    End If
                    ActionBuffer = ""
                End If
                Index = Index + ParenthesisIndex
            Else
                If ActionBuffer <> "" Then
                    Debug.Print "Scripting Error - Script Syntax on function '" & ActionBuffer & "'."
                Else
                    Debug.Print "Scripting Error - Open parenthesis without close parenthesis."
                End If
                ActionBuffer = ""
            End If
        ElseIf Mid(Script, Index, 1) = "=" Then
            TranslateType = TTEquils
        ElseIf Mid(Script, Index, 1) = "&" Then
            TranslateType = TTAppend
        ElseIf Mid(Script, Index, 1) = "+" Then
            TranslateType = TTAdd
        ElseIf Mid(Script, Index, 1) = "-" Then
            TranslateType = TTSubtract
        ElseIf Mid(Script, Index, 1) = "*" Then
            TranslateType = TTMultiply
        ElseIf Mid(Script, Index, 1) = "/" Then
            TranslateType = TTDevide
        ElseIf Mid(Script, Index, 1) = ">" Then
            If (Len(Script) - (Index + 1)) > 0 Then
                If Mid(Script, Index + 1, 1) = "<" Then
                    TranslateType = TTNotEquils
                Else
                    TranslateType = TTLessThan
                End If
            Else
                    TranslateType = TTLessThan
            End If
        ElseIf Mid(Script, Index, 1) = "<" Then
            If (Len(Script) - (Index + 1)) > 0 Then
                If Mid(Script, Index + 1, 1) = ">" Then
                    TranslateType = TTNotEquils
                Else
                    TranslateType = TTGreaterThan
                End If
            Else
                    TranslateType = TTGreaterThan
            End If
        Else
            ActionBuffer = ActionBuffer & Mid(Script, Index, 1)
        End If
    Next
    
    If ActionBuffer <> "" Then
        If IsStringValue(ActionBuffer) Then
            PreformAction Buffer, ItemVariable(ActionBuffer), TranslateType
        Else
            PreformAction Buffer, ActionBuffer, TranslateType
        End If
    End If
    
    TranslateScriptPart = Buffer
End Function
Private Sub Class_Initialize()
    ReDim ScriptVariableNames(0)
    ReDim ScriptVariableValues(0)
    ReDim FunctionNames(0)
    InitializeInternalFunctions
End Sub
