Option Compare Database Option Explicit '************************************************************************ 'http://www.aislebyaisle.com/access/tools.htm ' >> Access Database Design and Development Tools for Programmers << ' Automate tedious tasks in MS Access. Effortless results in record time! ' Advanced wizards for forms, reports, queries make you feel like a guru. ' Slick customizable menu as an alternative to the switchboard. ' VBA source code included, giving you more control. '************************************************************************ 'References (on the menu: Tools - References): ' Visual Basic for Applications ' Microsoft Access 9.0 Object Library ' Microsoft DAO 3.6 Object Library Function AddFieldToTable(ByVal TblName As String, FldName As String, FldType As Integer, Optional FldPos As Integer, Optional FldSize, Optional DefaultValue, Optional FldDes, Optional IsAutoNumber) As Boolean Dim Db As Database Dim DbPath As Variant Dim Td As TableDef Dim Fd As Field Dim p As Property On Error Resume Next 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If 'if IsAutoNumber, then use the correct field Type If Not IsMissing(IsAutoNumber) Then If IsAutoNumber Then FldType = dbLong End If End If 'add field and properties With Td 'create field If FldType = dbText And Not IsMissing(FldSize) Then Set Fd = .CreateField(FldName, FldType, FldSize) Else Set Fd = .CreateField(FldName, FldType) End If 'position (0 is first position) If Not IsMissing(FldPos) Then Fd.OrdinalPosition = FldPos 'if IsAutoNumber If Not IsMissing(IsAutoNumber) Then If IsAutoNumber Then Fd.Attributes = 17 End If End If 'add field to table .Fields.Append Fd If Err <> 0 Then 'failed to add field - probably already exists GoTo Done End If 'default If Not IsMissing(DefaultValue) Then .Fields(FldName).DefaultValue = DefaultValue End If 'add description property If Not IsMissing(FldDes) Then Set p = .Fields(FldName).CreateProperty("Description", dbText, FldDes) .Fields(FldName).Properties.Append p End If 'other properties according to personal preference If FldType = dbText Then .Fields(FldName).AllowZeroLength = True End If End With AddFieldToTable = True 'defaults to false if it fails to get here 'clean up Done: Set Fd = Nothing Set Td = Nothing If Not Db Is Nothing Then Db.Close Set Db = Nothing End Function Function DeleteFieldFromTable(ByVal TblName As String, FldName As String) As Boolean Dim Db As Database Dim DbPath As Variant Dim Td As TableDef On Error Resume Next 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If 'add field and properties With Td 'delete field .Fields.Delete FldName If Err <> 0 Then 'failed to delete field - probably doesn't exist GoTo Done End If End With DeleteFieldFromTable = True 'defaults to false if it fails to get here 'clean up Done: Set Td = Nothing If Not Db Is Nothing Then Db.Close Set Db = Nothing End Function Function GetBackEndPath(TblName As String) As String 'This returns the path, without the database name, of the back end. Dim x As Integer, y As Integer Dim DbPath As Variant DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Exit Function x = InStr(DbPath, ".mdb") While x > 0 x = x - 1 If Mid(DbPath, x, 1) = "\" Then y = InStr(DbPath, ":\") 'just after drive letter If y > 0 Then GetBackEndPath = Mid(DbPath, y - 1, x - y + 2) Else GetBackEndPath = Mid(DbPath, 1, x) End If Exit Function End If Wend End Function Function AddIndexToTable(ByVal TblName As String, IndexName As String, IsPrimary As Boolean, IsUnique As Boolean, ParamArray FldNames()) As Boolean Dim Idx As Index Dim Td As TableDef Dim DbPath As Variant Dim Db As Database Dim FldNum As Integer On Error Resume Next 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If With Td On Error Resume Next Set Idx = .Indexes(IndexName) 'test for existence If Err = 0 Then GoTo Done If Err > 0 Then 'create index On Error Resume Next Set Idx = .CreateIndex(IndexName) With Idx For FldNum = 0 To UBound(FldNames) .Fields.Append .CreateField(FldNames(FldNum)) .IgnoreNulls = True .Primary = IsPrimary .Unique = IsUnique Next End With .Indexes.Append Idx End If End With If Err = 0 Then AddIndexToTable = True Done: End Function Function DeleteIndexFromTable(ByVal TblName As String, IndexName As String) As Boolean Dim Idx As Index Dim Td As TableDef Dim DbPath As Variant Dim Db As Database On Error Resume Next 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If With Td On Error Resume Next .Indexes.Delete IndexName End With If Err = 0 Then DeleteIndexFromTable = True Done: End Function Function ChangeFieldName(TblName As String, OldFldName As String, NewFldName As String) Dim Td As TableDef Dim Db As Database Dim DbPath As Variant Dim FldPos As Integer Dim rs As Recordset Dim IdxName As String 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If 'change field name Td.Fields(OldFldName).Name = NewFldName ChangeFieldName = True 'defaults to false if it fails to get here Done: If Not Db Is Nothing Then Db.Close End Function Function ChangeFieldSize(TblName As String, FldName As String, NewSize As Byte) Dim Td As TableDef Dim Db As Database Dim DbPath As Variant Dim FldPos As Integer Dim rs As Recordset Dim IdxNames As Variant Dim IdxFldName As String Dim IdxNum As Integer Dim x As Integer 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If 'change field size If Td.Fields(FldName).Size <> NewSize Then With Td On Error Resume Next If NewSize > 0 And NewSize < 256 Then 'text field .Fields.Append .CreateField("TempFld", dbText, NewSize) Else '0 is memo field .Fields.Append .CreateField("TempFld", dbMemo) End If .Fields("TempFld").AllowZeroLength = True 'personal preference FldPos = .Fields(FldName).OrdinalPosition .Fields("TempFld").OrdinalPosition = FldPos Set rs = Db.OpenRecordset(TblName) While Not rs.EOF rs.Edit rs!TempFld = rs.Fields(FldName) rs.Update rs.MoveNext Wend rs.Close 'get indexes used by this field IdxNames = GetIndexes(Td, FldName) 'temporarily delete indexes used by this field For IdxNum = UBound(IdxNames, 2) To 0 Step -1 If IdxNames(0, IdxNum) > "" Then .Indexes.Delete IdxNames(0, IdxNum) Next 'delete old field .Fields.Delete FldName 'rename new field to original .Fields("TempFld").Name = FldName 'restore indexes For IdxNum = 0 To UBound(IdxNames, 2) If IdxNames(0, IdxNum) > "" Then Dim Idx As Index Set Idx = .CreateIndex(IdxNames(0, IdxNum)) 'parse comma-delimited field names and add them to index While Len(IdxNames(8, IdxNum)) > 1 x = InStr(IdxNames(8, IdxNum), ",") IdxFldName = left(IdxNames(8, IdxNum), x - 1) Idx.Fields.Append Td.CreateField(IdxFldName) IdxNames(8, IdxNum) = Mid(IdxNames(8, IdxNum), x + 1) Wend 'assign properties to index For x = 1 To 7 Idx.Properties(x) = IdxNames(x, IdxNum) Next 'add the index .Indexes.Append Idx End If Next End With If Err <> 0 Then GoTo Done End If ChangeFieldSize = True 'defaults to false if it fails to get here Done: If Not Db Is Nothing Then Db.Close End Function Function ChangeFieldType(ByVal TblName As String, FldName As String, NewType As Long, Optional DefaultValue, Optional FldSize) As Boolean Dim Td As TableDef Dim Db As Database Dim DbPath As Variant Dim FldPos As Integer Dim rs As Recordset Dim IdxNames As Variant Dim IdxFldName As String Dim IdxNum As Integer Dim x As Integer On Error Resume Next 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Set Db = CurrentDb 'if local table Else Set Db = OpenDatabase(DbPath) 'if linked table If Err <> 0 Then 'failed to open back end database Exit Function End If 'in case back end has different table name than front end TblName = DLookup("ForeignName", "MSysObjects", "Name='" & TblName & "' And Type=6") End If 'get table Set Td = Db.TableDefs(TblName) If Err <> 0 Then 'failed to get table GoTo Done End If 'change field type If Td.Fields(FldName).Type <> NewType Then With Td On Error Resume Next If NewType = dbText And Not IsMissing(FldSize) Then .Fields.Append .CreateField("TempFld", NewType, FldSize) Else .Fields.Append .CreateField("TempFld", NewType) End If If Err <> 0 Then GoTo Done If NewType = dbText Or NewType = dbMemo Then .Fields("TempFld").AllowZeroLength = True 'personal preference End If FldPos = .Fields(FldName).OrdinalPosition .Fields("TempFld").OrdinalPosition = FldPos If Not IsMissing(DefaultValue) Then .Fields("TempFld").DefaultValue = DefaultValue End If Set rs = Db.OpenRecordset(TblName) While Not rs.EOF rs.Edit If NewType = dbText Or NewType = dbMemo Then If Not IsNull(rs.Fields(FldName)) Then rs!TempFld = Eval(rs.Fields(FldName)) End If Else rs!TempFld = rs.Fields(FldName) End If rs.Update rs.MoveNext Wend rs.Close 'get indexes used by this field IdxNames = GetIndexes(Td, FldName) 'temporarily delete indexes used by this field For IdxNum = UBound(IdxNames, 2) To 0 Step -1 If IdxNames(0, IdxNum) > "" Then .Indexes.Delete IdxNames(0, IdxNum) Next 'delete old field .Fields.Delete FldName 'rename new field to original .Fields("TempFld").Name = FldName 'restore indexes For IdxNum = 0 To UBound(IdxNames, 2) If IdxNames(0, IdxNum) > "" Then Dim Idx As Index Set Idx = .CreateIndex(IdxNames(0, IdxNum)) 'parse comma-delimited field names and add them to index While Len(IdxNames(8, IdxNum)) > 1 x = InStr(IdxNames(8, IdxNum), ",") IdxFldName = left(IdxNames(8, IdxNum), x - 1) Idx.Fields.Append Td.CreateField(IdxFldName) IdxNames(8, IdxNum) = Mid(IdxNames(8, IdxNum), x + 1) Wend 'assign properties to index For x = 1 To 7 Idx.Properties(x) = IdxNames(x, IdxNum) Next 'add the index .Indexes.Append Idx End If Next End With If Err <> 0 Then GoTo Done End If ChangeFieldType = True 'defaults to false if it fails to get here Done: If Not Db Is Nothing Then Db.Close End Function Function PutTableOnBackEnd(DBName As String, TblName As String) As Boolean 'DBName should include full path and name of back end database Dim Db As Database 'test back end On Error Resume Next Set Db = OpenDatabase(DBName) If Err <> 0 Then 'failed to open back end database Exit Function End If If Not Db Is Nothing Then Db.Close 'test if table is local If IsNull(DLookup("Type", "MSysObjects", "Name='" & TblName & "' AND Type=1")) Then 'table is not local Exit Function End If 'put table on back end DoCmd.TransferDatabase acExport, "Microsoft Access", DBName, acTable, TblName, TblName If Err <> 0 Then GoTo Done 'link to the back end table DoCmd.DeleteObject acTable, TblName DoCmd.TransferDatabase acLink, "Microsoft Access", DBName, acTable, TblName, TblName PutTableOnBackEnd = True 'defaults to false if it fails to get here Done: End Function Function PutTableOnFrontEnd(ByVal TblName As String) As Boolean Dim DbPath As Variant 'get back end path of linked table DbPath = DLookup("Database", "MSysObjects", "Name='" & TblName & "' And Type=6") If IsNull(DbPath) Then Exit Function 'if local table End If 'delete linked table On Error Resume Next DoCmd.DeleteObject acTable, TblName 'import the table unlinked DoCmd.TransferDatabase acImport, "Microsoft Access", DbPath, acTable, TblName, TblName If Err <> 0 Then GoTo Done PutTableOnFrontEnd = True 'defaults to false if it fails to get here Done: End Function Function DeleteTableFromBackEnd(DbPath As String, TblName As String) 'This is dangerous - be careful! Make a backup of the back end database first. Dim Db As Database 'test back end On Error Resume Next Set Db = OpenDatabase(DbPath) If Err <> 0 Then 'failed to open back end database Exit Function End If Db.Execute "DROP TABLE " & TblName If Not Db Is Nothing Then Db.Close DeleteTableFromBackEnd = True 'defaults to false if it fails to get here Done: End Function Function GetUnLinked() As String 'Returns database path of first unlinked table it finds. 'This checks for valid path for back end, but it 'does not check that the table itself actually resides on back end. Dim rs As Recordset Dim Db As Database Set rs = CurrentDb.OpenRecordset("SELECT Database FROM MSysObjects " & _ "GROUP BY Database HAVING Database Is Not Null") While Not rs.EOF On Error Resume Next Set Db = OpenDatabase(rs!Database) If Err <> 0 Then 'return database path of unlinked table GetUnLinked = rs!Database GoTo Done End If Db.Close rs.MoveNext Wend Done: rs.Close End Function Function LinkTables(DbPath As String) As Boolean 'This links to all the tables that reside in DbPath, ' whether or not they already reside in this database. 'This works when linking to an Access .mdb file, not to ODBC. 'This keeps the same table name on the front end as on the back end. Dim rs As Recordset On Error Resume Next 'get tables in back end database Set rs = CurrentDb.OpenRecordset("SELECT Name " & _ "FROM MSysObjects IN '" & DbPath & "' " & _ "WHERE Type=1 AND Flags=0") If Err <> 0 Then Exit Function 'link the tables While Not rs.EOF If DbPath <> Nz(DLookup("Database", "MSysObjects", "Name='" & rs!Name & "' And Type=6")) Then 'delete old link, assuming front and back end table have the same name DoCmd.DeleteObject acTable, rs!Name 'make new link DoCmd.TransferDatabase acLink, "Microsoft Access", DbPath, acTable, rs!Name, rs!Name End If rs.MoveNext Wend rs.Close LinkTables = True End Function Function ReLinkTables(OldDbPath As String, NewDbPath As String) As Boolean 'This relinks only the tables that reside in this database ' that have a (broken) link to OldDbPath. 'This works when linking to an Access .mdb file, not to ODBC. 'This keeps the same table name on the front end, ' even if it's different than the back end table name. Dim rs As Recordset Dim Db As Database Dim TblName As String Dim ForeignTblName As String On Error Resume Next 'test for valid back end path Set Db = OpenDatabase(NewDbPath) If Err <> 0 Then Exit Function Db.Close 'get tables in this database with old link Set rs = CurrentDb.OpenRecordset("SELECT Name, ForeignName " & _ "FROM MSysObjects " & _ "WHERE Database='" & OldDbPath & "'") If Err <> 0 Then Exit Function 'relink the tables While Not rs.EOF TblName = rs!Name ForeignTblName = rs!ForeignName 'delete old link DoCmd.DeleteObject acTable, TblName 'make new link, retaining the front end name, even if the back end name is different DoCmd.TransferDatabase acLink, "Microsoft Access", NewDbPath, acTable, ForeignTblName, TblName rs.MoveNext Wend rs.Close ReLinkTables = True End Function Function GetIndexes(Td As TableDef, FldName As String) 'Returns array of indexes containing the specified field, ' the first index starting at Idx(1), so that ' Ubound(2, Idx) equals the number of indexes having the specified field Dim IdxNum As Integer, FldNum As Integer, PropNum As Integer Dim IdxNames() As String 'array to hold indexes ReDim IdxNames(8, 0) 'first dimension contains the index properties and field names 'second dimension represents index number Dim FldNames As String For IdxNum = 0 To Td.Indexes.Count - 1 FldNames = "" For FldNum = 0 To Td.Indexes(IdxNum).Fields.Count - 1 'concatonate field names FldNames = FldNames & Td.Indexes(IdxNum).Fields(FldNum).Name & "," 'if index contains the field we're looking for ... If FldName = Td.Indexes(IdxNum).Fields(FldNum).Name Then If IdxNum > 0 Then ReDim Preserve IdxNames(8, IdxNum) 'properties go into first 7 places of first dimension For PropNum = 0 To 7 IdxNames(PropNum, IdxNum) = Td.Indexes(IdxNum).Properties(PropNum) Next End If Next 'field names go into 8th place of first dimension If IdxNames(8, UBound(IdxNames, 2)) = "" Then IdxNames(8, UBound(IdxNames, 2)) = FldNames Next GetIndexes = IdxNames End Function Sub FindReferences() 'for development (place cursor here, and press F5 to run this) Dim x As Integer For x = 1 To References.Count Debug.Print References(x).FullPath Next End Sub Sub LoopFieldProperties() 'for development (place cursor here, and press F5 to run this) Dim TblName As String Dim FldName As String Dim x As Integer TblName = "Table1" 'put your table here FldName = "Field1" 'put your field here On Error Resume Next For x = 0 To CurrentDb.TableDefs(TblName).Fields(FldName).Properties.Count - 1 Debug.Print CurrentDb.TableDefs(TblName).Fields(FldName).Properties(x).Name & ": " & CurrentDb.TableDefs(TblName).Fields(FldName).Properties(x).Value Next End Sub Sub CallAddField() Dim Result As Boolean 'sample call: Result = AddFieldToTable("Table1", "NewFieldName", dbText, 2, 10, , "sample description") Debug.Print Result 'Possible values for FldType parameter: ' dbBigInt (Decimal) ' dbBinary ' dbBoolean (Yes/No) ' dbByte ' dbCurrency ' dbDate ' dbDouble ' dbGUID (Replication ID) ' dbInteger ' dbLong (Long Integer) ' dbLongBinary (OLE Object) ' dbMemo ' dbSingle ' dbText (specify size, or length of text) ' dbVarBinary (OLE Object) 'FldPos parameter is the ordinal position, 0 being position 1, ' but it works sporadically - I don't know why. 'For optional IsAutoNumber parameter, use True or False, or leave blank. End Sub Sub CallDeleteField() Dim Result As Boolean 'sample call: Result = DeleteFieldFromTable("Table1", "Field1") Debug.Print Result End Sub Sub CallAddIndex() Dim Result As Boolean 'sample call: Result = AddIndexToTable("Table1", "MyIndex", False, True, "Field1", "Field2") Debug.Print Result 'For the FldNames parameter, include one or more field names. 'Field2, Field3, etc. is optional End Sub Sub CallDeleteIndex() Dim Result As Boolean 'sample call: Result = DeleteIndexFromTable("Table1", "MyIndex") Debug.Print Result End Sub Sub CallChangeFieldName() Dim Result As Boolean 'sample call: Result = ChangeFieldName("Table1", "OldFieldName", "NewFieldName") Debug.Print Result End Sub Sub CallChangeFieldType() Dim Result As Boolean 'sample call: Result = ChangeFieldType("Table1", "Field1", dbText, , 10) Debug.Print Result 'Possible values for FldType parameter: ' dbBigInt (Decimal) ' dbBinary ' dbBoolean (Yes/No) ' dbByte ' dbCurrency ' dbDate ' dbDouble ' dbGUID (Replication ID) ' dbInteger ' dbLong (Long Integer) ' dbLongBinary (OLE Object) ' dbMemo ' dbSingle ' dbText (specify size, or length of text) ' dbVarBinary (OLE Object) End Sub Sub CallChangeFieldSize() Dim Result As Boolean 'sample call: Result = ChangeFieldSize("Table1", "Field1", 15) Debug.Print Result End Sub Sub CallPutTableOnBackEnd() Dim Result As Boolean 'sample call: Result = PutTableOnBackEnd("C:\Sample.mdb", "Table1") Debug.Print Result End Sub Sub CallPutTableOnFrontEnd() Dim Result As Boolean 'sample call: Result = PutTableOnFrontEnd("Table1") Debug.Print Result End Sub Sub CallDeleteTableFromBackEnd() 'This is dangerous - be careful! Make a backup of the back end database first. Dim Result As Boolean 'sample call: Result = DeleteTableFromBackEnd("C:\Sample.mdb", "Table1") Debug.Print Result End Sub Sub CallLinkTables() Dim Result As Boolean 'sample call: Result = LinkTables("C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb") Debug.Print Result End Sub Sub CallReLinkTables() Dim Result As Boolean Dim OldDbPath As String 'find broken links OldDbPath = GetUnLinked 'if we have broken links ... If OldDbPath > "" Then 'sample call: Result = ReLinkTables(OldDbPath, "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb") Debug.Print Result End If End Sub