George Brown - 11/14/04

The function [ IsSimilar(ByVal RefStr, ByVal TestStr, Optional Alg2Use$) As Single ] determines
a weighted numeric similarity between 2 strings by passing the strings through each algorithm
if Alg2Use is not passed by the form Algorithm Suite.

The form Algorithm Suite is a user interface to allow input of two separate strings or two separate
full names with the options of running the strings through individual algorithms or the full suite of
algorithms to see the results.
  
If full names are passed to the IsSimilar function by the form, then the [ NameSimilarity(RefStr, TestStr) As Single ] function is also called by the IsSimilar function to specifically deal with the two LFM names.
To deal with names in FML format or FL format or any other format, this function would need to be adapted
to those formats as well. The NameSimilarity function is only specific to the LFM format at this time.

The NameSimilarity function takes into consideration the variations involved with maiden names, such as,
maiden in middle in one name, and last name with a dash in the other name. It also looks for a full middle
name in one name and a possible match to an abbreviated middle name in the other name. The function looks
for other variations, typos, and anomalies between the two names for comparison. It has extensive parsing
for many possible variations in maiden names between the two names for comparison.

 

The two functions mentioned above are not included in this suite of algorithms, since I consider them
proprietary.


**********************************************************************************************************

Option Compare Database
Option Explicit


Public Sub Bigram(ByVal pStr, BGArray())
' * Breaks pStr into bigram segments
' * Example: zantac - %z za an nt ta ac c#
 Dim X As Integer, BGCount As Integer, StrLen As Integer
  
  pStr = "%" & pStr & "#"
  StrLen = Len(pStr)
  BGCount = StrLen - 1
  ReDim BGArray(BGCount)
      
       For X = 0 To BGCount - 1
        BGArray(X) = Mid(pStr, X + 1, 2)
       Next X
  
End Sub



Public Function LevDist(ByVal pStr1, ByVal pStr2) As Integer
'******************** Levenshtein Distance **************************************************
'* Levenshtein Distance algorithm is named after the Russian scientist
'* Vladimir Levenshtein, who devised the algorithm in 1965
'*
'* Levenshtein edit distance is the number of insertions, deletions, or
'* replacements of single characters that are required to convert one
'* string to the other.
'*
'* Character transposition is detected in Step 6A.
'* Transposition is given a cost of 1.
'*
'* Normally Levenshtein edit distance is symmetric.
'* That is, LevDist(pStr1 , pStr2) is the same as LevDist(pStr2 , pStr1).
'*
'********************************************************************************************
 Dim n As Integer, m As Integer, matrix() As Integer
 Dim i As Integer, j As Integer, cost As Integer, t_j, s_i
 Dim above As Integer, left As Integer, diag As Integer, cell As Integer
 Dim trans As Integer


  ' Step 1
   
    n = UBound(pStr1)
    m = UBound(pStr2)
  
     If n = 0 Then
      LevDist = 0
      GoTo LevDistXit
     End If
      If m = 0 Then
       LevDist = 0
       GoTo LevDistXit
      End If

   ReDim matrix(n + 1, m + 1)

  ' Step 2

  For i = 0 To n
    matrix(i, 0) = i
  Next i

   For j = 0 To m
    matrix(0, j) = j
   Next j

  ' Step 3

  For i = 1 To n

    s_i = pStr1(i - 1)

    ' Step 4

    For j = 1 To m

      t_j = pStr2(j - 1)

      ' Step 5

         cost = 0
            
           If Not IsEmpty(s_i) And Not IsEmpty(t_j) Then
            If s_i <> t_j Then
              cost = 1
            End If
           End If
           
      ' Step 6

      above = matrix(i - 1, j)
      left = matrix(i, j - 1)
      diag = matrix(i - 1, j - 1)
      cell = Minimum((above + 1), (left + 1), (diag + cost))

      ' Step 6A: Cover transposition, in addition to deletion,
      ' insertion and substitution. This step is taken from:
      ' Berghel, Hal ; Roach, David : "An Extension of Ukkonen's
      ' Enhanced Dynamic Programming ASM Algorithm"
      ' (http://www.acm.org/~hlb/publications/asm/asm.html)

      If i > 1 And j > 1 Then ' changed here to detect transposition of first 2 characters
                              ' and return 1 instead of 2 for a cost
        trans = matrix(i - 2, j - 2) + 1
        
        If pStr1(i - 2) <> pStr2(j - 1) Then ' was t_j
         trans = trans + 1
        End If
         If pStr1(i - 1) <> pStr2(j - 2) Then ' was s_i
          trans = trans + 1
         End If
       
      
        If cell > trans Then
         cell = trans
        End If
      End If

       matrix(i, j) = cell
    Next j
  Next i

  ' Step 7

  LevDist = matrix(n, m)

LevDistXit:
End Function



