Hallo Jacqueline,
alle Schreibfehler findet mein Programm nicht, aber die meisten.
Teste mal:
' **********************************************************************
' Modul: bas_Diffuse_Search Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Option Compare Text
Private Type DMValue
strBaseWord As String
Primary As String
Secondary As String
HasAlternate As Boolean
End Type
Sub Dateien_prüfen()
Dim i As Long ' Zählwert für Reihe
Dim strTemp As String, strFilename As String
Dim blnFound As Boolean
Const sPath As String = "C:\Users\" 'ANPASSEN
Const sSpalte As Long = 1 'Spalte 1 im Reparaturbuch
'Alle Zellen der angebenen Spalte durchlaufen
For i = 1 To Cells(Rows.Count, sSpalte).End(xlUp).Row
'Ist ein Zelleninhalt vorhanden?
If Not IsEmpty(Cells(i, sSpalte).Value) Then
'Ist die Datei im angegebenen Ordner vorhanden?
If Dir$(sPath & Cells(i, sSpalte) & ".xlsx") <> vbNullString Then
'wenn ja, dann Zeile grau hinterlegen
Cells(i, 1).EntireRow.Interior.ColorIndex = 15
Else
strTemp = Transform(Cells(i, sSpalte).Value & ".xlsx")
strFilename = Dir$(sPath & "*.xlsx")
Do Until strFilename = vbNullString
If Transform(strFilename) = strTemp Then
blnFound = True
Exit Do
End If
strFilename = Dir$
Loop
If blnFound Then
Cells(i, 1).EntireRow.Interior.ColorIndex = 15
Cells(i, sSpalte).Value = Left$(strFilename, InStrRev(strFilename, ".") - 1)
blnFound = False
Else
Cells(i, 1).EntireRow.Interior.ColorIndex = 0
End If
End If
End If
Next i
End Sub
Private Function Transform( _
pstrCompareText As String) As Variant
Dim udtDMValue As DMValue
udtDMValue = DoubleMetaphone(pstrCompareText)
Transform = udtDMValue.Primary
End Function
Private Function DoubleMetaphone( _
ByVal strInputString As String) As DMValue
Dim lngCurrentPosition As Long, lngLast As Long
Dim strCurrentChar As String, strTmpPrimary As String, strTmpSecondary As String
lngCurrentPosition = 1
lngLast = Len(strInputString)
strTmpPrimary = vbNullString
strTmpSecondary = vbNullString
DoubleMetaphone.strBaseWord = strInputString
strInputString = UCase$(strInputString)
strInputString = strInputString & " "
If ContainsAnyOf(Left$(strInputString, 2), "GN", "KN", "PN", "WR", "PS") Then _
lngCurrentPosition = lngCurrentPosition + 1
If Left$(strInputString, 1) = "X" Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
lngCurrentPosition = lngCurrentPosition + 1
End If
Do Until lngCurrentPosition > lngLast
get_out_of_select:
strCurrentChar = Mid$(strInputString, lngCurrentPosition, 1)
Select Case strCurrentChar
Case "A", "E", "I", "O", "U", "Y"
If lngCurrentPosition = 1 Then
strTmpPrimary = strTmpPrimary & "A"
strTmpSecondary = strTmpSecondary & "A"
End If
lngCurrentPosition = lngCurrentPosition + 1
Case "B"
strTmpPrimary = strTmpPrimary & "P"
strTmpSecondary = strTmpSecondary & "P"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "B" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
Case "Ç"
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
lngCurrentPosition = lngCurrentPosition + 1
Case "C"
If lngCurrentPosition > 2 _
And (Not Cbool(InStr(1, "AEIOUY", MyMid(strInputString, lngCurrentPosition - 2, 1)))) _
And MyMid(strInputString, lngCurrentPosition - 1, 3) = "ACH" _
And ((Mid$(strInputString, lngCurrentPosition + 2, 1) <> "I") _
And (Mid$(strInputString, lngCurrentPosition + 2, 1) <> "E" _
Or (MyMid(strInputString, lngCurrentPosition - 2, 6) = "BACHER" _
Or MyMid(strInputString, lngCurrentPosition - 2, 6) = "MACHER"))) Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If lngCurrentPosition = 1 And Left$(strInputString, 6) = "CAESAR" Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 4) = "CHIA" Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "CH" Then
If lngCurrentPosition > 1 And Mid$(strInputString, lngCurrentPosition, 4) = "CHAE" Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "X"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If (lngCurrentPosition = 1 _
And ((Mid$(strInputString, lngCurrentPosition + 1, 5) = "HARAC" _
Or Mid$(strInputString, lngCurrentPosition + 1, 5) = "HARIS") _
Or ContainsAnyOf(Mid$(strInputString, lngCurrentPosition + 1, 3), "HOR", "HYM", "HIA", "HEM") _
And Mid$(strInputString, 1, 5) <> "CHORE")) Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If (Left$(strInputString, 4) = "VAN " Or Left$(strInputString, 4) = "VON " _
Or Left$(strInputString, 3) = "SCH") _
Or ContainsAnyOf(MyMid(strInputString, lngCurrentPosition - 2, 6), "ORCHES", "ARCHIT", "ORCHID") _
Or InStr(1, "TS", MyMid(strInputString, lngCurrentPosition + 2, 1)) _
Or (((InStr(1, "AOUE", MyMid(strInputString, lngCurrentPosition - 1, 1)) > 0) Or lngCurrentPosition = 1) _
And InStr(1, "LRNMBHFVW ", Mid$(strInputString, lngCurrentPosition + 2, 1))) Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
Else
If lngCurrentPosition > 1 Then
If Left$(strInputString, 2) = "MC" Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
Else
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "K"
End If
Else
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
End If
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "CZ" _
And MyMid(strInputString, lngCurrentPosition - 2) <> "CZ" Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "X"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition + 1, 3) = "CIA" Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
If (Mid$(strInputString, lngCurrentPosition, 2) = "CC") _
And Not (lngCurrentPosition = 1 And Left$(strInputString, 1) = "M") Then
If InStr(1, "IEH", Mid$(strInputString, lngCurrentPosition + 2, 1)) _
And Mid$(strInputString, lngCurrentPosition + 2, 2) <> "HU" Then
If lngCurrentPosition = 2 And Left$(strInputString, 1) = "A" _
Or (MyMid(strInputString, lngCurrentPosition - 1, 5) = "UCCEE" _
Or MyMid(strInputString, lngCurrentPosition - 1, 5) = "UCCES") Then
strTmpPrimary = strTmpPrimary & "KS"
strTmpSecondary = strTmpSecondary & "KS"
Else
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
End If
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
Else
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
End If
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition, 2), "CK", "CG", "CQ") Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition, 2), "CI", "CE", "CY") Then
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition, 3), "CIO", "CIE", "CIA") Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "X"
Else
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition + 1, 2), " C", " Q", " G") Then
lngCurrentPosition = lngCurrentPosition + 3
Else
If InStr(1, "CKQ", Mid$(strInputString, lngCurrentPosition + 1, 1)) _
And (Mid$(strInputString, lngCurrentPosition + 1, 2) = "CE" _
Or Mid$(strInputString, lngCurrentPosition + 1, 2) = "CI") Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
End If
Case "D"
If Mid$(strInputString, lngCurrentPosition, 2) = "DG" Then
If InStr(1, "EIY", Mid$(strInputString, lngCurrentPosition + 2, 1)) Then
' e.g. "edge"
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "J"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
Else
strTmpPrimary = strTmpPrimary & "TK"
strTmpSecondary = strTmpSecondary & "TK"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "DT" _
Or Mid$(strInputString, lngCurrentPosition, 2) = "DD" Then
strTmpPrimary = strTmpPrimary & "T"
strTmpSecondary = strTmpSecondary & "T"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
strTmpPrimary = strTmpPrimary & "T"
strTmpSecondary = strTmpSecondary & "T"
lngCurrentPosition = lngCurrentPosition + 1
Case "F"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "F" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "F"
strTmpSecondary = strTmpSecondary & "F"
Case "G"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "H" Then
If lngCurrentPosition > 1 And InStr(1, "AEIOUY", MyMid(strInputString, lngCurrentPosition - 1, 1)) < 1 Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If lngCurrentPosition < 4 Then
If lngCurrentPosition = 1 Then
If Mid$(strInputString, lngCurrentPosition + 2, 1) = "I" Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "J"
Else
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
End If
End If
If (lngCurrentPosition > 2 And ContainsAnyOf(MyMid(strInputString, _
(lngCurrentPosition - 2), 1), "B", "H", "D") _
Or (lngCurrentPosition > 3 And ContainsAnyOf(MyMid(strInputString, _
(lngCurrentPosition - 3), 1), "B", "H", "D")) _
Or (lngCurrentPosition > 4 And ContainsAnyOf(MyMid(strInputString, _
(lngCurrentPosition - 4), 1), "B", "H"))) Then
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
Else
If (lngCurrentPosition > 3 _
And MyMid(strInputString, lngCurrentPosition - 1, 1) = "U" _
And ContainsAnyOf(MyMid(strInputString, (lngCurrentPosition - 3), 1), _
"C", "G", "L", "R", "T")) Then
strTmpPrimary = strTmpPrimary & "F"
strTmpSecondary = strTmpSecondary & "F"
Else
If (lngCurrentPosition > 1 And MyMid(strInputString, lngCurrentPosition - 1, 1) <> "I") Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
End If
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
End If
If MyMid(strInputString, lngCurrentPosition + 1, 1) = "N" Then
If lngCurrentPosition = 2 And InStr(1, "AEIOUY", Left$(strInputString, 1)) _
And (IsSlavoGermanic(strInputString) = False) Then
strTmpPrimary = strTmpPrimary & "KN"
strTmpSecondary = strTmpSecondary & "N"
Else
If (MyMid(strInputString, (lngCurrentPosition + 2), 2) <> "EY") _
And MyMid(strInputString, lngCurrentPosition + 1, 1) <> "Y" _
And Not IsSlavoGermanic(strInputString) Then
strTmpPrimary = strTmpPrimary & "N"
strTmpSecondary = strTmpSecondary & "KN"
Else
strTmpPrimary = strTmpPrimary & "KN"
strTmpSecondary = strTmpSecondary & "KN"
End If
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If MyMid(strInputString, (lngCurrentPosition + 1), 2) = "LI" _
And Not IsSlavoGermanic(strInputString) Then
strTmpPrimary = strTmpPrimary & "KL"
strTmpSecondary = strTmpSecondary & "L"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If (lngCurrentPosition = 1 _
And (MyMid(strInputString, lngCurrentPosition + 1, 1) = "Y" _
Or ContainsAnyOf(Mid$(strInputString, (lngCurrentPosition + 1), 2), _
"ES", "EP", "EB", "EL", "EY", "IB", "IL", "IN", "IE", "EI", "ER"))) Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "J"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
' -ger-, -gy-
If ((MyMid(strInputString, (lngCurrentPosition + 1), 2) = "ER") _
Or (MyMid(strInputString, lngCurrentPosition + 1, 1) = "Y")) _
And (Not ContainsAnyOf(MyMid(strInputString, 1, 6), "DANGER", "RANGER", "MANGER")) _
And (InStr(1, "EI", MyMid(strInputString, lngCurrentPosition - 1, 1)) < 1) _
And (Not ContainsAnyOf(MyMid(strInputString, (lngCurrentPosition - 1), 3), "RGY", "OGY")) Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "J"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If InStr(1, "EIY", (MyMid(strInputString, (lngCurrentPosition + 1), 1))) _
Or ContainsAnyOf(MyMid(strInputString, (lngCurrentPosition - 1), 4), "AGGI", "OGGI") Then
If ((ContainsAnyOf(MyMid(strInputString, 1, 4), "VAN ", "VON ") _
Or MyMid(strInputString, 1, 3) = "SCH") _
Or MyMid(strInputString, (lngCurrentPosition + 1), 2) = "ET") Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
End If
If MyMid(strInputString, (lngCurrentPosition + 1), 4) = "IER " Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "J"
Else
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "K"
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If MyMid(strInputString, lngCurrentPosition + 1, 1) = "G" Then
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
Else
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
End If
Case "H"
If lngCurrentPosition = 1 Or Cbool(InStr(1, "AEIOUY", MyMid(strInputString, _
lngCurrentPosition - 1, 1))) Then
If InStr(1, "AEIOUY", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
strTmpPrimary = strTmpPrimary & "H"
strTmpSecondary = strTmpSecondary & "H"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
End If
lngCurrentPosition = lngCurrentPosition + 1
Case "J"
If Mid$(strInputString, lngCurrentPosition, 4) = "JOSE" Or Left$(strInputString, 4) = "SAN " Then
If ((lngCurrentPosition = 1) And ((Mid$(strInputString, lngCurrentPosition + 4, 1) = " ") _
Or (Left$(strInputString, 4) = "SAN "))) Then
strTmpPrimary = strTmpPrimary & "H"
strTmpSecondary = strTmpSecondary & "H"
Else
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "H"
End If
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
End If
If (lngCurrentPosition = 1) And (Mid$(strInputString, lngCurrentPosition, 4) <> "JOSE") Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "A"
Else
If InStr(1, "AEIOUY", MyMid(strInputString, lngCurrentPosition - 1, 1)) > 0 _
And (IsSlavoGermanic(strInputString) = False) _
And InStr(1, "AO", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "H"
Else
If lngCurrentPosition = lngLast Then
strTmpPrimary = strTmpPrimary & "J"
Else
If (InStr(1, "LTKSNMBZ", Mid$(strInputString, lngCurrentPosition + 1, 1)) < 1) _
And (InStr(1, "SKL", MyMid(strInputString, lngCurrentPosition - 1, 1)) < 1) Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "J"
End If
End If
End If
End If
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "J" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
Case "K"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "K" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
Case "L"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "L" Then
If (((lngCurrentPosition = lngLast - 2) _
And ContainsAnyOf(MyMid(strInputString, lngCurrentPosition - 1, 4), "ILLO", "ILLA", "ALLE")) _
Or ((ContainsAnyOf(MyMid(strInputString, lngLast - 1, 2), "AS", "OS") _
Or InStr(1, "AO", Mid$(strInputString, lngLast, 1))) _
And MyMid(strInputString, lngCurrentPosition - 1, 4) = "ALLE")) Then
strTmpPrimary = strTmpPrimary & "L"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "L"
strTmpSecondary = strTmpSecondary & "L"
Case "M"
If (MyMid(strInputString, lngCurrentPosition - 1, 3) = "UMB" _
And (lngCurrentPosition + 1 = lngLast _
Or Mid$(strInputString, lngCurrentPosition + 2, 2) = "ER")) _
Or Mid$(strInputString, lngCurrentPosition + 1, 1) = "M" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "M"
strTmpSecondary = strTmpSecondary & "M"
Case "N"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "N" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "N"
strTmpSecondary = strTmpSecondary & "N"
Case "Ñ"
strTmpPrimary = strTmpPrimary & "N"
strTmpSecondary = strTmpSecondary & "N"
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
Case "P"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "H" _
Or Mid$(strInputString, lngCurrentPosition + 1, 1) = "F" Then
strTmpPrimary = strTmpPrimary & "F"
strTmpSecondary = strTmpSecondary & "F"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If InStr(1, "PB", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "P"
strTmpSecondary = strTmpSecondary & "P"
Case "Q"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "Q" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "K"
strTmpSecondary = strTmpSecondary & "K"
Case "R"
If lngCurrentPosition = lngLast _
And Not IsSlavoGermanic(strInputString) _
And MyMid(strInputString, lngCurrentPosition - 2, 2) = "IE" _
And MyMid(strInputString, lngCurrentPosition - 4, 2) <> "ME" _
And MyMid(strInputString, lngCurrentPosition - 4, 2) <> "MA" Then
strTmpSecondary = strTmpSecondary & "R"
Else
strTmpPrimary = strTmpPrimary & "R"
strTmpSecondary = strTmpSecondary & "R"
End If
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "R" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
Case "S"
If MyMid(strInputString, lngCurrentPosition - 1, 3) = "ISL" _
Or MyMid(strInputString, lngCurrentPosition - 1, 3) = "YSL" Then
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
End If
If lngCurrentPosition = 1 And Left$(strInputString, 5) = "SUGAR" Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "S"
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "SH" Then
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition + 1, 4), _
"HEIM", "HOEK", "HOLM", "HOLZ") Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
Else
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 3) = "SIO" _
Or Mid$(strInputString, lngCurrentPosition, 3) = "SIA" _
Or Mid$(strInputString, lngCurrentPosition, 4) = "SIAN" Then
If IsSlavoGermanic(strInputString) = False Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "X"
Else
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
End If
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
If (lngCurrentPosition = 1) _
And InStr(1, "MNLW", Mid$(strInputString, lngCurrentPosition + 1, 1)) _
Or Mid$(strInputString, lngCurrentPosition + 1, 1) = "Z" Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "X"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "Z" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "SC" Then
If Mid$(strInputString, lngCurrentPosition + 2, 1) = "H" Then
If ContainsAnyOf(Mid$(strInputString, lngCurrentPosition + 3, 2), _
"OO", "ER", "EN", "UY", "ED", "EM") Then
If Mid$(strInputString, lngCurrentPosition + 3, 2) = "ER" _
Or Mid$(strInputString, lngCurrentPosition + 3, 2) = "EN" Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "SK"
Else
strTmpPrimary = strTmpPrimary & "SK"
strTmpSecondary = strTmpSecondary & "SK"
End If
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
Else
If lngCurrentPosition = 1 _
And (InStr(1, "AEIOUYW", Mid$(strInputString, 4, 1)) < 1) Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "S"
Else
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
End If
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
ElseIf Cbool(InStr(1, "IEY", Mid$(strInputString, lngCurrentPosition + 2, 1))) Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
strTmpPrimary = strTmpPrimary & "SK"
strTmpSecondary = strTmpSecondary & "SK"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
If lngCurrentPosition = lngLast _
And (MyMid(strInputString, lngCurrentPosition - 2, 2) = "AI" _
Or MyMid(strInputString, lngCurrentPosition - 2, 2) = "OI") Then
strTmpSecondary = strTmpSecondary & "S"
Else
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
End If
If InStr(1, "SZ", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
Case "T"
If Mid$(strInputString, lngCurrentPosition, 4) = "TION" Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 3) = "TIA" _
Or Mid$(strInputString, lngCurrentPosition, 3) = "TCH" Then
strTmpPrimary = strTmpPrimary & "X"
strTmpSecondary = strTmpSecondary & "X"
lngCurrentPosition = lngCurrentPosition + 3
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 2) = "TH" _
Or Mid$(strInputString, lngCurrentPosition, 3) = "TTH" Then
If Mid$(strInputString, lngCurrentPosition + 2, 2) = "OM" _
Or Mid$(strInputString, lngCurrentPosition + 2, 2) = "AM" _
Or Left$(strInputString, 4) = "VAN " _
Or Left$(strInputString, 4) = "VON " _
Or Left$(strInputString, 3) = "SCH" Then
strTmpPrimary = strTmpPrimary & "T"
strTmpSecondary = strTmpSecondary & "T"
Else
strTmpPrimary = strTmpPrimary & "0"
strTmpSecondary = strTmpSecondary & "T"
End If
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If InStr(1, "TD", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "T"
strTmpSecondary = strTmpSecondary & "T"
Case "V"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "V" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
strTmpPrimary = strTmpPrimary & "F"
strTmpSecondary = strTmpSecondary & "F"
GoTo get_out_of_select
Case "W"
If Mid$(strInputString, lngCurrentPosition, 2) = "WR" Then
strTmpPrimary = strTmpPrimary & "R"
strTmpSecondary = strTmpSecondary & "R"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If lngCurrentPosition = 1 _
And (InStr(1, "AEIOUY", Mid$(strInputString, lngCurrentPosition + 1, 1)) _
Or Mid$(strInputString, lngCurrentPosition, 2) = "WH") Then
If InStr(1, "AEIOUY", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then
strTmpPrimary = strTmpPrimary & "A"
strTmpSecondary = strTmpSecondary & "F"
Else
strTmpPrimary = strTmpPrimary & "A"
strTmpSecondary = strTmpSecondary & "A"
End If
End If
If (lngCurrentPosition = lngLast And InStr(1, "AEIOUY", _
MyMid(strInputString, lngCurrentPosition - 1, 1)) _
Or ContainsAnyOf(MyMid(strInputString, lngCurrentPosition - 1, 5), _
"EWSKI", "EWSKY", "OWSKI", "OWSKY") _
Or Left$(strInputString, 3) = "SCH") Then
strTmpSecondary = strTmpSecondary & "F"
lngCurrentPosition = lngCurrentPosition + 1
GoTo get_out_of_select
End If
If Mid$(strInputString, lngCurrentPosition, 4) = "WICZ" _
Or Mid$(strInputString, lngCurrentPosition, 4) = "WITZ" Then
strTmpPrimary = strTmpPrimary & "TS"
strTmpSecondary = strTmpSecondary & "FX"
lngCurrentPosition = lngCurrentPosition + 4
GoTo get_out_of_select
End If
lngCurrentPosition = lngCurrentPosition + 1
Case "X"
If Not (lngCurrentPosition = lngLast _
And (MyMid(strInputString, lngCurrentPosition - 3, 3) = "IAU" _
Or MyMid(strInputString, lngCurrentPosition - 3, 3) = "IAU" _
Or MyMid(strInputString, lngCurrentPosition - 2, 2) = "AU" _
Or MyMid(strInputString, lngCurrentPosition - 2, 2) = "OU")) Then
strTmpPrimary = strTmpPrimary & "KS"
strTmpSecondary = strTmpSecondary & "KS"
End If
If InStr(1, "CX", Mid$(strInputString, lngCurrentPosition + 1, 1)) Then _
lngCurrentPosition = lngCurrentPosition + 1
lngCurrentPosition = lngCurrentPosition + 1
Case "Z"
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "H" Then
strTmpPrimary = strTmpPrimary & "J"
strTmpSecondary = strTmpSecondary & "J"
lngCurrentPosition = lngCurrentPosition + 2
GoTo get_out_of_select
End If
If (ContainsAnyOf(Mid$(strInputString, lngCurrentPosition + 1, 2), "ZO", "ZI", "ZA") _
Or (IsSlavoGermanic(strInputString) _
And (lngCurrentPosition > 1 _
And MyMid(strInputString, lngCurrentPosition - 1, 1) <> "T"))) Then
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "TS"
Else
strTmpPrimary = strTmpPrimary & "S"
strTmpSecondary = strTmpSecondary & "S"
End If
If Mid$(strInputString, lngCurrentPosition + 1, 1) = "Z" Then
lngCurrentPosition = lngCurrentPosition + 2
Else
lngCurrentPosition = lngCurrentPosition + 1
End If
Case Else
lngCurrentPosition = lngCurrentPosition + 1
End Select
Loop
DoubleMetaphone.Primary = strTmpPrimary
DoubleMetaphone.Secondary = strTmpSecondary
If strTmpPrimary <> strTmpSecondary Then DoubleMetaphone.HasAlternate = True
End Function
Private Function MyMid( _
ByVal strInputString As String, _
ByVal Start As Long, _
Optional ByVal Length As Long) As String
If Start < 1 Then
MyMid = vbNull
Else
MyMid = Mid$(strInputString, Start, Length)
End If
End Function
Private Function IsSlavoGermanic( _
ByVal strInputString As String) As Boolean
If ContainsAnyOf(strInputString, "W", "K", "CZ", "WITZ") Then _
IsSlavoGermanic = True
End Function
Private Function ContainsAnyOf( _
ByVal strBaseStringToSearch As String, _
ParamArray vntSubstringsToSearchFor() As Variant) As Boolean
Dim vntCurrentlySearching As Variant
For Each vntCurrentlySearching In vntSubstringsToSearchFor()
If Cbool(InStr(1, strBaseStringToSearch, vntCurrentlySearching)) Then
ContainsAnyOf = True
Exit For
End If
Next
End Function
Gruß
Nepumuk