Access 2000-compatible functions for Access 97

'====================================================================================
' Application: Various
' Module:      VBA6 Functions
' Version:     11/16/01 14:00
'====================================================================================
' Description:
' This module contains VBA version 5 implementations of built-in functions that were
' new in VBA version 6. Care was taken when writing this code to preserve the
' precedence of error detection, so parameter errors should raise the same runtime
' errors as in VBA6.
' One thing that could not be duplicated, due to language differences, is enumerated
' parameter types. For example, in InStrRev, the 4th parameter should have been of
' type VbCompareMethod, but VBA5 does not allow us to have this enumerated type of
' parameter in our own code. In all cases, a compatible basic data type was used.
' This means that the Object Browser and AutoQuickInfo syntax tips are  not identical
' to VBA6, and the AutoListMembers feature will not work with these parameters.
'====================================================================================
' Modification history:
' 11/16/01 14:00 RPS Fixed a bug in Join

Option Compare Database
Option Explicit

' The following conditional compilation statement prevents this code from being
' compiled if this module should be imported into Access 2000 by mistake.
#If Not CBool(Vba6) Then

'------------------------------------------------------------------------------------
Public Function InStrRev(StringCheck As String, StringMatch As String, _
                         Optional Start As Long = -1, _
                         Optional Compare As Integer = vbBinaryCompare) _
                         As Long
'------------------------------------------------------------------------------------
' Purpose: Finds the last occurrence of a substring within a string
' Accepts: 1. String to be searched
'          2. Substring whose occurrence is to be found
'          3. Optional rightmost position to be searched (default is
'             -1, meaning to search the entire string)
'          4. Optional text comparison method (default: binary compare)
' Returns: Position of the substring within the string (1=start of string)
' Notes:   Returns 0 if the string to be search is zero-length.
'          Returns Start if the string to be found is zero-length.
'          Returns 0 if Start is past the end of the search string.
'          Returns 0 if substring is not found.
    Dim i As Long, j As Long, k As Long, S As String

    If (Start < -1) Or (Start = 0) Then Error 5
    j = Len(StringCheck)
    k = Len(StringMatch)
    i = Start
    If i = -1 Then i = j
    If j = 0 Then InStrRev = 0: Exit Function
    If k = 0 Then InStrRev = i: Exit Function
    If i > j Then InStrRev = 0: Exit Function
    S = Left$(StringCheck, i)
    i = 0
    Do
        j = InStr(i + 1, S, StringMatch, Compare)
        If j = 0 Then Exit Do
        i = j
    Loop
    InStrRev = i
End Function

'------------------------------------------------------------------------------------
Public Function Replace(Expression As String, _
                        Find As String, ByVal ReplaceWith As String, _
                        Optional Start As Long = 1, Optional Count As Long = -1, _
                        Optional Compare As Integer = vbBinaryCompare) As String
'------------------------------------------------------------------------------------
' Purpose: Replaces occurrences of a substring within a string with a specified
'          repacement string.
' Accepts: 1. String containing substrings to be replaced
'          2. Value of the substring to be found
'          3. Replacement value to substitute for the substring
'          4. Optional starting position for the search, default=1 (start of string)
'          5. Optional maximum number of occurrences to replace, default=-1 (all
'             occurences)
'          6. Optional text comparison method (default: binary compare)
' Returns: The part of the string starting at the Start position, with substitutions
'          made. Returns an empty string if Start > Len(Expression).
    Dim str As String
    Dim i As Long
    Dim lngFindLen As Long
    Dim c As Long
    
    If Start < 1 Then Err.Raise 5
    If Count < -1 Then Err.Raise 5
    If Compare < 0 Or Compare >= 40 Then Err.Raise 5
    str = Mid$(Expression, Start)
    lngFindLen = Len(Find)
    If lngFindLen > 0 Then
        c = Count
        i = 1
        Do While c <> 0
            i = InStr(i, str, Find, Compare)
            If i = 0 Then Exit Do
            If lngFindLen = Len(ReplaceWith) Then
                Mid$(str, i, lngFindLen) = ReplaceWith
            Else
                str = Left$(str, i - 1) & ReplaceWith & Mid$(str, i + lngFindLen)
            End If
            i = i + Len(ReplaceWith)
            If c > 0 Then c = c - 1
        Loop
    End If
    Replace = str
End Function