Public Function Dice(ByVal Qgram1, ByVal Qgram2, Optional DMPH As Boolean) As Single
 ' *************************** Dice Coefficient *******************************
 ' Similarity metric
 ' D is Dice coefficient
 ' SB is Shared Bigrams
 ' TBg1 is total number of bigrams in Qgram1
 ' TBg2 is total number of bigrams in Qgram2
 ' D = (2SB)/(TBg1+TBg2)
 ' Double the number of shared bigrams and divide by total number of bigrams
 ' in each string.
 ' ****************************************************************************
 Dim QgramCount1 As Integer, QgramCount2 As Integer, BG1, BG2
 Dim SharedQgrams As Integer, q1 As Integer, q2 As Integer
 
 If IsMissing(DMPH) Then DMPH = False
 
 If IsNull(Qgram1) Or IsNull(Qgram2) Then
  Exit Function
 End If
 
 QgramCount1 = UBound(Qgram1)
 QgramCount2 = UBound(Qgram2)
 
 If QgramCount1 = 0 Or QgramCount2 = 0 Then Exit Function
 
 For q1 = 0 To QgramCount1 ' get shared bigram count
  BG1 = Qgram1(q1)
  
  For q2 = 0 To QgramCount2
   BG2 = Qgram2(q2)
   
   If Not IsEmpty(BG1) And Not IsEmpty(BG2) Then
    If BG1 = BG2 Then
     SharedQgrams = SharedQgrams + 1
    End If
   End If
  Next q2
 Next q1
 
 Dice = CSng(Format((2 * SharedQgrams) / (QgramCount1 + QgramCount2), "0.00"))
 If DMPH Then Dice = Minimum(Dice, 0.75)
 
End Function



Public Function LCS(ByVal str1, ByVal str2, Optional AlgInUse) As Single
'* *************** Longest Common Subsequence *********************
'* The LCS is calculated by the length of the longest common,
'* not necessarily contiguous, sub-sequence of characters divided by
'* the average character lengths of both strings.
'* In this case:  c(m, n) / (((Str1Len) + (Str2Len)) / 2))
'* LCS is symmetric.
'************************************************************************
 
 Dim i As Integer, j As Integer, m As Integer, n As Integer
 Dim c() As Integer, b() As Integer, X$(), Y$()
 Dim Str1Len As Integer, Str2Len As Integer, SmStr(), LgStr()

 If IsMissing(AlgInUse) Then AlgInUse = ""
 
  Str1Len = UBound(str1)
  Str2Len = UBound(str2)

  n = Minimum(Str1Len, Str2Len)
  m = Maximum(Str1Len, Str2Len)
  
  ReDim X(m)
  ReDim Y(m)
  ReDim c(m, m)
  ReDim b(m, m)
  
   If Str1Len > Str2Len Then
    For i = 0 To Str1Len - 1
     X(i) = str1(i)
    Next i
     For i = 0 To Str2Len - 1
      Y(i) = str2(i)
     Next i
   Else
    For i = 0 To Str2Len - 1
     X(i) = str2(i)
    Next i
     For i = 0 To Str1Len - 1
      Y(i) = str1(i)
     Next i
   End If ' Str1Len > Str2Len
   
    For i = 1 To m
      For j = 1 To n
        If X(i - 1) = Y(j - 1) Then
          c(i, j) = c(i - 1, j - 1) + 1
          b(i, j) = 1 ' /* from north west */
        ElseIf c(i - 1, j) >= c(i, j - 1) Then
          c(i, j) = c(i - 1, j)
          b(i, j) = 2 ' /* from north */
        Else
          c(i, j) = c(i, j - 1)
          b(i, j) = 3 ' /* from west */
        End If
      Next j
    Next i
    
'  return c[m][n];

  If c(m, n) > 0 Then
   If AlgInUse = "Dmph" Or AlgInUse = "SSLCS" Then
    LCS = c(m, n) ' Longest Common Subsequence
   Else
    LCS = CSng(Format((c(m, n) / (((Str1Len) + (Str2Len)) / 2)), "#.##"))
   End If
  Else
    LCS = 0
  End If

  Erase X
  Erase Y
  Erase c
  Erase b

End Function


=============================================

Option Compare Database
Option Explicit
Option Base 0

Public Alternate As Boolean ' Set to True if DoubleMetaphone returns
                            ' two phonetic codes
Public Primary              ' Primary phonetic code
Public Secondary            ' Secondary phonetic code


Function DoubleMetaphone(ByVal pWord, MetaPh, MetaPh2) As Boolean
'********************************************************************
'* DOUBLE Metaphone (c) 1998, 1999 BY Lawrence Philips
'*
'* Slightly modified BY Kevin Atkinson TO fix several bugs AND
'* TO ALLOW it TO give BACK more than 4 characters.
'*
'* Atkinson's C++ version Translated to Visual Foxpro
'* by Craig Boyd (Slighthaze) 10-23-2003
'* From http://aspell.sourceforge.net/metaphone/dmetaph.cpp
'* Also added SIGNIFICANTCHARS constant so developer
'* can control number of characters returned
'*
'* Atkinson's C++ version and Craig Boyd's Visual Foxpro versions
'* (referenced both versions for translation). Translated to
'* Visual Basic by George Brown 08-22-2004
'*
'* Returns phonetic codes in Metaph (primary) and Metaph2 (secondary)
'* for pWord
'********************************************************************
Dim SIGNIFICANTCHARS As Integer

