Corrupted Database...

[KyleS]

OK, this is gonna sound weird but stick with me.

I created a utility to compact/repair a whole slew of DB's accross our network automatically (I'm not responsible for them and those who are don't compact regularly and the Network guy asked me to do this for him to help keep the space down) I've got it working great and all the error trapping is fine, but I need to make sure that if I run into a corrupt DB that I've got that error-trapping in there too. None of the DB's are corrupt (right now at least ;-) ) so I was hoping that someone who has run into this problem could send me a corrupted DB so I can build that error trapping into my utility. Or does anyone know what error message you get if you try to compact a corrupted DB from another DB? Or is there a way to corrupt a copy of one of mine?

Like I said, wierd, but I'm not gonna leave that stone unturned, especially since I kow what Access is capable of.

Any help/hints would be greatly appreciated.

Oh yeah, I'm using Access '97 so the DB would also need to be in Access '97

Thanks,

Kyle :

 

[demoman]

kyle - take a database, start a compaction and then 'pull the plug'. That should give just what you need.

 

[Ricky1946]

Hello AccessIsFun,
I have a corrupted database that you may be interested in.
How do I send it?
Regards
Ian "To say 'thankyou' encourages others."

 

[KyleS]

demoman: By 'pull the plug' you mean power off the PC right? I'll try that, thanks!

