Public Sub IdentifyLikeFields()
Dim db As DAO.Database
Dim tblOne As DAO.TableDef
Dim tblTwo As DAO.TableDef
Dim fldOne As DAO.Field
Dim fldTwo As DAO.Field
Dim strSql As String
Dim strLikeNameType As String
Set db = CurrentDb
For Each tblOne In db.TableDefs
'At this point the code to handle a single PK
If numberPrimaryKeys(tblOne.Name) = 1 And Left(tblOne.Name, 4) <> "MSYS" Then
Set fldOne = getPK(tblOne)
For Each tblTwo In db.TableDefs
If Not tblOne.Name = tblTwo.Name And Left(tblTwo.Name, 4) <> "MSYS" And tblOne.Name <> "tblLikeFields" Then
For Each fldTwo In tblTwo.Fields
strLikeNameType = LikeNameType(fldOne.Name, fldTwo.Name)
If strLikeNameType <> "NoMatch" And tblTwo.Name <> "tblLikeFields" Then
Debug.Print tblOne.Name & "." & fldOne.Name & " " & tblTwo.Name & "." & fldTwo.Name
Debug.Print strLikeNameType
strSql = "Insert INTO tblLikeFields (tblOne,tblTwo,fldOne,fldTwo,matchType) Values ('"
strSql = strSql & tblOne.Name & "', '" & tblTwo.Name & "', '" & fldOne.Name & "', '" & fldTwo.Name & "', '" & strLikeNameType & "')"
'Debug.Print strSql
CurrentDb.Execute strSql
End If
Next fldTwo
End If
Next tblTwo
Else
'future code to handle composite keys
End If
Next tblOne
End Sub
Public Function isPK(tblDef As DAO.TableDef, strField As String) As Boolean
Dim idx As DAO.Index
Dim fld As DAO.Field
For Each idx In tblDef.Indexes
If idx.Primary Then
For Each fld In idx.Fields
If strField = fld.Name Then
isPK = True
Exit Function
End If
Next fld
End If
Next idx
End Function
Public Function numberPrimaryKeys(tblName As String) As Integer
Dim db As DAO.Database
Dim fld As DAO.Field
Dim tblDef As DAO.TableDef
Set db = CurrentDb
Set tblDef = db.TableDefs(tblName)
For Each fld In tblDef.Fields
If isPK(tblDef, fld.Name) Then numberPrimaryKeys = numberPrimaryKeys + 1
Next fld
End Function
Public Function LikeNameType(nameOne As String, nameTwo As String) As String
LikeNameType = "NoMatch"
If nameOne = nameTwo Then
LikeNameType = "ExactMatch"
ElseIf nameOne Like "*" & nameTwo & "*" Then
LikeNameType = "FieldOne Like *FieldTwo*"
ElseIf nameTwo Like "*" & nameOne & "*" Then
LikeNameType = "FieldTwo like *FieldOne*"
ElseIf Nz(InStr(nameOne, nameTwo), 0) > 0 Then
LikeNameType = "FieldTwo in FieldOne"
ElseIf Nz(InStr(nameTwo, nameOne), 0) > 0 Then
LikeNameType = "FieldOne in FieldTwo"
ElseIf Soundex2(nameOne) = Soundex2(nameTwo) Then
LikeNameType = "FieldOne sounds like FieldTwo"
End If
End Function
Public Function getPK(tblDef As DAO.TableDef) As DAO.Field
Dim fld As DAO.Field
For Each fld In tblDef.Fields
If isPK(tblDef, fld.Name) Then Set getPK = fld
Next fld
End Function
' Computes the "Soundex" value of a string.
' This version produces exactly the same results as the Soundex
' function of Microsoft SQL Server 2000.
' Author: Christian d'Heureuse, chdh@source-code.biz
Public Function Soundex2(ByVal s As String) As String
Const CodeTab = " 123 12 22455 12623 1 2 2"
' abcdefghijklnmopqrstuvwxyz
If Len(s) = 0 Then Soundex2 = "0000": Exit Function
Dim c As Integer
c = Asc(Mid$(s, 1, 1))
If c >= 65 And c <= 90 Or c >= 97 And c <= 122 Then
' nop
ElseIf c >= 192 And c <= 214 Or c >= 216 And c <= 246 Or c >= 248 Then
' nop
Else
Soundex2 = "0000"
Exit Function
End If
Dim ss As String, PrevCode As String
ss = UCase(Chr(c))
PrevCode = "?"
Dim p As Integer: p = 2
Do While Len(ss) < 4 And p <= Len(s)
c = Asc(Mid(s, p))
If c >= 65 And c <= 90 Then
' nop
ElseIf c >= 97 And c <= 122 Then
c = c - 32
ElseIf c >= 192 And c <= 214 Or c >= 216 And c <= 246 Or c >= 248 Then
c = 0
Else
Exit Do
End If
Dim Code As String: Code = "?"
If c <> 0 Then
Code = Mid$(CodeTab, c - 64, 1)
If Code <> " " And Code <> PrevCode Then ss = ss & Code
End If
PrevCode = Code
p = p + 1
Loop
If Len(ss) < 4 Then ss = ss & String$(4 - Len(ss), "0")
Soundex2 = ss
End Function
I can confidently say I wouldn't have managed that myself, but have learnt a lot about the Access system tables in the process.