Dim nLength As Integer, sLetter, nCurrent As Integer, nLast As Integer
Dim PreviousFlag As Boolean, PreviousFlag2 As Boolean

Primary = ""
Secondary = ""

SIGNIFICANTCHARS = 4 ' Can be changed to allow more or less characters returned

nLength = UBound(pWord)

nLast = nLength

' pad the original string so that we can index beyond the edge of the word
RApad pWord, 5, " "

' skip these when at start of word
If IsInArry(pWord, 0, Array("GN", "KN", "PN", "WR", "PS")) Then
    nCurrent = nCurrent + 1
End If

' Initial "X" is pronounced "Z" e.g. "Xavier"
If pWord(0) = "X" Then
    MetaphAdd "S" ' "Z" maps to "S"
    nCurrent = nCurrent + 1
End If

Do While True Or Len(Primary) < 4 Or Len(Secondary) < 4
   
   PreviousFlag = False ' used to check a previous letter if nCurrent >0
   PreviousFlag2 = False
   
    If nCurrent > nLength Then
        Exit Do
    End If
    sLetter = pWord(nCurrent)

   Select Case sLetter

    Case "A", "E", "I", "O", "U", "Y"
        If nCurrent = 0 Then
            ' all init vowels now map to "A"
            MetaphAdd "A"
        End If
        nCurrent = nCurrent + 1

    Case "B"
    
     ' *** modified logic here - original logic didn't make sense and
     ' *** was dropping critical letters after B
     
      ' "-mb", e.g", "dumb", already skipped over...
       If nCurrent > 0 Then
        PreviousFlag = (pWord(nCurrent - 1) = "M")
       End If
       
        If PreviousFlag And pWord(nCurrent) = "B" Then
          nCurrent = nCurrent + 2
        Else
          MetaphAdd "B"  ' was P
          nCurrent = nCurrent + 1
        End If

    Case ""
        MetaphAdd "S"
        nCurrent = nCurrent + 1

    Case "C"
        ' various germanic
        If ((nCurrent > 0) And Not _
                pWord(nCurrent) Like "[aeiouy]" And _
                IsInArry(pWord, nCurrent, Array("ACH")) And _
                pWord(nCurrent) <> "I" And _
                (pWord(nCurrent + 2) <> "E" Or _
                IsInArry(pWord, nCurrent, Array("BACHER", "MACHER")))) Then

            MetaphAdd "K"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        ' special case 'caesar'
        If nCurrent = 0 And IsInArry(pWord, nCurrent, Array("CAESAR")) Then

            MetaphAdd "S"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        ' italian 'chianti'
        If IsInArry(pWord, nCurrent, Array("CHIA")) Then

            MetaphAdd "K"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        If (pWord(nCurrent) = "C" And pWord(nCurrent + 1) = "H") Then

            ' find "michael"
            If (nCurrent > 0) And IsInArry(pWord, nCurrent, Array("CHAE")) Then

                MetaphAdd "K", "X"
                nCurrent = nCurrent + 2
                GoTo Bottom
            End If

            ' greek roots e.g. "chemistry", "chorus"
            If (nCurrent = 0) And _
               (IsInArry(pWord, nCurrent, Array("HARAC", "HARIS")) Or _
                IsInArry(pWord, nCurrent, Array("HOR", "HYM", "HIA", "HEM"))) And _
                 Not IsInArry(pWord, 0, Array("CHORE")) Then

                MetaphAdd "K"
                nCurrent = nCurrent + 2
                GoTo Bottom
            End If

            ' germanic, greek, or otherwise 'ch' for 'kh' sound
            ' e.g., 'wachtler', 'wechsler', but not 'tichner'
            ' e.g., 'wachtler', 'wechsler', but not 'tichner'
            If nCurrent > 0 Then
             PreviousFlag = IsInArry(pWord, nCurrent - 1, Array("A", "O", "U", "E"))
            End If
            
            If (IsInArry(pWord, 0, Array("VAN ", "VON ")) Or _
                IsInArry(pWord, 0, Array("SCH"))) Or _
                IsInArry(pWord, nCurrent, Array("ORCHES", "ARCHIT", "ORCHID")) Or _
                IsInArry(pWord, nCurrent + 1, Array("T", "S")) Or _
                ((PreviousFlag Or _
                (nCurrent = 0)) And _
                IsInArry(pWord, nCurrent + 1, _
                Array("L", "R", "N", "M", "B", "H", "F", "V", "W"))) Then

                MetaphAdd "K"
            Else
                If nCurrent > 0 Then

                    If IsInArry(pWord, 0, Array("MC")) Then
                        ' e.g., McHugh
                     MetaphAdd "K"
                    Else
                     MetaphAdd "X", "K"
                    End If
                Else
                    MetaphAdd "X"
                End If
            End If
            nCurrent = nCurrent + 2
            
            GoTo Bottom
            
        End If

        ' e.g, czerny
        If IsInArry(pWord, nCurrent, Array("CZ")) And Not _
           IsInArry(pWord, nCurrent, Array("WICZ")) Then
            MetaphAdd "S", "X"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        ' e.g. focaccia
        If IsInArry(pWord, nCurrent + 1, Array("CIA")) Then
            MetaphAdd "X"
            nCurrent = nCurrent + 3
            GoTo Bottom
        End If

        ' double C, but not if e.g. McClellan
        If pWord(nCurrent) = "C" And pWord(nCurrent + 1) = "C" And Not _
           (nCurrent = 0 And pWord(0) = "M") Then
             '  bellocchio  but not bacchus
            If IsInArry(pWord, nCurrent + 2, Array("I", "E", "H")) And _
               (pWord(nCurrent + 2) <> "H" And pWord(nCurrent + 3) <> "U") Then

                ' accident, accede succeed
                If ((nCurrent = 0) And (pWord(0) = "A")) Or _
                   IsInArry(pWord, nCurrent, Array("UCCEE", "UCCES")) Then
                    MetaphAdd "KS"
                    ' "bacci", "bertucci", other italian
                Else
                 MetaphAdd "X"
                End If
                nCurrent = nCurrent + 3
                GoTo Bottom
            Else   ' Pierce's rule
                MetaphAdd "K"
                nCurrent = nCurrent + 2
                GoTo Bottom
            End If
        End If

         If IsInArry(pWord, nCurrent, Array("CK", "CG", "CQ")) Then
            MetaphAdd "K"
            nCurrent = nCurrent + 2
            GoTo Bottom
         End If

          If IsInArry(pWord, nCurrent, Array("CI", "CE", "CY")) Then
            ' italian vs. english
            If IsInArry(pWord, nCurrent, Array("CIO", "CIE", "CIA")) Then
             MetaphAdd "S", "X"
            Else
              MetaphAdd "S"
            End If
            nCurrent = nCurrent + 2
            GoTo Bottom
          End If

        ' else
           MetaphAdd "K"

        ' name sent in "mac caffrey", "mac gregor"
        If IsInArry(pWord, nCurrent + 1, Array(" C", " Q", " G")) Then
            nCurrent = nCurrent + 3
        Else
            If pWord(nCurrent + 1) Like "[CKQ]" And _
               IsInArry(pWord, nCurrent + 1, Array("CE", "CI")) Then
                nCurrent = nCurrent + 2
            Else
                nCurrent = nCurrent + 1
            End If
        End If

    Case "D"
        If (pWord(nCurrent) = "D" And pWord(nCurrent + 1) = "G") Then
            If pWord(nCurrent + 2) Like "[IEY]" Then
                ' e.g. 'edge'
                MetaphAdd "J"
                nCurrent = nCurrent + 3
            Else
                ' e.g. 'edgar'
                MetaphAdd "TK"
                nCurrent = nCurrent + 2
            End If
            GoTo Bottom
        End If

        If IsInArry(pWord, nCurrent, Array("DT", "DD")) Then
            MetaphAdd "T"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If
          ' else
        MetaphAdd "T"
        nCurrent = nCurrent + 1

    Case "F"
        If pWord(nCurrent + 1) = "F" Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
        MetaphAdd "F"

    Case "G"
        If pWord(nCurrent + 1) = "H" Then
            If (nCurrent > 0) And Not pWord(nCurrent) Like "[aeiouy]" Then
                MetaphAdd "K"
                nCurrent = nCurrent + 2
                GoTo Bottom
            End If

            If nCurrent < 2 Then

                ' ghislane, ghiradelli
                If nCurrent = 0 Then
                    If pWord(nCurrent + 2) = "I" Then
                      MetaphAdd "J"
                    Else
                      MetaphAdd "K"
                    End If
                    nCurrent = nCurrent + 2
                    GoTo Bottom
                End If
            End If

            ' Parker's rule (with some further refinements) - e.g., 'hugh'
            ' e.g., 'bough'
            ' e.g., 'broughton'
            If ((nCurrent > 0) And pWord(nCurrent) Like "[BHD]") Or _
               ((nCurrent > 1) And pWord(nCurrent - 1) Like "[BHD]") Or _
               ((nCurrent > 2) And pWord(nCurrent - 2) Like "[BH]") Then

                nCurrent = nCurrent + 2
                GoTo Bottom
            Else
                ' **   e.g., laugh, McLaughlin, cough, gough, rough, tough
                If (nCurrent > 1) And _
                   (pWord(nCurrent) = "U") And _
                    pWord(nCurrent - 1) Like "[CGLRT]" Then

                  MetaphAdd "F"
                Else
                    If (nCurrent > 0) And pWord(nCurrent) <> "I" Then
                      MetaphAdd "K"
                    End If
                End If
                nCurrent = nCurrent + 2
                GoTo Bottom
            End If
        End If

        If pWord(nCurrent + 1) = "N" Then

            If (nCurrent = 0) And pWord(0) Like "[aeiouy]" And Not _
                SlavoGermanic(pWord) Then

              MetaphAdd "KN", "N"
            Else
                ' **   not e.g. 'cagney'
                If (pWord(nCurrent + 2) <> "E" And pWord(nCurrent + 3) <> "Y") And _
                   (pWord(nCurrent + 1) <> "Y") And Not SlavoGermanic(pWord) Then

                 MetaphAdd "N", "KN"
                Else
                  MetaphAdd "KN"
                End If
            End If
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

         ' tagliaro
        If (pWord(nCurrent + 1) = "L" And pWord(nCurrent + 2) = "I") And Not _
            SlavoGermanic(pWord) Then
            MetaphAdd "KL", "L"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        ' **    -ges-,-gep-,-gel-, -gie- at beginning
        If (nCurrent = 0) And ((pWord(nCurrent + 1) = "Y") Or _
           IsInArry(pWord, nCurrent + 1, _
           Array("ES", "EP", "EB", "EL", "EY", "IB", "IL", "IN", "IE", "EI", "ER"))) Then

            MetaphAdd "K", "J"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        '  -ger-,  -gy-
        If ((pWord(nCurrent + 1) = "E" And pWord(nCurrent + 2) = "R") Or _
            pWord(nCurrent + 1) = "Y") And Not _
            IsInArry(pWord, 1, Array("DANGER", "RANGER", "MANGER")) And Not _
            IsInArry(pWord, nCurrent, Array("E", "I")) And Not _
            IsInArry(pWord, nCurrent, Array("RGY", "OGY")) Then

            MetaphAdd "K", "J"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        '  italian e.g, 'biaggi'
        If pWord(nCurrent + 1) Like "[EIY]" Or _
           IsInArry(pWord, nCurrent, Array("AGGI", "OGGI")) Then
            ' obvious germanic
            If IsInArry(pWord, 0, Array("VAN ", "VON ")) Or _
                IsInArry(pWord, 0, Array("SCH")) Or _
                (pWord(nCurrent + 1) = "E" And pWord(nCurrent + 2) = "T") Then
                MetaphAdd "K"
            Else
                ' always soft if french ending
                If IsInArry(pWord, nCurrent + 1, Array("IER ")) Then
                    MetaphAdd "J"
                Else
                 MetaphAdd "J", "K"
                End If
            End If
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        If pWord(nCurrent + 1) = "G" Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
        MetaphAdd "K"

    Case "H"
        ' only keep if first & before vowel or btw. 2 vowels
        If (nCurrent > 0) Then
         PreviousFlag = pWord(nCurrent - 1) Like "[aeiouy]"
        End If
        
        If (nCurrent = 0) Or _
           (PreviousFlag And pWord(nCurrent + 1) Like "[aeiouy]") Then
            
           MetaphAdd "H"
           nCurrent = nCurrent + 2
            
        Else ' also takes care of HH
            nCurrent = nCurrent + 1
        End If

    Case "J"
        ' obvious spanish, jose, san jacinto
        If IsInArry(pWord, nCurrent, Array("JOSE")) Or _
           IsInArry(pWord, 0, Array("SAN ")) Then
            If ((nCurrent = 0) And (pWord(nCurrent + 3) = " ")) Or _
               IsInArry(pWord, 1, Array("SAN ")) Then
                 MetaphAdd "H"
            Else
             MetaphAdd "J", "H"
            End If
            nCurrent = nCurrent + 1
            GoTo Bottom
        End If

        If (nCurrent = 0) And Not IsInArry(pWord, 0, Array("JOSE")) Then
         MetaphAdd "J", "A" ' Yankelovich/Jankelowicz
        Else
            ' spanish pron. of - e.g. bajador
            If pWord(nCurrent) Like "[aeiouy]" And Not _
               SlavoGermanic(pWord) And _
               (pWord(nCurrent + 1) = "A" And pWord(nCurrent + 2) = "O") Then
             MetaphAdd "J", "H"
            Else

                If nCurrent = (nLast - 1) Then
                 MetaphAdd "J", " "
                Else
                    If Not pWord(nCurrent + 1) Like "[LTKSNMBZ]" And Not _
                       pWord(nCurrent) Like "[SKL]" Then
                        MetaphAdd "J"
                    End If
                End If
            End If ' pWord(nCurrent) Like "[aeiouy]", etc.

        End If ' (nCurrent = 0) And Not IsInArry(pWord, 0, Array("JOSE"))
        
         If pWord(nCurrent + 1) = "J" Then ' it could happen!
            nCurrent = nCurrent + 2
         Else
            nCurrent = nCurrent + 1
         End If
        

    Case "K"
        If pWord(nCurrent + 1) = "K" Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
         MetaphAdd "K"

    Case "L"
        If pWord(nCurrent + 1) = "L" Then

            ' spanish e.g. 'cabrillo', 'gallegos'
            If ((nCurrent = (nLength - 3) - 1)) Then
               If (IsInArry(pWord, nCurrent, Array("ILLO", "ILLA", "ALLE")) Or _
                ((IsInArry(pWord, nLast - 1, Array("AS", "OS")) Or _
                pWord(nLast) Like "[AO]")) And _
                IsInArry(pWord, nCurrent, Array("ALLE"))) Then

                 MetaphAdd "L", " "
                nCurrent = nCurrent + 2
                GoTo Bottom
               End If ' (IsInArry, etc.
            End If
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
         MetaphAdd "L"

    Case "M"
        ' dumb, thumb
        If (IsInArry(pWord, nCurrent, Array("UMB")) And _
           ((((nCurrent + 1) = nLast) - 1) Or _
           (pWord(nCurrent + 2) = "E" And pWord(nCurrent + 3) = "R")) Or _
           pWord(nCurrent + 1) = "M") Then
           
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
         MetaphAdd "M"

    Case "N"
        If pWord(nCurrent + 1) = "N" Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
        MetaphAdd "N"

    Case ""
        nCurrent = nCurrent + 1
        MetaphAdd "N"

    Case "P"
        If pWord(nCurrent + 1) = "H" Then

            MetaphAdd "F"
            nCurrent = nCurrent + 2
            GoTo Bottom
        End If

        ' also account for campbell, raspberry
        If (pWord(nCurrent + 1) = "P" And pWord(nCurrent + 2) = "B") Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
             MetaphAdd "P"
        End If

    Case "Q"
        If pWord(nCurrent + 1) = "Q" Then
            nCurrent = nCurrent + 2
        Else
            nCurrent = nCurrent + 1
        End If
        MetaphAdd "K"

    Case "R"
        ' french e.g. rogier, but exclude hochmeier
        If (nCurrent = nLast - 1) And Not SlavoGermanic(pWord) Then
          If (pWord(nCurrent) = "I" And pWord(nCurrent + 1) = "E") Then
             If IsInArry(pWord, nCurrent - 2, Array("ME", "MA")) Then
              MetaphAdd "", "R"
             Else
              GoTo RJump
             End If
          Else
           GoTo RJump
          End If
        Else
