compact repair method

' ------- < VB Script > -------------------------------------------------------------------------------------------------------
 
' ** Start of Script **
 
Option Explicit
 
Dim objEngine
Dim objProcess
Dim objDB
Dim strDb1
 
Dim strAccessSoftware
Dim strAccessRunTime
Dim strPath
Dim strFile
Dim strCompactedDate
Dim strDAOversion
Dim strApplicationName
Dim strReOpenAfterCompact
 
Dim strReOpenString
Dim strQuotes
 
Dim strMsg
Dim FSO
 
' **** Start of DYNAMIC change ****
 
' The following variables are DYNAMICALLY changed by the Access function which calls this script
 
strAccessSoftware = "C:\Program Files\Microsoft Office 2000\Office\MSACCESS.EXE"
strAccessRuntime = ""
strPath = "C:\Documents and Settings\Rob Richards\My Documents\My Files\_Burn to CD\MS Access\CJSFC\"
strFile = "CJSFC_fe_2000.mdb"
strCompactedDate = "Last Compacted - 12/09/2004 11:34:21 AM"
strDAOversion = "DAO.DBEngine.36"
strApplicationName = "CJSFC Players Registration System"
strReOpenAfterCompact = "NO"
 
' **** End of DYNAMIC change ****
 
 
 
strDb1 = strPath & strFile
 
Set FSO = CreateObject("Scripting.FileSystemObject")
 
Do While FSO.FileExists(Left(strDb1, Len(strDb1) - 3) & "ldb") = True
' As long as an ldb file exists, someone is in the database, so just do nothing until it goes.
Loop
 
strMsg = "About to perform a COMPACT on the"
strMsg = strMsg & chr(10) & chr(10)
strmsg = strMsg & strApplicationName
strMsg = strMsg & chr(10) & chr(10)
strmsg = strmsg & "FRONT_END database."
strMsg = strmsg & chr(10) & chr(10)
strmsg = strmsg & space(12) & "It is VITAL you do not exit windows until"
strMsg = strMsg & chr(10)
strMsg = strMsg & space(12) & "you receive the confirmation message."
strMsg = strmsg & chr(10) & chr(10)
strMsg = strMsg & space(6) & "Press OK to continue or Cancel to stop the process."
 
 
if MsgBox(strMsg, 1, strApplicationName) = 1 Then
 
' HourGlass TRUE
 
Set objEngine = WScript.CreateObject(strDAOversion)
 
Call CompactDB(FSO, objEngine, strDb1, "")
 
strMsg = "Database compacting complete"
MsgBox strMsg, 1, strApplicationName
End If
 
' Does the newly compacted database have to NOW be re-opened
 
If strReOpenAfterCompact = "YES" then
strQuotes = """"
strReOpenString = strQuotes & strAccessSoftware & strQuotes & space(1)
If strAccessRuntime <> "" then
strReOpenString = strReOpenString & strAccessRuntime & space(1)
End If
 
strReOpenString = strReOpenString & strQuotes & strDb1 & strQuotes
 
' HourGlass FALSE
 
' MsgBox strReOpenString
 
' At this point "strReOpenString" contains :
'
' "C:\Program Files\Microsoft Office 2000\Office\MSACCESS.EXE" "C:\MS Access\CJSFC\CJSFC_fe_2000.mdb"
 
' Set objprocess = CreateObject("Shell.Application")
' objProcess.Create strReOpenString
' objprocess.Open strReOpenString
'
' Timk's suggestion
 
Set objprocess = CreateObject("Access.Application")
objprocess.OpenCurrentDataBase(strDb1)
objprocess.Visible = TRUE
 
End If
 
' HourGlass FALSE
 
'
'
 
Function CompactDB(objFSO, objEngine, strDb, pwd)
 
'Compact the database
 
Dim strdbtemp
Dim MsgText
 
strdbtemp = Left(strDb, Len(strDb) - 3) & "ldb"
 
If FSO.FileExists(strdbtemp) = True Then 'if ldb file exists, db is still open.
MsgText = "You have not exited the file. Please close and try again."
MsgBox MsgText, 1, strApplicationName
Exit Function
End If
 
If FSO.FileExists(strDb1) = False Then
MsgText = "Cannot locate the database at " & strDB
MsgBox MsgText, 1, strApplicationName
Exit Function
End If
 
strdbtemp = Left(strDb, Len(strDb) - 3) & "tmp"
 
If pwd = "" Then
objEngine.CompactDatabase strDb, strdbtemp
Else
objEngine.CompactDatabase strDb, strdbtemp, , , ";pwd=" & pwd
End If
 
If Err = 0 Then
FSO.deletefile strDb
FSO.copyfile strdbtemp,strDb
FSO.deletefile strdbtemp
Else
MsgText = "Error during COMPACT process for " & strDB
MsgBox MsgText, 1, strApplicationName
End If
 
End Function
 
' ** End of SCRIPT **

                                              

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:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153: