Public Function WeightedDL(ByVal source As String, ByVal target As String) As Double
Const deleteCost = 1
Const insertCost = 1.1
Const replaceCost = 1.1
Const swapCost = 1.2
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim deleteDistance As Double
Dim insertDistance As Double
Dim matchDistance As Double
Dim maxSourceLetterMatchIndex As Integer
Dim table() As Double
Dim sourceIndexByCharacter() As Variant
Dim candidateSwapIndex As Integer
Dim jSwap As Integer
Dim swapDistance As Double
Dim iSwap As Integer
Dim preSwapCost As Double
If Len(source) = 0 Then
WeightedDL = Len(target) * insertCost
Exit Function
End If
If Len(target) = 0 Then
WeightedDL = Len(source) * deleteCost
Exit Function
End If
ReDim table(Len(source), Len(target))
ReDim sourceIndexByCharacter(0 To 1, 0 To Len(source) - 1)
If Left(source, 1) <> Left(target, 1) Then
table(0, 0) = MinOf(replaceCost, (deleteCost + insertCost))
End If
sourceIndexByCharacter(0, 0) = Left(source, 1)
sourceIndexByCharacter(1, 0) = 0
For i = 1 To Len(source) - 1
deleteDistance = table(i - 1, 0) + deleteCost
insertDistance = ((i + 1) * deleteCost) + insertCost
If Mid(source, i + 1, 1) = Left(target, 1) Then
matchDistance = (i * deleteCost) + 0
Else
matchDistance = (i * deleteCost) + replaceCost
End If
table(i, 0) = MinOf(MinOf(deleteDistance, insertDistance), matchDistance)
Next
For j = 1 To Len(target) - 1
deleteDistance = table(0, j - 1) + insertCost
insertDistance = ((j + 1) * insertCost) + deleteCost
If Left(source, 1) = Mid(target, j + 1, 1) Then
matchDistance = (j * insertCost) + 0
Else
matchDistance = (j * insertCost) + replaceCost
End If
table(0, j) = MinOf(MinOf(deleteDistance, insertDistance), matchDistance)
Next
For i = 1 To Len(source) - 1
If Mid(source, i + 1, 1) = Left(target, 1) Then
maxSourceLetterMatchIndex = 0
Else
maxSourceLetterMatchIndex = -1
End If
For j = 1 To Len(target) - 1
candidateSwapIndex = -1
For k = 0 To UBound(sourceIndexByCharacter, 2)
If sourceIndexByCharacter(0, k) = Mid(target, j + 1, 1) Then candidateSwapIndex = sourceIndexByCharacter(1, k)
Next
jSwap = maxSourceLetterMatchIndex
deleteDistance = table(i - 1, j) + deleteCost
insertDistance = table(i, j - 1) + insertCost
matchDistance = table(i - 1, j - 1)
If Mid(source, i + 1, 1) <> Mid(target, j + 1, 1) Then
matchDistance = matchDistance + replaceCost
Else
maxSourceLetterMatchIndex = j
End If
If candidateSwapIndex <> -1 And jSwap <> -1 Then
iSwap = candidateSwapIndex
If iSwap = 0 And jSwap = 0 Then
preSwapCost = 0
Else
preSwapCost = table(MaxOf(0, iSwap - 1), MaxOf(0, jSwap - 1))
End If
swapDistance = preSwapCost + ((i - iSwap - 1) * deleteCost) + ((j - jSwap - 1) * insertCost) + swapCost
Else
swapDistance = 500
End If
table(i, j) = MinOf(MinOf(MinOf(deleteDistance, insertDistance), matchDistance), swapDistance)
Next
sourceIndexByCharacter(0, i) = Mid(source, i + 1, 1)
sourceIndexByCharacter(1, i) = i
Next
WeightedDL = table(Len(source) - 1, Len(target) - 1)
End Function
Public Function MinOf(ByVal Value1 As Double, ByVal Value2 As Double) As Double
If Value1 > Value2 Then
MinOf = Value2
Else
MinOf = Value1
End If
End Function
Public Function MaxOf(ByVal Value1 As Double, ByVal Value2 As Double) As Double
If Value1 < Value2 Then
MaxOf = Value2
Else
MaxOf = Value1
End If
End Function