RJump:
             MetaphAdd "R"
        End If

         If pWord(nCurrent + 1) = "R" Then
            nCurrent = nCurrent + 2
         Else
            nCurrent = nCurrent + 1
         End If

    Case "S"
        ' special cases island, isle, carlisle, carlysle
        If IsInArry(pWord, nCurrent, Array("ISL", "YSL")) Then
            nCurrent = nCurrent + 1
            GoTo Bottom
        End If

        ' special case sugar
        If (nCurrent = 0) And IsInArry(pWord, nCurrent, Array("SUGAR")) Then

            MetaphAdd "X", "S"
            nCurrent = nCurrent + 1
            GoTo Bottom
        End If

         If (pWord(nCurrent) = "S" And pWord(nCurrent + 1) = "H") Then
            ' germanic
            If IsInArry(pWord, nCurrent + 1, Array("HEIM", "HOEK", "HOLM", "HOLZ")) Then
                MetaphAdd "S"
            Else
                 MetaphAdd "X"
            End If
            nCurrent = nCurrent + 2
            GoTo Bottom
         End If

        ' italian & armenian
        If IsInArry(pWord, nCurrent, Array("SIO", "SIA")) Or _
           IsInArry(pWord, nCurrent, Array("SIAN")) Then

            If Not SlavoGermanic(pWord) Then
              MetaphAdd "S", "X"
            Else
                MetaphAdd "S"
            End If
            nCurrent = nCurrent + 3
            GoTo Bottom
        End If
        
        ' german & anglicizations, e.g. smith matches schmidt, snider matches schneider
        ' also, -sz- in slavic language altho in hungarian it is pronounced "s"
        If ((nCurrent = 0) And _
                pWord(nCurrent + 1) Like "[MNLW]") Or _
                pWord(nCurrent + 1) = "Z" Then

             MetaphAdd "S", "X"
            If pWord(nCurrent + 1) = "Z" Then
                nCurrent = nCurrent + 2
            Else
                nCurrent = nCurrent + 1
            End If
            GoTo Bottom
        End If

        If (pWord(nCurrent) = "S" And pWord(nCurrent + 1) = "C") Then
            ' Schlesinger's rule
            If pWord(nCurrent + 2) = "H" Then
                ' dutch origin, e.g. school, schooner
                If IsInArry(pWord, nCurrent + 3, Array("OO", "ER", "EN", "UY", "ED", "EM")) Then
                    ' schermerhorn, schenker
                    If IsInArry(pWord, nCurrent + 3, Array("ER", "EN")) Then
                     MetaphAdd "X", "SK"
                    Else
                     MetaphAdd "SK"
                    End If
                    nCurrent = nCurrent + 3
                    GoTo Bottom
                Else

                    If (nCurrent = 0) And Not pWord(2) Like "[aeiouy]" And _
                       (pWord(2) <> "W") Then
                      MetaphAdd "X", "S"
                    Else
                      MetaphAdd "X"
                    End If
                    nCurrent = nCurrent + 3
                    GoTo Bottom
                End If
            End If


             If pWord(nCurrent + 2) Like "[IEY]" Then
                MetaphAdd "S"
                nCurrent = nCurrent + 3
                GoTo Bottom
             End If
             ' else
            MetaphAdd "SK"
            nCurrent = nCurrent + 3
            GoTo Bottom
        End If

        ' french e.g. resnais, artois
        If (nCurrent = nLast - 1) And IsInArry(pWord, nCurrent, Array("AI", "OI")) Then
         MetaphAdd "", "S"
        Else
             MetaphAdd "S"
        End If
 
         If (pWord(nCurrent + 1) = "S" And pWord(nCurrent + 2) = "Z") Then
            nCurrent = nCurrent + 2
         Else
            nCurrent = nCurrent + 1
         End If
    Case "T"
         If IsInArry(pWord, nCurrent, Array("TION")) Then
             MetaphAdd "X"
             nCurrent = nCurrent + 3
             GoTo Bottom
         End If

           If IsInArry(pWord, nCurrent, Array("TIA", "TCH")) Then
             MetaphAdd "X"
             nCurrent = nCurrent + 3
             GoTo Bottom
           End If

            If (pWord(nCurrent) = "T" And pWord(nCurrent + 1) = "H") Or _
               IsInArry(pWord, nCurrent, Array("TTH")) Then

               '** special case 'thomas', 'thames' or germanic
               If IsInArry(pWord, nCurrent + 2, Array("OM", "AM")) Or _
                  IsInArry(pWord, 1, Array("VAN ", "VON ")) Or _
                  IsInArry(pWord, 0, Array("SCH")) Then
                  MetaphAdd "T"
               Else
                 MetaphAdd "0", "T"  ' 0 represents TH
               End If
                 nCurrent = nCurrent + 2
                 GoTo Bottom
            End If

             If (pWord(nCurrent + 1) = "T" And pWord(nCurrent + 2) = "D") Then
               nCurrent = nCurrent + 2
             Else
              nCurrent = nCurrent + 1
              MetaphAdd "T"
             End If

    Case "V"
      If pWord(nCurrent + 1) = "V" Then
       nCurrent = nCurrent + 2
      Else
       nCurrent = nCurrent + 1
       MetaphAdd "F"
      End If

    Case "W"
      ' ** can also be in middle of word
      If (pWord(nCurrent) = "W" And pWord(nCurrent + 1) = "R") Then
       MetaphAdd "R"
       nCurrent = nCurrent + 2
       GoTo Bottom
      End If


         If nCurrent = 0 And pWord(nCurrent + 1) Like "[aeiouy]" Or _
            (pWord(nCurrent) = "W" And pWord(nCurrent + 1) = "H") Then
           
           ' ** Wasserman should match Vasserman
           If pWord(nCurrent + 1) Like "[aeiouy]" Then
             MetaphAdd "A", "F"
           Else
             ' ** need Uomo to match Womo
             MetaphAdd "R"
           End If
           
         End If

             ' ** Arnow should match Arnoff
             If (nCurrent = nLast - 1) And pWord(nCurrent) Like "[aeiouy]" Or _
                IsInArry(pWord, nCurrent, Array("EWSKI", "EWSKY", "OWSKI", "OWSKY")) Or _
                IsInArry(pWord, 1, Array("SCH")) Then
                  MetaphAdd "", "F"
                  nCurrent = nCurrent + 1
                  GoTo Bottom
             End If


              ' ** polish e.g. 'filipowicz'
              If IsInArry(pWord, nCurrent, Array("WICZ", "WITZ")) Then
               MetaphAdd "TS", "FX"
               nCurrent = nCurrent + 4
               GoTo Bottom
              End If
              

               ' ** else skip it
               nCurrent = nCurrent + 1

    Case "X"
     If nCurrent > 2 Then
      PreviousFlag = IsInArry(pWord, nCurrent - 3, Array("IAU", "EAU"))
     End If
      If nCurrent > 1 Then
       PreviousFlag2 = IsInArry(pWord, nCurrent - 2, Array("AU", "OU"))
      End If
      
     ' ** french e.g. breaux
     ' I had to fine tune nCurrent position for indexing (different from C++ code)
     If Not ((nCurrent = nLast - 1) And _
        (PreviousFlag Or PreviousFlag2)) Then
        
         MetaphAdd "KS"
     End If
      ' ** Added below if construct (not in C++ code)
      If IsInArry(pWord, 0, Array("AUX")) Then
       MetaphAdd "KS"
      End If

        If (pWord(nCurrent + 1) = "C" And pWord(nCurrent + 2) = "X") Then
         nCurrent = nCurrent + 2
        Else
         nCurrent = nCurrent + 1
        End If

    Case "Z"

     ' ** chinese pinyin e.g. "zhao"
     If pWord(nCurrent + 1) = "H" Then
      MetaphAdd "J"
      nCurrent = nCurrent + 2
      GoTo Bottom
     Else
        
       If (IsInArry(pWord, nCurrent + 1, Array("ZO", "ZI", "ZA")) Or _
          SlavoGermanic(pWord) And pWord(nCurrent) <> "T") Then

        MetaphAdd "S", "TS"
       Else
        MetaphAdd "S"
       End If
       
         If pWord(nCurrent + 1) = "Z" Then
          nCurrent = nCurrent + 2
         Else
          nCurrent = nCurrent + 1
         End If

     End If
     
    Case Else
     nCurrent = nCurrent + 1
     
 End Select

