I found a c program called similcmp on the net and converted it to vba
if anybody wants it. I'll post the technical research on it if there
is any call for it. It looks like it could be a useful tool for
breaking ties when a phonic call returns a bunch of possibilities.
Also, I'm looking for someone that has a zip code file with alternate
city names (the PO assigns whatever name is convenient to them), email
me if you got something.
Thanks, Tom
tw*@gate.net
int
#ifdef PROTOTYPES
GCsubstr(char *st1, char *end1, char *st2, char *end2)
#else
GCsubstr(st1, end1, st2, end2)
char *st1;
char *end1;
char *st2;
char *end2;
#endif
{
register char *a1, *a2;
char *b1, *s1, *b2, *s2;
short max, i;
if (end1 <= st1 || end2 <= st2) return(0);
if (end1 == st1 + 1 && end2 == st2 + 1) return(0);
max = 0; b1 = end1; b2 = end2;
for (a1 = st1; a1 < b1; a1++) {
for (a2 = st2; a2 < b2; a2++) {
if (*a1 == *a2) {
/* determine length of common substring */
for (i = 1; a1[i] && (a1[i] == a2[i]); i++) /* do nothing */;
if (i > max) {
max = i; s1 = a1; s2 = a2;
b1 = end1 - max; b2 = end2 - max;
}
}
}
}
if (!max) return(0);
max += GCsubstr(s1 + max, end1, s2 + max, end2); /* rhs */
max += GCsubstr(st1, s1, st2, s2); /* lhs */
return(max);
}
int
#ifdef PROTOTYPES
simil(char *s1, char *s2)
#else
simil(s1, s2)
char *s1;
char *s2;
#endif
{
int l1 = strlen(s1), l2 = strlen(s2);
if (strcmp(s1, s2) == 0) return(100); /* exact match end-case */
return(200 * GCsubstr(s1, s1 + l1, s2, s2 + l2) / (l1 + l2));
}
#endif /* similcmp_c */
Public Function SimilCmp(Known As String, Match As String) As Single
Dim k() As Byte ' Known word array
Dim m() As Byte ' Match word array
Dim ks As Integer ' Known string length
Dim ms As Integer ' Match string length
ks = Len(Known): ms = Len(Match) ' initialize Known and
Match string lengths
If ks = 0 Or ms = 0 Then Exit Function ' if Known or Match are
empty, return 0%
If Known = Match Then ' if strings the same
SimilCmp = 100 ' return 100%
Else ' if strings are NOT the
same
k = StrConv(UCase(Known), vbFromUnicode) ' load Known array
m = StrConv(UCase(Match), vbFromUnicode) ' load Match array
SimilCmp = GcSubStr(k(), 0, ks, m(), 0, ms) ' get number of matching
characters
SimilCmp = (200 * SimilCmp / (ks + ms)) ' calculate precentage
Erase k ' free array resources
Erase m ' free array resources
End If ' if strings match
End Function
Private Function GcSubStr(k() As Byte, ko As Integer, ks As Integer,
m() As Byte, mo As Integer, ms As Integer) As Long
Dim ki As Integer ' Known string index
Dim mi As Integer ' Match string index
Dim kn As Integer ' Known next index
Dim mn As Integer ' Match next index
Dim kl As Integer ' Known next length
Dim ml As Integer ' Match next length
Dim cc As Integer ' current concurrent
character count
Dim ci As Integer ' concurrent character
index
' If no more substing to compare, return 0
If (ks <= ko Or ms <= mo) Then Exit Function ' if Known or Match
index is past end of string
If (ks = ko + 1 And ms = mo + 1) Then Exit Function ' if last
character of Known and Match strings
cc = 0: kl = ks: ml = ms: ' initialize concurrent
character count and string lengths
ki = ko ' initialize Known index
While (ki < kl) ' Known string loop
mi = mo ' initialize Match index
While (mi < ml) ' Match string loop
If (k(ki) = m(mi)) Then ' if a character the
same in both strings
ci = 1 ' initialize concurrent
character index
Do Until ((ki + ci >= kl) Or (mi + ci >= ml)) ' while things
match, keep trying...
If (k(ki + ci) <> m(mi + ci)) Then Exit Do ' if things NOT
matching, break loop
ci = ci + 1 ' bump concurrent
character count
Loop ' next character match
If ci > cc Then ' if concurrent count >
greatest count
cc = ci: kn = ki: mn = mi ' save indexes and
greatest count
kl = ks - cc: ml = ms - cc ' save indexes and
greatest count
End If ' if concurrent count >
greatest count
End If ' if a character the
same in both strings
mi = mi + 1 ' bump Match index
Wend ' next Match character
ki = ki + 1 ' bump Known index
Wend ' next Known character
If cc = 0 Then Exit Function ' return 0
cc = cc + GcSubStr(k(), kn + cc, ks, m(), mn + cc, ms) ' check right
hand side
cc = cc + GcSubStr(k(), ko, kn, m(), mo, mn) ' check left hand side
GcSubStr = cc ' return matched
character count of substrings
End Function