home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / A_Comprehe2007317182006.psc / SpellCheck / clsPhoneme.cls
Text File  |  2006-07-17  |  5KB  |  149 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsPhoneme"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. '// Please see the accompanying documentation for the algorithms
  17.  
  18. '// Returns the 4 letter soundex for an english word
  19. Private Function Soundex(argWord As String)
  20. Dim workStr As String, i As Long, replaceMask(5) As Boolean
  21.  
  22.     '// Capitalize it to remove ambiguity
  23.     argWord = UCase$(argWord)
  24.     
  25.     '// 1. Retain the first letter of the string
  26.     workStr = Left$(argWord, 1)
  27.     
  28.     '// 2. Replacement
  29.     '   [a, e, h, i, o, u, w, y] = 0
  30.     '   [b, f, p, v] = 1
  31.     '   [c, g, j, k, q, s, x, z] = 2
  32.     '   [d, t] = 3
  33.     '   [l] = 4
  34.     '   [m, n] = 5
  35.     '   [r] = 6
  36.     
  37.     For i = 2 To Len(argWord)
  38.         Select Case Mid$(argWord, i, 1)
  39.             Case "B", "F", "P", "V"
  40.                 If replaceMask(0) = False Then
  41.                     workStr = workStr & Chr$(49) '// 1
  42.                     replaceMask(0) = True
  43.                 End If
  44.                 
  45.             Case "C", "G", "J", "K", "Q", "S", "X", "Z"
  46.                 If replaceMask(1) = False Then
  47.                     workStr = workStr & Chr$(50) '// 2
  48.                     replaceMask(1) = True
  49.                 End If
  50.             
  51.             Case "D", "T"
  52.                 If replaceMask(2) = False Then
  53.                     workStr = workStr & Chr$(51) '// 3
  54.                     replaceMask(2) = True
  55.                 End If
  56.             
  57.             Case "L"
  58.                 If replaceMask(3) = False Then
  59.                     workStr = workStr & Chr$(52) '// 4
  60.                     replaceMask(3) = True
  61.                 End If
  62.             
  63.             Case "M", "N"
  64.                 If replaceMask(4) = False Then
  65.                     workStr = workStr & Chr$(53) '// 5
  66.                     replaceMask(4) = True
  67.                 End If
  68.                 
  69.             Case "R"
  70.                 If replaceMask(5) = False Then
  71.                     workStr = workStr & Chr$(56) '// 6
  72.                     replaceMask(5) = True
  73.                 End If
  74.             
  75.             '// A, E, H, I, O, U, W, Y do nothing
  76.         End Select
  77.     Next i
  78.     
  79.     '// 5. Return the first four bytes padded with 0.
  80.     If Len(workStr) > 4 Then
  81.         Soundex = Left$(workStr, 4)
  82.     Else
  83.         Soundex = workStr & Space$(4 - Len(workStr))
  84.     End If
  85. End Function
  86.  
  87. '// Returns the Minimum of 3 numbers
  88. Private Function min3(ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long) As Long
  89.     min3 = n1
  90.     If n2 < min3 Then min3 = n2
  91.     If n3 < min3 Then min3 = n3
  92. End Function
  93.  
  94. '// Returns the Levenshtein Distance between 2 strings.
  95. Private Function LevenshteinDistance(argStr1 As String, argStr2 As String) As Long
  96. Dim m As Long, n As Long
  97. Dim editMatrix() As Long, i As Long, j As Long, cost As Long
  98. Dim str1_i As String, str2_j As String
  99. Dim p() As Long, q() As Long, r As Long
  100. Dim x As Long, y As Long
  101.  
  102.     n = Len(argStr1)
  103.     m = Len(argStr2)
  104.     
  105.     'If (n = 0) Or (m = 0) Then Exit Function
  106.     ReDim editMatrix(n, m) As Long
  107.     
  108.     
  109.     For i = 0 To n
  110.         editMatrix(i, 0) = i
  111.     Next
  112.     
  113.     For j = 0 To m
  114.         editMatrix(0, j) = j
  115.     Next
  116.     
  117.     For i = 1 To n
  118.         str1_i = Mid$(argStr1, i, 1)
  119.         For j = 1 To m
  120.             str2_j = Mid$(argStr2, j, 1)
  121.             If str1_i = str2_j Then
  122.                 cost = 0
  123.             Else
  124.                 cost = 1
  125.             End If
  126.             
  127.             editMatrix(i, j) = min3(editMatrix(i - 1, j) + 1, editMatrix(i, j - 1) + 1, editMatrix(i - 1, j - 1) + cost)
  128.         Next j
  129.     Next i
  130.             
  131.     LevenshteinDistance = editMatrix(n, m)
  132.     Erase editMatrix
  133. End Function
  134.  
  135.  
  136. Public Function GetSoundexWord(ByVal inputStr As String) As String
  137.     If inputStr <> vbNullString Then GetSoundexWord = Soundex(inputStr)
  138. End Function
  139.  
  140. Public Function GetLevenshteinDistance(ByVal inputStr1 As String, ByVal inputStr2 As String) As Long
  141.     If inputStr1 = vbNullString Then
  142.         GetLevenshteinDistance = Len(inputStr2)
  143.     ElseIf inputStr2 = vbNullString Then
  144.         GetLevenshteinDistance = Len(inputStr1)
  145.     Else
  146.         GetLevenshteinDistance = LevenshteinDistance(inputStr1, inputStr2)
  147.     End If
  148. End Function
  149.