Bottom:

Loop

 MetaPh = Primary
 If Alternate Then
  MetaPh2 = Secondary
 End If
 
 DoubleMetaphone = True
 
End Function


Public Sub MetaphAdd(pChr, Optional pChr2)
' Appends pChr (phonetic code segment) to Primary and/or Secondary
 Primary = Primary & pChr

 If Not IsMissing(pChr2) Then
  Alternate = True

    If pChr2 <> " " Then
     Secondary = Secondary & pChr2
    Else

     If pChr <> " " Then
      Secondary = Secondary & pChr
     End If

    End If
 
 Else

  Secondary = Secondary & pChr

 End If ' not ismissing(pChr2)

End Sub

Public Function IsVowel(pChr, pos As Integer) As Boolean
'* Returns True if pChr is a vowel - else returns false
 IsVowel = Mid(pChr, pos, 1) Like "[aeiouy]"
End Function

Function SlavoGermanic(pArry) As Boolean
   SlavoGermanic = IsInArry(pArry, 0, Array("WK", "CZ"))
   If Not SlavoGermanic Then SlavoGermanic = IsInArry(pArry, 0, Array("WITZ"))
End Function

Public Function IsInStr(pStr, StartDX As Integer, pLen, pList) As Boolean
'*****************************************************************************
'* Checks segment of pStr for the existence of any character(s)in pList.
'* Characters in pList are separated by commas with no spaces.
'* pList example: a,c,d,e or abc,def,ghi
'* StartDX is the start position in pStr, pLen is the number of characters in
'* pStr from StartDX.
'*****************************************************************************
 Dim X As Integer, Increment As Integer, Str2Check
 If pLen > Len(pStr) Then
  Exit Function
 End If
  If StartDX < 1 Then
   Exit Function
  End If
  
 Str2Check = Mid(pStr, StartDX, pLen)
 
 Increment = InStr(pList, ",")
 pList = pList & ","
 For X = 1 To Len(pList) - 1 Step Increment
  If InStr(Str2Check, Mid(pList, X, InStr(Mid(pList, X), ",") - 1)) > 0 Then
   IsInStr = True
   Exit For
  End If
 Next X

