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

  • 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?

    Wednesday, January 30, 2019 11:29 PM

All replies

  • 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

    Thursday, January 31, 2019 2:11 AM
  • 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.
    Thursday, January 31, 2019 3:46 PM
  • 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
    


    Thursday, January 31, 2019 8:11 PM