Attribute VB_Name = "TextHandlers"
Option Explicit


Public Function FindRev(StringToBeSearched As String, _
        StringToSearchFor As String, _
        Optional PositionToStart As Long = -1 _
        ) As Long
' Purpose: search a string from the end (right) rather than the beginning (left) for a substring
' Returns: position substring begins (from the left). First character = 1.
    
    FindRev = InStrRev(StringToBeSearched, StringToSearchFor, PositionToStart)
End Function

Public Function GetString( _
        FromString As String, _
        Optional Skip As Long = 0, _
        Optional Delimiter As String = " ", _
        Optional IgnorePunctuation As Boolean = False _
        ) As String
' Purpose: Obtain the (n-1)th word from a sentence.
' Returns: String; a word or an empty string.
' Usage: GetString(StringBeingSearched [,Skip] [,Delimiter] [,IgnorePunctuation])
'   StringBeingSearched: Required; The string being being searched.
'   Skip: Optional; The number of delimiters to skip (e.g, pass 1 to find the second word). Default is zero.
'   Delimiter: Optional; The character to use as a word delimiter. Default is space.
'   IgnorePunctuation: Optional; If true, all non-alphanumeric characters will be removed from the input string.
'       If false, any character will constitute a "word". Default is false.
' Note: White space (contiguous occurrences of the delimiter) is treated as a single instance of the delimiter.
' Examples:
'   GetString("My dog has ...    fleas", 3, , True) = fleas
'   GetString("123-45-6789", 2, "-") = 6789
'   GetString(" what will happen?", 1) = what [note the leading space in the input string]

    Dim P As Long
    Dim L As Long
    Dim j As Long
    
    If IgnorePunctuation Then FromString = StripPunctuation(FromString, Delimiter)
    P = InStr(1, FromString, Delimiter)
    If Skip = 0 Then
        If P = 0 Then
            GetString = FromString
        Else
            GetString = Left(FromString, P - 1)
        End If
    Else
        If P = 0 Then
            GetString = ""
        Else
            GetString = GetString(Mid(FromString, SkipMultipleDelims(FromString, Delimiter)), Skip - 1, Delimiter)
        End If
    End If
End Function

Public Function NameCleanup4(InputString As String, _
        Optional DisallowedWords As String = _
            "ATTORNEY DDS DO DR II III JR MD MRS OD PRES PRESIDENT SECRETARY SR TRUST" _
        ) As String
' Purpose: This function was designed for a cleanup project in which names were entered in various ways into
'   a spreadsheet. The input was usually 2-4 words and included honorifics such as "DO", "DDS", and other
'   labels not consistent with business rules. The function attempts to parse the input and create output
'   in the format "LAST, FIRST, M"
' Usage: NameCleanup4(InputString [,DisallowedWords])
'   InputString: Required; the string being parsed. Expected typical input is 2-4 words with possible punctuation.
'   DisallowedWords: Optional; a string of words that would disqualify the input text from being processed.
'       See function declaration for example.

    Dim Token(4) As String
    Dim Disallowed() As String
    Dim DisallowedBound As Long
    Dim j As Long
    Dim k As Long
    Dim tmpWord As String
    Dim tmpWordEx As String
    
    InputString = StripPunctuation(InputString, ", ")
    
    ' Step - Tokenize disallowed words
    j = 0
    tmpWord = GetString(DisallowedWords, j)
    Do While tmpWord <> ""
        ReDim Preserve Disallowed(j + 1)
        Disallowed(j) = tmpWord
'        Debug.Print j, Disallowed(j)
        j = j + 1
        tmpWord = GetString(DisallowedWords, j)
    Loop
    DisallowedBound = j
    
'    Stop
    
    ' Step - Tokenize source string and reject entries containing disallowed words or more than 3 words
    For j = 0 To 3
        Token(j) = ""
        tmpWord = GetString(InputString, j)
        If tmpWord <> "" Then
            If j = 3 Then
                NameCleanup4 = "#TOO MANY WORDS"
                Exit Function
            End If
            tmpWordEx = StripPunctuation(tmpWord, "")
            For k = 0 To DisallowedBound - 1
 '               Debug.Print tmpWord, k, Disallowed(k)
                If tmpWordEx = Disallowed(k) Then
                    NameCleanup4 = "#TITLE"
                    Exit Function
                End If
            Next k
        End If
        Token(j) = tmpWord
    Next j
    
    ' Step - Source is 2 words
    If Token(1) <> "" And Token(2) = "" Then
        If Right(Token(0), 1) = "," Then
            ' assume L, F
            NameCleanup4 = Token(0) & " " & Token(1)
        Else
            ' assume F L
            NameCleanup4 = Token(1) & ", " & Token(0)
        End If
        Exit Function
    End If
    
    ' Step - Source is 3 words
    If Token(2) <> "" And Token(3) = "" Then
        If Right(Token(0), 1) = "," Then
            ' assume L, F M
            NameCleanup4 = Token(0) & " " & Token(1) & ", " & Left(Token(2), 1)
        Else
            ' assume F M L
            NameCleanup4 = Token(2) & ", " & Token(0) & ", " & Left(Token(1), 1)
        End If
        Exit Function
    End If
    
    NameCleanup4 = "#PARSE"
    
End Function