End Function

Public Sub RApad(pArry, NumChrs As Integer, pChr)
 ' Right append pArry with pChr NumChrs times
 Dim X As Integer, ALen As Integer
 ALen = UBound(pArry) + NumChrs
 ReDim Preserve pArry(ALen - 1)
 For X = (ALen - NumChrs) To ALen - 1
  pArry(X) = pChr
 Next X
 
End Sub

Public Function IsInArry(pArry, StartDX As Integer, pListArry) As Boolean
'*****************************************************************************
'* Checks sequential element(s) of pArry for the existence of any character(s)
'* in pListArry.
'* Each string in pListArry must be the same length
'* pListArry example: [a] [c] [d] [e] or [abc] [def] [ghi]
'* StartDX is the start position in pArry
'* StrLen is the length of each list item in pListArry
'* List item must be <= UBound(pArry)
'*****************************************************************************
 Dim X As Integer, ArryLen As Integer, z As Integer
 Dim TmpStr, ListArryLen As Integer, StrLen As Integer, Y As Integer
 
 On Error GoTo IsInArryErr
 
 ArryLen = UBound(pArry)
 
 If ArryLen < Len(pListArry(0)) Then Exit Function
 
 ListArryLen = UBound(pListArry)
 StrLen = Len(pListArry(0)) - 1 ' must be option base 0
 
 For X = 0 To ListArryLen
 
   For Y = StartDX To ArryLen
     TmpStr = ""
     
     If Y + StrLen <= ArryLen Then
      For z = Y To (Y + StrLen)
       TmpStr = TmpStr & pArry(z)
      Next z
     End If
     
       If TmpStr = pListArry(X) Then
        IsInArry = True
        Exit Function
       End If
    
   Next Y
   
 Next X
 
