1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
|
Function CheckTable() 'This function checks a table attachment
Dim db As Database
Dim CurrDBTbls As DAO.Snapshot
Dim ds As Dynaset
On Error GoTo CheckTabletrap
Set db = CurrentDb()
Set CurrDBTbls = db.ListTables() 'Gets a list of tables in the current DB
CurrDBTbls.MoveFirst 'Moves to the first table in the list
Do Until CurrDBTbls.EOF 'This loop is used to find an attached table
If CurrDBTbls![tabletype] = DB_ATTACHEDTABLE Then 'Checks to see if it's an attached table
Set ds = db.CreateDynaset(CurrDBTbls![Name]) 'Tests the attached table. If it fails, it goes to the error trap. Otherwise, it just continues through the function.
Exit Do
End If
CurrDBTbls.MoveNext 'Moves to the next table in the list
Loop
ds.Close 'Closes the VT object
CurrDBTbls.Close 'Closes the VT object
db.Close 'Closes the VT object
Exit Function
CheckTabletrap:
DeleteAttach 'Opens the sub procedure that deletes the current attachments
Exit Function
End Function
Sub DeleteAttach() 'This function deletes any attached tables
Dim db As Database, CurrDBTbls As Snapshot
On Error Resume Next
Set db = CurrentDb()
Set CurrDBTbls = db.ListTables() 'Gets a list of tables in the current DB
CurrDBTbls.MoveLast
s = SysCmd(1, "Deleting tables...", CurrDBTbls.RecordCount)
Count = 0
CurrDBTbls.MoveFirst 'Moves to the first table in the list
DoCmd.SetWarnings False 'Turns the warnings messages off for deleting tables
Do Until CurrDBTbls.EOF 'This loop is used to find attached tables
If CurrDBTbls![tabletype] = DB_ATTACHEDTABLE Then 'Only finds attached tables
DoCmd.SelectObject A_TABLE, CurrDBTbls![Name], True 'Selects the attached table
DoCmd.DoMenuItem 1, 1, 4 'Deletes the attached table
s = SysCmd(2, Count)
End If
Count = Count + 1
CurrDBTbls.MoveNext 'Moves to the next table in the list
Loop
DoCmd.SetWarnings True 'Turns the warnings back on
s = SysCmd(5)
DoCmd.OpenForm "frm reattach" 'Opens a form to ask the user for the new location of the tables database
CurrDBTbls.Close 'Closes VT object
db.Close 'Closes VT object
End Sub
Function FRMCancel() 'This functions closes the database
DoCmd.Close 'Closes the form
SendKeys "{f11}", True 'Selects the DB container window
DoCmd.DoMenuItem 1, 0, 2 'Closes the DB
End Function
Function FRMok(f As Form)
Dim db As Database
Dim OtherDBTbls As Snapshot
Dim OtherDBPath As String
Dim GotOne
On Error GoTo FRMokTrap
OtherDBPath = f("dbpath")
Set db = OpenDatabase(OtherDBPath)
DoCmd.Close
Set OtherDBTbls = db.ListTables()
OtherDBTbls.MoveLast
s = SysCmd(1, "Adding tables...", OtherDBTbls.RecordCount)
Count = 0
OtherDBTbls.MoveFirst
DoCmd.SetWarnings False
Do Until OtherDBTbls.EOF
If Not Left(OtherDBTbls![Name], 4) = "msys" And OtherDBTbls![tabletype] = DB_TABLE Then
DoCmd.TransferDatabase A_ATTACH, "Microsoft Access", OtherDBPath, , OtherDBTbls![Name], OtherDBTbls![Name]
s = SysCmd(2, Count)
GotOne = True
End If
Count = Count + 1
OtherDBTbls.MoveNext
Loop
DoCmd.SetWarnings True
OtherDBTbls.Close
db.Close
s = SysCmd(5)
If GotOne = True Then
x = MsgBox("The tables were added successfully", 0, "")
Else
x = MsgBox("The database doesn't contain any tables.", 0, "")
DoCmd.OpenForm "frm reattach"
End If
Exit Function
FRMokTrap:
If Err = 94 Then
x = MsgBox("You must enter the path to a database.", 0, "")
DoCmd.GoToControl "dbpath"
Exit Function
End If
If Err = 3044 Or Err = 3024 Then
x = MsgBox("The path or filename specified is invalid.", 0, "")
DoCmd.GoToControl "dbpath"
Exit Function
End If
If Err = 3051 Then
x = MsgBox("The file couldn't be opened." & Chr(13) & Chr(13) & Chr(10) & "It may be in/on a read-only directory/drive" & Chr(13) & Chr(10) & "or locked by another user.", 0, "")
DoCmd.GoToControl "dbpath"
Exit Function
End If
If Err = 3049 Then
x = MsgBox("The file is corrupted or isn't a Microsoft Access database.", 0, "")
DoCmd.GoToControl "dbpath"
Exit Function
End If
x = MsgBox("ERROR: " & Error(Err), 0, "")
DoCmd.SetWarnings True
Exit Function
End Function
Open in New Window
|