Ian: I would be greatful if you would send it to goatakis@aol.com (my home e-mail as the network people won't be too pleased with me recieving an attachment!)

Thank you both very much!

Kyle

 

[smedvid]

I also have a similar program that compacts mdb's over the network. I would love to compare notes to see where you are and where I am. Perhaps we can borrow ideas from each other. I've had some strange errors pop-up related to "File Not Found", that I plan to look at next week. In any event, here is a dump of my main procedure...

Watch for file names and directory names with a ' in the string. That cause me a headache my first week... Steve

Option Compare Database
Const APP_PATH = "C:\mdbcmpt\" 'Testing Directory for SJM. Also change basepath table!
'Const APP_PATH = "D:\mdbcmpt\" 'Change to reflect true location if this changes!
'Local Drive to execute Access compact upon.

Function Main_One()
'This procedure will snapshot a directory listing of database files (*.mdb) and
'loop through that list attempting to perform an Access compact on each file.
'The purpose of this compacting is to establish a schedule to compact those
'Access databases located on a network drive and realize diskspace savings.
'
'Modified by: SJM 01/11/2002
'Problem with ' appearing in the filepath where either directory or file has apostrophe.
'Program updated to look for a single apostrophe and handle it. If more than one apostrophe,
'then program will bomb. Will be handled later. Also added "/o-s" to DIR command to order
'by largest files first. Perhaps add file size to DIR_List and sort on size.
'
'Modified by: SJM 01/11/2002
'Added additional traps in Error section to account for possible network issues.

Dim thisdb As Database
Dim rsLog As DAO.Recordset
Dim rsBase As DAO.Recordset
Dim rsDirList As DAO.Recordset
Dim rsLastCompact As DAO.Recordset
Dim rsException As DAO.Recordset
Dim sFilePath As String
Dim oFSO As Scripting.FileSystemObject
Dim oFileOrig As Scripting.File
Dim oFileTemp As Scripting.File
Dim blnCompact As Boolean
Dim sTempName As String
Dim dOrigFileSize As Double
Dim dtOrigFileDate As Date
Dim sCommand As String
Dim wHandle As Long
Dim JobStart, StepStart
Dim ErrTrigger As Boolean
Dim lcError_Text As String
Dim lcAction_Text As String
Dim TempStatus As String 'Temporary Field used as place holder Status Bar Call.
Dim TempStr As String 'Temporary Field used as place holder for stuff.
Dim TempNum As Double 'Temporary Field used as place holder for stuff.
Dim lnCountOfDIRList As Integer 'Used for Status Bar display.
Dim lnCurrentNo As Integer 'Used for Status Bar display.

TempStr = ""
TempNum = 0
ErrTrigger = False
lnCountOfDIRList = 0
lnCurrentNo = 0

'Needed to Account for Wrong Access Version (95, 2000 or 2002) or Passworded Files and Skip File.
On Error GoTo Error_Trap

'Mark the begining of the overall job so that its
'overall running time can be logged or governed
JobStart = Timer

Set thisdb = CurrentDb
Set rsBase = thisdb.OpenRecordset("select * from basepathlist&quot

'Check if data returned from recordset. - Should be 1 record!
If Not rsBase.BOF And Not rsBase.EOF Then
'get a filesystem object so that you can get sizes and modification times
Set oFSO = CreateObject("Scripting.FileSystemObject&quot

'create a directory listing by writing a batch file and executing it
sCommand = "dir " & rsBase("basepath&quot & "*.mdb /s /b /o-s >" & APP_PATH & "dir_list_mdb.lst"
Open APP_PATH & "dir.bat" For Output As #1
Print #1, sCommand
Close #1

'appLoop Shell(APP_PATH & "dir.bat&quot
wHandle = Shell(APP_PATH & "dir.bat&quot

'delay to wait for the directory list
'file to finish writing from the bat command. This is necessary becuase
'the Shell command is asyncronous
DelayTime 5
appLoop wHandle

'clear the working table
thisdb.Execute "delete from dir_list"

'load the directory listing into the working table DIR_LIST
While Not rsBase.EOF
'open the directory list file and load it into a table
Open APP_PATH & "dir_list_mdb.lst" For Input As #1
Set rsDirList = thisdb.OpenRecordset("select * from dir_list order by 1, 2&quot
Do While Not EOF(1)
Input #1, sFilePath
'strip the base path to save the overall number of characters
If InStr(1, sFilePath, rsBase(&quot;basepath&quot) <> 0 Then
sFilePath = Mid(sFilePath, Len(rsBase(&quot;basepath&quot) + 1)
End If
lnCountOfDIRList = lnCountOfDIRList + 1
'add it to the table
With rsDirList
.AddNew
.Fields(&quot;basepath&quot = rsBase(&quot;basepath&quot
.Fields(&quot;filepath&quot = sFilePath
.Update
End With
Loop 'end doloop not EOF(1)
Close #1

'get back to the begining of the list that you just loaded
rsDirList.MoveFirst
Do While Not rsDirList.EOF
lnCurrentNo = lnCurrentNo + 1
'Update DIR_List to flag file as being processed. See how many from big directory list are flagged.
rsDirList.Edit
rsDirList(&quot;processflag&quot = &quot;Y&quot;
rsDirList.Update
TempNum = 0
TempNum = InStr(rsDirList(&quot;filepath&quot, &quot;'&quot
TempStatus = SysCmd(acSysCmdSetStatus, rsDirList(&quot;filepath&quot & &quot;File: &quot; & lnCurrentNo & &quot; of &quot; & lnCountOfDIRList)

'test to see if the file is on the exception list
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
Set rsException = thisdb.OpenRecordset(&quot;select 1 from Exception_list where basepath = '&quot; & rsBase(&quot;basepath&quot _
& &quot;' and filepath = '&quot; & rsDirList(&quot;filepath&quot & &quot;' &quot
Else
'Single apostrophe in filepath field. More than one not handled at present.
Set rsException = thisdb.OpenRecordset(&quot;select 1 from Exception_list where basepath = '&quot; & rsBase(&quot;basepath&quot _
& &quot;' and filepath = '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;' &quot
End If

'if the recordset has anything in it then it is on the exception list: skip to the bottom of the loop
If Not rsException.BOF And Not rsException.EOF Then
lcError_Text = &quot;File appears to be excluded from list. This file will NOT be compacted!&quot;
DoCmd.Beep
'update the log - may need short file name and short path here...
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
'update the dirlist record as an additional log
lcAction_Text = lcError_Text
rsDirList.Edit
rsDirList(&quot;action&quot = lcAction_Text
rsDirList(&quot;actiondate&quot = Now()
rsDirList.Update
'then go to the bottom of the loop
GoTo NEXTDIRLIST
End If

'**************** NEW CODE
'test to see if it is in use - see if a Lock (.ldb) file exists.
'Check date-stamp on ldb file to determine if greater than 21 days. If it is, Kill the ldb file.

If oFSO.FileExists(rsDirList(&quot;basepath&quot & Left(rsDirList(&quot;filepath&quot, Len(rsDirList(&quot;filepath&quot) - 3) & &quot;ldb&quot Then
'Check Date-Stamp.
Set oFileOrig = oFSO.GetFile(rsDirList(&quot;basepath&quot & Left(rsDirList(&quot;filepath&quot, Len(rsDirList(&quot;filepath&quot) - 3) & &quot;ldb&quot
If DateDiff(&quot;d&quot;, oFileOrig.DateLastModified, Now()) > rsBase(&quot;modify_generation&quot Then
'Delete ldb File and Continue with Compact!
Kill rsDirList(&quot;basepath&quot & oFileOrig.Name 'Delete the ldb file on basepath location.
If ErrTrigger = True Then
'Problem - Copying the File - Possible Permission/Rights Issue!
ErrTrigger = False
GoTo NEXTDIRLIST
End If
blnCompact = True
Else
blnCompact = False
lcError_Text = &quot;File appears to be open since ldb file exists. Verify ldb file is valid. Compacting requires exclusive use.&quot;
End If
If blnCompact = False Then
'update the log - ldb file found and appears to be pretty new!
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
'also update the dir list as an additional log
lcAction_Text = lcError_Text
rsDirList.Edit
rsDirList(&quot;action&quot = lcAction_Text
rsDirList(&quot;actiondate&quot = Now()
rsDirList.Update
'go to the bottom of the loop
GoTo NEXTDIRLIST
End If
End If


'test for when the file was last compacted and modified
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
Set rsLastCompact = thisdb.OpenRecordset(&quot;select iif(max(compact_datetime)is null, #01/01/1900#, max(compact_datetime)) &quot; _
& &quot;as maxcompact from actionlog &quot; _
& &quot;where basepath = '&quot; & rsBase(&quot;basepath&quot & &quot;' and filepath = '&quot; & rsDirList(&quot;filepath&quot & &quot;' &quot
Else
Set rsLastCompact = thisdb.OpenRecordset(&quot;select iif(max(compact_datetime)is null, #01/01/1900#, max(compact_datetime)) &quot; _
& &quot;as maxcompact from actionlog &quot; _
& &quot;where basepath = '&quot; & rsBase(&quot;basepath&quot _
& &quot;' and filepath = '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;' &quot
End If

If Not rsLastCompact.BOF And Not rsLastCompact.EOF Then
'if it is in the compacting window then has it been modified
If DateDiff(&quot;d&quot;, rsLastCompact(&quot;maxcompact&quot, Now()) > rsBase(&quot;compact_generation&quot Then
Set oFileOrig = oFSO.GetFile(rsDirList(&quot;basepath&quot & rsDirList(&quot;filepath&quot)
If DateDiff(&quot;d&quot;, oFileOrig.DateLastModified, Now()) > rsBase(&quot;modify_generation&quot Then
lcAction_Text = &quot;File will be compacted.&quot;
blnCompact = True
Else
lcAction_Text = &quot;File has not been modified recently. File Date: &quot; & oFileOrig.DateLastModified & &quot; > &quot; & rsBase(&quot;modify_generation&quot
blnCompact = False
End If
Else
lcAction_Text = &quot;File has already been compacted recently. File Date:&quot; & rsLastCompact(&quot;maxcompact&quot & &quot; > &quot; & rsBase(&quot;compact_generation&quot
blnCompact = False
End If
Else
lcAction_Text = &quot;New file. It will be compacted.&quot;
blnCompact = True
End If

rsDirList.Edit
rsDirList(&quot;action&quot = lcAction_Text
rsDirList(&quot;actiondate&quot = Now()
rsDirList.Update

If blnCompact = True Then
StepStart = Timer
'create a temp file name
sTempName = Format(Now(), &quot;mmddyyyyhhnnss&quot & &quot;.mdb&quot;
'copy the file to the local drive for compacting
oFileOrig.Copy APP_PATH & oFileOrig.Name

'Problem with Copy of file to local drive.
If ErrTrigger = True Then
'Problem - Copying the File - Possible Permission/Rights Issue!
ErrTrigger = False
GoTo NEXTDIRLIST
End If

'compact the database
If oFSO.FileExists(APP_PATH & oFileOrig.Name) Then
'Make sure file was properly copied to local drive before Compact attempt.
DBEngine.CompactDatabase APP_PATH & oFileOrig.Name, APP_PATH & sTempName
End If

If ErrTrigger = True Then
'Problem - Wrong Version or Other Incompatible File Format or Password - Unable to Compact!
If oFSO.FileExists(APP_PATH & oFileOrig.Name) Then
'Need to Account for situation when file is restricted access on network and
'can not copy local.
Kill APP_PATH & oFileOrig.Name 'copy in the local directory
End If
ErrTrigger = False
GoTo NEXTDIRLIST
End If

'*****deal with contingency on not geting an exclusive lock on the db
'get a handle on the compacted file
Set oFileTemp = oFSO.GetFile(APP_PATH & sTempName)
dOrigFileSize = oFileOrig.Size
dtOrigFileDate = oFileOrig.DateLastModified
'delete the originals
Kill APP_PATH & oFileOrig.Name 'copy in the local directory
If ErrTrigger = True Then
'Problem - Copying the File - Possible Permission/Rights Issue!
ErrTrigger = False
GoTo NEXTDIRLIST
End If
'oFileOrig.Delete 'orig in the orig location - Not Needed?????
'copy the compacted file into the place of the old
oFileTemp.Copy rsDirList(&quot;basepath&quot & rsDirList(&quot;filepath&quot
If ErrTrigger = True Then
'Problem - Copying the File - Possible Permission/Rights Issue!
ErrTrigger = False
GoTo NEXTDIRLIST
End If

'update the log
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (basepath,filepath,file_size,file_date_time,Compact_datetime,compact_size,elaps_minutes) Values(&quot; _
& &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& rsDirList(&quot;filepath&quot & &quot;', &quot; _
& dOrigFileSize & &quot;, #&quot; & dtOrigFileDate & &quot;#, #&quot; _
& oFileTemp.DateLastModified & &quot;#, &quot; & oFileTemp.Size & &quot;, &quot; _
& (Timer - StepStart) / 60 & &quot &quot

Else
thisdb.Execute (&quot;Insert into ActionLog (basepath,filepath,file_size,file_date_time,Compact_datetime,compact_size,elaps_minutes) Values(&quot; _
& &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', &quot; _
& dOrigFileSize & &quot;, #&quot; & dtOrigFileDate & &quot;#, #&quot; _
& oFileTemp.DateLastModified & &quot;#, &quot; & oFileTemp.Size & &quot;, &quot; _
& (Timer - StepStart) / 60 & &quot &quot
End If

'update the dir list as an additional log
rsDirList.Edit
rsDirList(&quot;action&quot = lcAction_Text
rsDirList(&quot;actiondate&quot = Now()
rsDirList.Update

'clear the temp file
oFileTemp.Delete
Else 'do not compact
rsDirList.Edit
rsDirList(&quot;action&quot = lcAction_Text
rsDirList(&quot;actiondate&quot = Now()
rsDirList.Update
End If 'end if blnCompact

NEXTDIRLIST:
'only let the overall job run for eight hours (28800 seconds)
If ((Timer - JobStart) / 60) > 28800 Then Exit Function
'clean up
Set oFileOrig = Nothing
Set oFileTemp = Nothing
'go to the next item in the directory listing
rsDirList.MoveNext
Loop 'end while not rsdirlist.eof
rsBase.MoveNext

Wend 'end while not rsBase.eof
End If 'end if not rsBase.BOF/EOF
SysCmd (acSysCmdClearStatus) 'Clears Status Bar
Exit Function 'Needed to bypass Error_trap when done.

Error_Trap:
Select Case Err.Number ' Evaluate Error Number.
Case 3343 ' Unrecognized database format <filename>.
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - Unrecognized database format <filename>. Possible Access 2000/2002 File Format.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case 3031 'Not a valid password.
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - Not a valid password. Possible Access 2000/2002 File Format.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case 70 'Permission Denied.
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - Permission Denied. Possible File Rights Issue or Read-Only.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case 75 'Path/File Access Error
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - Path/File Access Error. Possible Folder Rights Issue or Read-Only.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case 53 'File Not Found
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - File Not Found Error. Possible Network Issue.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case 3112 'No Read Permission
ErrTrigger = True
lcError_Text = Err.Number & &quot; Compact Failed - Record(s) can not be read; no read permission on <name>. (Error 3112). Check Tools / Security / User Group Permission Objects.&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next

Case Else 'Other values.
ErrTrigger = True
lcError_Text = Err.Number & &quot; Error Not in Case Statement. Check!&quot;
If TempNum = 0 Then 'No Quote Found in FilePath Field of DIR_LIST
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; & rsDirList(&quot;filepath&quot & &quot;', '&quot; & lcError_Text & &quot;')&quot
Else
thisdb.Execute (&quot;Insert into ActionLog (Basepath,FilePath,Comments) &quot; _
& &quot;Values( &quot; & &quot;'&quot; & rsDirList(&quot;basepath&quot & &quot;', '&quot; _
& Mid(rsDirList(&quot;filepath&quot, 1, TempNum - 1) & &quot;''&quot; & Mid(rsDirList(&quot;filepath&quot, TempNum + 1) _
& &quot;', '&quot; & lcError_Text & &quot;')&quot
End If
Resume Next
End Select
'Note: Could not use Err.Description. In some cases, it appears to exceed 255 characters and is most likely a memo field.
'Perhaps in future change Comments field in database table to memo field.
End Function

Public Function DelayTime(PauseTime As Integer)
Dim start
'PauseTime = 4 ' Set duration.
start = Timer ' Set start time.
Do While Timer < start + PauseTime
DoEvents ' Yield to other processes.
Loop

End Function

Sub appLoop(wHandle As Long)
On Error GoTo errorhandler
Do While 1
AppActivate wHandle, False
Loop

errorhandler:
Exit Sub

End Sub

Function RplStr(string1 As String, search As String, replace As String) As String
'This function is designed to change any single variable occurrance to another variable
'based on parameters passed in. For the current problem, a quote appears to be the problem.
If search <> replace Then
'*loop until there are no more search items found
While InStr(1, string1, search) <> 0
'*strip the search item working from left to right
'*by finding the item and concatenating the left
'*and right portions except the search value
string1 = Left(string1, InStr(1, string1, search) - 1) & replace _
& Right(string1, Len(string1) - ((InStr(1, string1, search) - 1) + Len(search)))
Wend
'*return the stripped value
RplStr = string1
End If
End Function

Sub stub1()
'Test for RplStr Function
Dim mystring As String
mystring = &quot;doug's and amy's house&quot;
MsgBox RplStr(mystring, &quot;'&quot;, &quot;&quot
End Sub
Steve Medvid
&quot;IT Consultant & Web Master&quot;

http://users.erols.com/medvid/

 

[KyleS]

Steve, thanks for the hint about the &quot; ' &quot;'s I'll have to put something in there for that.

I kind of went a different route with mine in that I make our NT guy enter the DB path and if necessary the password. I'm using API calls to get him a dialog box to select the files with, but it also gives him the ability to compact the password protected DB's as well (which 99% of them are). Anyway, here's my main code:


Private Sub cmdCompact_Click()
On Error GoTo Err_Handler
Dim rst As Recordset, dbs As Database
Dim i As Integer, strTemp As String, strTempComp As String, strPWord As String
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(&quot;tblDBnames&quot

'If there are no files, tell the operator
If rst.RecordCount = 0 Then
MsgBox &quot;There are no Databases listed to Compact!&quot;, vbCritical + vbOKOnly, &quot;DB List Empty&quot;
Else
Dim rstRes As Recordset
Set rstRes = dbs.OpenRecordset(&quot;tblResults&quot
'loop through the table and compact/repair each database as needed
Do While Not rst.EOF
'Get Full DB Name
strTemp = rst.Fields(1)

'Check if a password is required
If rst.Fields(2) = True Then
'Get Password if one exists
strPWord = rst.Fields(3)
'Create name for Compacted DB
strTempComp = Left(strTemp, Len(strTemp) - 4) & &quot;ABC&quot; & Right(strTemp, 4)
'Repair DB
DBEngine.RepairDatabase strTemp
'Compact the DB into a new file
DBEngine.CompactDatabase strTemp, strTempComp, , , &quot;;PWD=&quot; & strPWord
Else
'Create name for Compacted DB
strTempComp = Left(strTemp, Len(strTemp) - 4) & &quot;ABC&quot; & Right(strTemp, 4)
'Repair DB
DBEngine.RepairDatabase strTemp
'Compact the DB into a new file
DBEngine.CompactDatabase strTemp, strTempComp
End If

'Delete original DB
Kill strTemp
'Rename compacted version to Original DB name
Name strTempComp As strTemp
'Enter Results in Results field
rstRes.AddNew
rstRes.Fields(0) = strTemp
rstRes.Fields(3) = Now
rstRes.Update
SkipDB:
'Next DB
rst.MoveNext
Loop
rstRes.Close
Set rstRes = Nothing
End If

Exit_Compact:
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
Exit Sub

Err_Handler:
Dim rstErr As Recordset
Set rstErr = dbs.OpenRecordset(&quot;tblCompactErrors&quot
rstErr.AddNew
rstErr.Fields(0) = strTemp 'Which DB had the Problem?
rstErr.Fields(1) = Err.Description 'Description
rstErr.Fields(2) = Err.Number 'Err Number just in case
rstErr.Fields(3) = Now() 'When the error occured
rstErr.Update
rstErr.Close
Set rstErr = Nothing
Resume SkipDB

End Sub

I would be more than happy to share any info. I'll admit I only skimmed through your code (I am at work) but I was wondering, did you make a local copy of each DB before compacting and deleteing the original? Or are you compacting it (which will make a copy) and then deleting and replacing right away? I only ask because my only hesitation here is that I don't 100% trust anything Microsoft makes, so it is possible (although I can't think of a scenario right now) that the DB doesn't compact but my code still moves on to delete the original even though I'm telling it to skip over the DB as soon as an error occurs.

Any thoughts?

Kyle :