'------------------------------------------------------------------------------------
Public Function Join(SourceArray As Variant, Optional Delimiter As Variant) As String
'------------------------------------------------------------------------------------
' Purpose: Create a string containing the elements of an array separated by a
'          delimiter character.
' Accepts: 1. A variant array containing any data that can be converted to strings.
'             Different elements can be of different types. The array can be empty.
'          2. A delimiter to be inserted between the strings. This also must be
'             convertible to a string. It is usually a single-character string.
    Dim delim As String
    Dim item As String, result As String
    Dim i As Integer, top As Integer
    
    ' if SourceArray is not a variant (array), raise error 13
    If VarType(SourceArray) And vbArray = 0 Then Err.Raise 13
    ' set the default delimiter
    If IsMissing(Delimiter) Then
        delim = " "
    Else
        delim = CStr(Delimiter)
    End If
    ' concatenate the array entries
    On Error GoTo ErrorHandler
    ' Note: If the array is empty, the next statement raises error 9
    top = UBound(SourceArray)
    For i = LBound(SourceArray) To top
        On Error GoTo 0
        ' if variant type is array or Object, raise error 13
        If (VarType(SourceArray(i)) And vbArray) <> 0 Then Err.Raise 13
        If (VarType(SourceArray(i)) = vbObject) Then Err.Raise 13
        result = result & CStr(SourceArray(i))
        If i < top Then result = result & delim
    Next i
ErrorResume:
    Join = result
    Exit Function
ErrorHandler:
    If Err.Number = 9 Then Resume ErrorResume
    Err.Raise Err.Number
End Function

'------------------------------------------------------------------------------------
Public Function Split(Expression As String, Optional Delimiter, _
                      Optional Limit As Long = -1, _
                      Optional Compare As Integer = vbBinaryCompare) As Variant
'------------------------------------------------------------------------------------
' Purpose: Split a string into substrings at a delimiter, and return the substrings
'          in a Variant (Array of String)
' Accepts: 1. String expression to be split
'          2. Optional delimiter (default is ' ')
'          3. Optional maximum of number of substrings to return (default is all
'             substrings)
'          4. Optional compare mode for delimiter (default is case-sensitive)
' Returns: Variant array of strings containing substrings separated by the delimiter.
'          If Limit is reached, last entry in array contains remainder of string,
'          including any delimiters embedded.
    Dim result()
    Dim i As Integer, j As Integer, Count As Integer
    
    If Limit < -1 Then Err.Raise 5
    If IsMissing(Delimiter) Then Delimiter = " "
    If Delimiter = "" Then
        ReDim result(0)
        result(0) = Expression
        Split = result
        Exit Function
    End If
    If Expression = "" Then
        Split = Array()
        Exit Function
    End If
    i = 1
    Do
        If (Limit >= 0) And (Count >= Limit - 1) Then Exit Do
        j = InStr(i, Expression, Delimiter, Compare)
        If j = 0 Then Exit Do
        ReDim Preserve result(Count)
        result(Count) = Mid$(Expression, i, j - i)
        Count = Count + 1
        i = j + Len(Delimiter)
    Loop
    ReDim Preserve result(Count)
    result(Count) = Mid$(Expression, i)
    Split = result
End Function

'------------------------------------------------------------------------------------
Public Function StrReverse(Expression As String) As String
'------------------------------------------------------------------------------------
' Purpose: Returns a string in which the character sequence is reversed from that of
'          the parameter.
    Dim i As Integer, j As Integer, S As String
    S = Expression
    i = 1
    For j = Len(S) To 1 Step -1
        Mid$(S, i, 1) = Mid$(Expression, j, 1)
        i = i + 1
    Next j
    StrReverse = S
End Function

'------------------------------------------------------------------------------------
Public Function MonthName(Month As Long, Optional Abbreviate As Boolean = False) _
    As String
'------------------------------------------------------------------------------------
' Purpose: Returns a string indicating the specified month.
' Accepts: The month number (1-12). Optionally, an indicator to abbreviate the
'          returned name.
' Returns: The month name as a string. If Abbreviate=True, the string is abbreviated
'          to the first three characters.
' Note:    Unlike the standard VBA6 function, this function does NOT return the
'          month name in the local language. The returned month name is always
'          English.
    Dim astrMonthName As Variant
    
    If (Month < 1) Or (Month > 12) Then Err.Raise 5
    astrMonthName = Array("January", "February", "March", "April", "May", "June", _
        "July", "August", "September", "October", "November", "December")
    If Abbreviate Then
        MonthName = Left$(astrMonthName(Month), 3)
    Else
        MonthName = astrMonthName(Month)
    End If
End Function

#End If