How to VBA DBEngine.CompactDatabase multiple 2007 back-end files?

Question

I have a table that contains a record for each back-end file (file name,source folder, destination folder...)

I created a form linked to that table in order to copy each back-end file to destination folder and then do the Compact, but it doesn't work when i use: for example

Do While Not myRSet.EOF

CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewTempFile & """"
Shell CopyMyDB, 0
Do Until CheckMyFile(NewTempFile) = 1

Loop

MyPass = ";" & "PWD" & "=" & [PW]
On Error GoTo Err_Compact

If IsNull([PW]) Then DBEngine.CompactDatabase NewTempFile, NewCompFile
If Not IsNull([PW]) Then DBEngine.CompactDatabase NewTempFile, NewCompFile, , , MyPass

Kill (NewTempFile)

myRSet.MoveNext

Loop

It only works fine when i remove the myRSet oop, which means that i have to click the button and wait until its done for each record.

It seams like, when using Do While Not myRSet.EOF, the code doesn't wait until DBEngine.CompactDatabase is finished.

for example i used the function CheckMyFile to check if the file is copied to destination folder

Is there a way to check if the DBEngine.CompactDatabase is finished?

Answer 1

Why are you Shell-ing out to a command window to copy a file, in light of VBA's FileCopy function?

Once you use it, you can also remove your attempt at detecting if the file has been copied.

Once you read the help page about CompactDatabase more carefully, you realize filecopy is not even needed since you can compact to the destination folder.

---

-Tom. Microsoft Access MVP

Answer 2

Hmm, I haven't tried using this function on multiple BE files, but I wonder if it will have the same problem. Be careful you are not performing the Compact over the network. If so, it might result in a corrupted file instead.

Answer 3

I use this only to make backups, so I copy the BE files one by one with compacting them locally and not on the network.<o:p></o:p>

So, I  put DoEvents just right before the Loop, and made the temp file name change by adding the record id to it.<o:p></o:p>

It works good now.<o:p></o:p>

Thank you anyway.<o:p></o:p>

<o:p> </o:p>

Below is the full code:

Dim timFOLD As String
Dim mainFOLD As String
Dim branFOLD As String
Dim mainFOLD2 As String
Dim branFOLD2 As String
Dim myRSet As Recordset
Dim recCou
Dim C As Integer
Dim MyPass As String

Function CheckMyFile(strFile) As Integer

On Error GoTo Error:

If IsNull(strFile) Then
CheckMyFile = 0
Exit Function
End If
    
Open strFile For Input As #1
Close
CheckMyFile = 1
Exit Function

Error:
    Exit Function

'--------------------------------------------------

Private Sub NewBackup_Click()

'On Error GoTo Err_NewBackup_Click

C = 0

[ResultLBL].Visible = False
timFOLD = Me.StrNew & Format(Now(), "ddmmyyyyhhnnss")
mainFOLD = timFOLD & "\" & "MainDB"
branFOLD = timFOLD & "\" & "BranDB"
mainFOLD2 = mainFOLD & "\" & "M"
branFOLD2 = branFOLD & "\" & "M"

On Error GoTo MyErr


If IsNull([StrOld]) Then
MsgBox "ãä ÝÖáß ¡ ÍÏÏ ÞÇÚÏÉ ÇáÈíÇäÇÊ ¡ ÃæáÇ", vbExclamation, "ÞÇÚÏÉ ÇáÈíÇäÇÊ"
Exit Sub
End If

If IsNull([StrNew]) Then
MsgBox "ãä ÝÖáß ¡ ÍÏÏ ãÓÇÑ ÇáÍÝÙ ¡ ÃæáÇ", vbExclamation, "ÇáãÓÇÑ"
Exit Sub
End If

If Not IsNull(Me.StrNew) Then

MkDir (timFOLD)
MkDir (mainFOLD)
MkDir (branFOLD)
MkDir (mainFOLD2)
MkDir (branFOLD2)

End If

Set myRSet = Me.Recordset
myRSet.MoveLast
myRSet.MoveFirst
recCou = myRSet.RecordCount
ProgressBar0.Max = recCou
ProgressBar0.value = C
DoCmd.Hourglass (-1)

Do While Not myRSet.EOF '===================================================

Dim OldFile As String, DBwithEXT, DBwithoutEXT, NewFile As String, CopyMyDB


OldFile = Me.StrOld
DBwithEXT = Dir(OldFile, vbDirectory)
DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4)
' --------------------- Backup only ---------------------------
If [BKUP] = True Then
Select Case Me.LINKFLDB
Case Is = "MDB"
NewFile = mainFOLD2 & "\" & DBwithoutEXT & Right(DBwithEXT, 4)
Case Is = "BDB"
NewFile = branFOLD2 & "\" & DBwithoutEXT & Right(DBwithEXT, 4)
End Select

CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """"
Shell CopyMyDB, 0
Do Until CheckMyFile(NewFile) = 1
[ResultLBL].Visible = False
Loop
[ResultLBL].Visible = True
'If [CloseMe] = True Then
'DoCmd.Close
'Exit Sub
End If
' ---------------------  Backup with Compact -------------
Dim NewTempFile As String, NewCompFile As String

If [COMP] = True Then

Select Case Me.LINKFLDB

Case Is = "MDB"

NewTempFile = mainFOLD2 & "\" & "AGBC" & Me.bckup__id & Right(DBwithEXT, 4)
NewCompFile = mainFOLD2 & "\" & DBwithoutEXT & Right(DBwithEXT, 4)

Case Is = "BDB"

NewTempFile = branFOLD2 & "\" & "AGBC" & Me.bckup__id & Right(DBwithEXT, 4)
NewCompFile = branFOLD2 & "\" & DBwithoutEXT & Right(DBwithEXT, 4)

End Select

CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewTempFile & """"
Shell CopyMyDB, 0
Do Until CheckMyFile(NewTempFile) = 1
[ResultLBL].Visible = False
DoEvents
Loop

MyPass = ";" & "PWD" & "=" & [PW]
On Error GoTo Err_Compact

If IsNull([PW]) Then DBEngine.CompactDatabase NewTempFile, NewCompFile
If Not IsNull([PW]) And [PSWRD] = True Then DBEngine.CompactDatabase NewTempFile, NewCompFile, , , MyPass
On Error GoTo 0

[ResultLBL].Visible = True

If Dir(NewTempFile, vbDirectory) <> "" Then Kill (NewTempFile)


C = C + 1
ProgressBar0.value = C
myRSet.MoveNext
DoEvents
Loop

myRSet.Close
Set myRSet = Nothing

DoCmd.Hourglass (0)

MyErr:
If Err.Number <> 0 Then
DoCmd.Hourglass (0)

MsgBox Err.Number & " - " & Err.Description, vbMsgBoxRight + vbMsgBoxRtlReading, my_App_Name
End If
Err_Compact:
If Err.Number <> 0 Then

DoCmd.Hourglass (0)

[ResultLBL].Visible = True
[ResultLBL].Caption = "áã" & vbCr & "íäÌÍ" & vbCr & "ÇáÇÌÑÇÁ"
If Dir(NewTempFile, vbDirectory) <> "" Then
Kill (NewTempFile)
End If
MsgBox Err.Number & " - " & Err.Description, , "áã ÊäÌÍ ÇáÚãáíÉ"
End If