Problem Creating a usable zip file using VBA. Does anyone have an alternative?

Let’s say you want to make a backup of your database and email a copy to somewhere – as a backup on the same machine isn’t much use.

If you don't want to email it don't add that section of code to your button.

Here’s a simple method I used to use.  I don’t anymore as we now have a different system in place, but this will start you off in the right direction.

I use MS Outlook, so if you don’t you’ll need to alter the code to use whatever mailing system you do use.

First
Create a form with a button – call it   cmd_backup

Next create a macro – call it   mcr_Backup

Next create a module – call it   mod_Backup

In the module paste this and save it (I didn’t write this, I’ve changed a few lines from the original which I can't remember where I got it from)

Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function SendTheBackUp () As Long
    Dim ShellApplication    As Object
    Dim CurrentProjectFile  As String
    Dim ZipPath             As String
    Dim ZipName             As String
    Dim ZipFile             As String
    Dim FileNumber          As Integer
    CurrentProjectFile = CurrentProject.Path & "\" & CurrentProject.Name
    ZipPath = CurrentProject.Path & "\_My_backup_created_on_" & Format(Date, "mm-dd-yyyy") & "_at_" & Format(Time, "hh-mm")
    ZipName = ".zip"
    ZipFile = ZipPath & ZipName

    If Dir(ZipPath, vbDirectory) = "" Then
        MkDir ZipPath
    End If
    FileNumber = FreeFile
    Open ZipFile For Output As #FileNumber
    Print #FileNumber, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
    Close #FileNumber

    Set ShellApplication = CreateObject("Shell.Application")
    With ShellApplication
        Debug.Print Timer, "zipping started ..."
        .NameSpace(CVar(ZipFile)).CopyHere CVar(CurrentProjectFile)
        On Error Resume Next
        Do Until .NameSpace(CVar(ZipFile)).Items.Count = 1
            'DoEvents
            Sleep 100
            Debug.Print " .";
        Loop
        Debug.Print
        On Error GoTo 0
        Debug.Print Timer, "Zip done."
    End With
    Set ShellApplication = Nothing
    ZipCurrentProject = Err.Number
End Function

Next in the macro call the module (can be done in VBA but simpler to see what is going on if it’s in a macro)

Action = RunCode
Arguments = SendTheBackUp()
Function Name = SendTheBackUp

Next code the button to send the back up somewhere –

Private Sub cmd_backup_Click()
    DoCmd.RunMacro "mcr_Backup", , ""
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    Dim strpath As String
    Dim varMail As Variant
    Dim varMailCC As Variant
    Dim varSubject As Variant
    Dim varcontact As Variant
    Dim varBody As Variant
    
    strpath = "This is where the file will go to "
    strfile = CurrentProject.Path & "\_My_Back_created_on_" & Format(Date, "mm-dd-yyyy") & "_at_" & Format(Time, "hh-mm") & ".zip"
‘of course you can take the details (mail address, name, etc) from the form controls if you prefer, but I have hard coded them below to show you where the details are.
     varMail = "Email address removed"
    varMailCC = "Email address removed"
    varSubject = "Hey, I've made a backup"
    varcontact = "Some name here"
    varBody = "<P><font face=calibri color=Black style= font-size:20px>  " & varcontact & " <p>A backup has been created." & Chr(13) + Chr(10) & Chr(13) + Chr(10) _
    & "Add more information here if you want to.</p>"
        Set appOutLook = CreateObject("Outlook.Application")
        Set MailOutLook = appOutLook.CreateItem(olMailItem)
        With MailOutLook
            .BodyFormat = olFormatRichText
            .To = varName
            .CC = varCC
            .Subject = varSubject
            .HTMLBody = varBody
            .Attachments.Add (strfile)
            .Display
         End With         
End Sub

Hope this helps

K