• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• this code used to search in arabic text, by appling SOUNDEX technique for arabic searching and for

this code used to search in arabic text, by appling SOUNDEX technique for arabic searching and for

this code used to search in arabic text, by appling SOUNDEX technique for arabic searching and for arabs. i hope to help u :-) the function is

Rate this code used to search in arabic text, by appling SOUNDEX technique for arabic searching and for

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Public Function SOUNDEX(Surname As String) As String
' Developed by Richard J. Yanco
' This function follows the Soundex rules given at
' http://home.utah-inter.net/kinsearch/Soundex.html

    Dim Result As String, c As String * 1
    Dim Location As Integer

    Surname = UCase(Surname)
' remove ال from the word
'****************************************************
    If Left(Surname, 2) = "ال" Then
        Surname = Mid(Surname, 3)
    End If
'****************************************************

' get the code for each character in the word
'****************************************************
        Result = ""
        For Location = 1 To Len(Surname)
            Result = Result & Category(Mid(Surname, Location, 1))
        Next Location
'****************************************************

'Remove the repeated character
'****************************************************
        Location = 1
        Do While Location < Len(Result)
            If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then
                Result = Left(Result, Location) & Mid(Result, Location + 2)
            Else
                Location = Location + 1
            End If
        Loop
'****************************************************

'
'****************************************************
        If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then
            Result = Left(Result, 1) & Mid(Result, 3)
        End If
'****************************************************
    
'remove the unkown characeter
'*****************************************************
        For Location = 1 To Len(Result)
            If Mid(Result, Location, 1) = "/" Then
                Result = Left(Result, Location - 1) & Mid(Result, Location + 1)
            End If
        Next
'*****************************************************

'get the first 4 haracters
'*****************************************************
        Select Case Len(Result)
            Case 4
                SOUNDEX = Result
            Case Is < 4
                SOUNDEX = Result & String(4 - Len(Result), "0")
            Case Is > 4
                SOUNDEX = Left(Result, 4)
        End Select
'*****************************************************
End Function

Private Function Category(c) As String

    Select Case True
        Case c Like "[&#1607;&#1581;]"
           Category = "1"
        Case c Like "[&#1579;&#1587;&#1589;]"
             Category = "2"
        Case c Like "[&#1603;&#1602;]"
            Category = "3"
        Case c Like "[&#1584;&#1586;]"
            Category = "4"
        Case c Like "[&#1593;&#1569;]"
            Category = "5"
        Case c Like "[&#1590;&#1592;&#1591;]"
            Category = "6"
        Case c Like "[&#1604;&#1606;&#1585;]"
            Category = "7"
        Case c Like "[&#1594;&#1582;]"
            Category = "8"
        Case c Like "[&#1588;]"
            Category = "9"
        Case c Like "[&#1578;&#1583;&#1580;]"
            Category = "A"
        Case c Like "[&#1610;]"
            Category = "B"
        Case c Like "[&#1605;&#1576;]"
            Category = "C"
        Case c Like "[&#1601;]"
            Category = "D"
        
        Case Else
            Category = ""

    End Select
End Function