Zipping with VBA

[jfougerousse]

I have a database that I am working on and there is a macro that creates a text file backup in a folder on the users C:/. it creates 18 text files. what I am wanting to do is be able to have another process that runs but after creating the files I would like them all zipped together. I am at a loss, I have seen some information on creating a zip with vba but can't seem to adapt it to what I need. the code would need to generate the filename of MY choosing rather than let the user decide.

[Bob Phillips]

Show us the code that you tried and tell us where it doesn't do what you want.

[jfougerousse]

Actually here is the code I have.... this set actually lets the user determine where to save the file. this would be fine if it would create a zip file instead of a folder with the text files inside.

Private Sub cmdSaveAs_Click()
Dim intDecision As Integer
On Error GoTo Error_cmdSaveAs
'Opens a Treeview control that displays the directories in a computer
         Dim lpIDList       As Long
         Dim sBuffer        As String
         Dim sNewDir        As String
         Dim sNewSaveBuffer As String
         Dim sTempString    As String
         Dim szTitle        As String
         Dim tBrowseInfo    As BrowseInfo
         Dim sDateDir       As String
         Dim sNewFolder     As String
         szTitle = "Location to Save Data"
         With tBrowseInfo
            .hWndOwner = Me.hwnd
            .lpszTitle = lstrcat(szTitle, "")
            .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
         End With
         lpIDList = SHBrowseForFolder(tBrowseInfo)
         If (lpIDList) Then
            sBuffer = Space(MAX_PATH)
            SHGetPathFromIDList lpIDList, sBuffer
            sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
            
            Me.Form.Visible = False
            MsgBox "Winstabs Data will be saved in " & vbCrLf & vbCrLf & _
            sBuffer
            
            Else
            
            MsgBox "Export Action Canceled.", vbOKOnly, "Action Canceled by User."
            Exit Sub
            
         End If
                  
         sDateDir = "\WData" & DLookup("Year", "tblTreasID") & "_L" & _
         DLookup("LocalNo", "tblTreasID") & "_" & Format(CStr(Right(Year(Now), 4)), "0000") & _
         "-" & Format(CStr(Month(Now)), "00") & "-" & Format(CStr(Day(Now)), "00") & "_" & _
         Format(CStr(Hour(Now)), "00") & "h" & Format(CStr(Minute(Now)), "00") & "m"
         sNewDir = sBuffer & sDateDir
         
         If Mid(sNewDir, 3, 2) = "\\" Then
         
            sTempString = Left(sNewDir, 3) & Right(sNewDir, (Len(sNewDir) - 4))
            
            sNewDir = sTempString
            sTempString = ""
         
         End If
         
         
         MkDir sNewDir
         
    DoCmd.Hourglass True
    sNewSaveBuffer = sNewDir & "\wstabs01.txt"
    DoCmd.TransferText acExportDelim, , "exportpopup", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs02.txt"
    DoCmd.TransferText acExportDelim, , "tblMemberRecord", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs03.txt"
    DoCmd.TransferText acExportDelim, , "tblBillingHistory", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs04.txt"
    DoCmd.TransferText acExportDelim, , "tblInsurance", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs05.txt"
    DoCmd.TransferText acExportDelim, , "tblE49", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs06.txt"
    DoCmd.TransferText acExportDelim, , "ExportPayrollTax", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs07.txt"
    DoCmd.TransferText acExportDelim, , "tblTransfers", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs08.txt"
    DoCmd.TransferText acExportDelim, , "tblPayroll", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs09.txt"
    DoCmd.TransferText acExportDelim, , "tblMileage", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs10.txt"
    DoCmd.TransferText acExportDelim, , "tblCheckbook", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs11.txt"
    DoCmd.TransferText acExportDelim, , "tblBilling", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs12.txt"
    DoCmd.TransferText acExportDelim, , "tblBilling2", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs13.txt"
    DoCmd.TransferText acExportDelim, , "tblTreasID", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs14.txt"
    DoCmd.TransferText acExportDelim, , "tblTreasurer", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs16.txt"
    DoCmd.TransferText acExportDelim, , "tblMinutes", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs17.txt"
    DoCmd.TransferText acExportDelim, , "tblE49History", sNewSaveBuffer, True
    sNewSaveBuffer = sNewDir & "\wstabs18.txt"
    DoCmd.TransferText acExportDelim, , "tblBillingHistoryPg3", sNewSaveBuffer, True
    
    DoCmd.Hourglass False
    
    sNewFolder = Right(sDateDir, Len(sDateDir) - 1)
   
    MsgBox "Files Exported Successfully to a Folder Named " & vbCrLf & vbCrLf & _
    sNewFolder, vbOKOnly, "Export Complete - " & sNewDir
    
    Me.Form.Visible = True
    
    intDecision = _
    MsgBox("Do you wish to make another Backup?", vbYesNo, "Backup Completed")
    
    If intDecision = vbNo Then
        
    DoCmd.Close
    
    Else
    
    Exit Sub
    
    End If
    
Exit_cmdSaveAs:
    Exit Sub
    
Error_cmdSaveAs:
'     MsgBox Err.Description
    Me.Form.Visible = True
    Resume Exit_cmdSaveAs

End Sub

[Logit]

.
You can use this project ... I'm certain there are a few modifications you'll want to effect :

Option Explicit


Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip
       
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If


    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"


    'Browse to the file(s), use the Ctrl key to select more files
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
        'do nothing
    Else
        'Create empty Zip File
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
            Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)


                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr


        MsgBox "You find the zipfile here: " & FileNameZip
    End If
End Sub


Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub




Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function




Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

The complete project attached. As is, the code allows the user to select the folder then files to be zipped. You can hard code that to the present folder where all files are saved.
The zipped file is placed in the DOCUMENTS folder. That too can be edited for your purposes.

Cheers !

[jfougerousse]

Forgive the Noob question, Logit, I am having trouble getting this to work in access. what I would like to do is have a form with a button that loads your code. anytime I try to tie the code to the "on click" code builder it simply doesn't work

I am sorry for the new questions, I am a bit rusty with coding!

[Logit]

.
Sorry for the confusion. Excel VBA doesn't always work with ACCESS. It has been decades since I've messed with ACCESS ... hopefully someone else can assist you.

Anyone ??

[jfougerousse]

Thank you for the help anyway.. will work well when I am using excel!!!!

[PhilS]

I think Logit's sample code is coupled very tightly to Excel. E.g. the Application.Something-Methods need to be adjusted for Access, Workbook/Worksheet reference will not work, etc.

I published an extensive info on ZIP-Archives with VBA and the Shell32 libraryon my website. It is based on the same approach of using the built-in Shell32 libaray, but it is split into smaller and more digestible procedures, which should work in any VBA enabled application.