Private Function SkipMultipleDelims(FromString As String, Delimiter As String) As Long
' Purpose: Subroutine for GetString function. Facilitates traversing white space.
    Dim P As Long
    Dim L As Long
    Dim C As String * 1
    
    L = Len(FromString)
    P = InStr(1, FromString, Delimiter)
    C = Mid(FromString, P, 1)
    Do While P < L And C = Delimiter
        P = P + 1
        C = Mid(FromString, P, 1)
    Loop
    SkipMultipleDelims = P
End Function

Public Function Soundex(ByVal pWord As String, _
    Optional pAccuracy As Byte = 4) As String
' Soundex routine found on the internet.

  On Error GoTo LocalError
  '  char importance "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  Dim x As Integer
  Dim CChar As String
  Dim SoundsLike As String

  If pAccuracy > 10 Then
    pAccuracy = 10                     ' maximum accuracy allowed
  ElseIf pAccuracy < 4 Then
    pAccuracy = 4                      ' minimum accuracy allowed
  End If
  ' account for the first character
  pAccuracy = pAccuracy - 1

  pWord = UCase(pWord)

  ' strip all invalid characters
  For x = 1 To Len(pWord)
    If Asc(Mid(pWord, x, 1)) < 65 Or _
        Asc(Mid(pWord, x, 1)) > 90 Then
      Mid(pWord, x, 1) = "@"           ' assign a catchable value
    End If
  Next x
  pWord = Trim(pWord)

  SoundsLike = pWord
  ' assign values to the string
  SoundsLike = Replace(SoundsLike, "A", "0")
  SoundsLike = Replace(SoundsLike, "E", "0")
  SoundsLike = Replace(SoundsLike, "I", "0")
  SoundsLike = Replace(SoundsLike, "O", "0")
  SoundsLike = Replace(SoundsLike, "U", "0")
  SoundsLike = Replace(SoundsLike, "Y", "0")
  SoundsLike = Replace(SoundsLike, "H", "0")
  SoundsLike = Replace(SoundsLike, "W", "0")
  SoundsLike = Replace(SoundsLike, "B", "1")
  SoundsLike = Replace(SoundsLike, "P", "1")
  SoundsLike = Replace(SoundsLike, "F", "1")
  SoundsLike = Replace(SoundsLike, "V", "1")
  SoundsLike = Replace(SoundsLike, "C", "2")
  SoundsLike = Replace(SoundsLike, "S", "2")
  SoundsLike = Replace(SoundsLike, "G", "2")
  SoundsLike = Replace(SoundsLike, "J", "2")
  SoundsLike = Replace(SoundsLike, "K", "2")
  SoundsLike = Replace(SoundsLike, "Q", "2")
  SoundsLike = Replace(SoundsLike, "X", "2")
  SoundsLike = Replace(SoundsLike, "Z", "2")
  SoundsLike = Replace(SoundsLike, "D", "3")
  SoundsLike = Replace(SoundsLike, "T", "3")
  SoundsLike = Replace(SoundsLike, "L", "4")
  SoundsLike = Replace(SoundsLike, "M", "5")
  SoundsLike = Replace(SoundsLike, "N", "5")
  SoundsLike = Replace(SoundsLike, "R", "6")

  CChar = Left(SoundsLike, 1)
  For x = 2 To Len(SoundsLike)
    If Mid(SoundsLike, x, 1) = CChar Then
      Mid(SoundsLike, x, 1) = "@"
    Else
      CChar = Mid(SoundsLike, x, 1)
    End If
  Next x
  SoundsLike = Replace(SoundsLike, "@", "")

  SoundsLike = Mid(SoundsLike, 2)
  SoundsLike = Replace(SoundsLike, "0", "")

  SoundsLike = SoundsLike & String(pAccuracy, "0")
  SoundsLike = Left(pWord, 1) & Left(SoundsLike, pAccuracy)
  Soundex = SoundsLike
  Exit Function
LocalError:
End Function

Public Function StripPunctuation(StringIn As String, _
        Optional SaveDelimiters As String = "", _
        Optional ReplaceChar As String = "" _
        ) As String
' Purpose: Removes or replaces characters in a string that are not alphanumeric or other specified characters.
'       Useful for stripping punctuation and symbols from text.
' Usage: StripPunctuation(StringIn [,SaveDelimiters] [,ReplaceChar])
'   StringIn: Required; The string to be processed.
'   SaveDelimiters: Optional; Allow these characters in addition to the default alphanumerics. No default.
'       Note: often, you will want to specify space for this parameter. Multiple characters can be specified
'       here, e.g., StripPunctuation(StringIn, " .,") will preserve space, period, and comma.
'   ReplaceChar: Optional; If ReplaceChar is specified it will be used to replace disallowed characters.
'       if not specified, disallowed characters will be dropped from the output.
    
    Const AllowChars As String = _
            "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
    Dim tmp As String
    Dim L As Long
    Dim j As Long
    Dim C As String
    Dim AllowedString As String
    
    AllowedString = SaveDelimiters & AllowChars
    L = Len(StringIn)
    j = 1
    Do While j <= L
        C = Mid(StringIn, j, 1)
        If InStr(1, AllowedString, C) > 0 Then
            tmp = tmp & C
        Else
            tmp = tmp & ReplaceChar
        End If
        j = j + 1
    Loop
    StripPunctuation = tmp
End Function