IsInArryXit:
 
 Exit Function
 
IsInArryErr:
 
 Resume IsInArryXit
End Function


Public Function Minimum(pVal1, pVal2, Optional pVal3, Optional pVal4)
 Dim X As Integer, TopVal As Integer
 
 Minimum = pVal1
 
 TopVal = 2
 If Not IsMissing(pVal3) Then
  TopVal = 3
   If Not IsMissing(pVal4) Then
    TopVal = 4
   End If
 End If
  
  Select Case TopVal
   Case 2
    If pVal2 < Minimum Then Minimum = pVal2
   Case 3
    If pVal2 < Minimum Then Minimum = pVal2
     If pVal3 < Minimum Then Minimum = pVal3
   Case 4
    If pVal2 < Minimum Then Minimum = pVal2
     If pVal3 < Minimum Then Minimum = pVal3
      If pVal4 < Minimum Then Minimum = pVal4
  End Select
End Function

Public Function Maximum(pVal1, pVal2, Optional pVal3, Optional pVal4)
 Dim X As Integer, TopVal As Integer
 
 Maximum = pVal1
 
 TopVal = 2
 If Not IsMissing(pVal3) Then
  TopVal = 3
   If Not IsMissing(pVal4) Then
    TopVal = 4
   End If
 End If
 
  Select Case TopVal
   Case 2
    If pVal2 > Maximum Then Maximum = pVal2
   Case 3
    If pVal2 > Maximum Then Maximum = pVal2
     If pVal3 > Maximum Then Maximum = pVal3
   Case 4
    If pVal2 > Maximum Then Maximum = pVal2
     If pVal3 > Maximum Then Maximum = pVal3
      If pVal4 > Maximum Then Maximum = pVal4
  End Select
 
End Function

