Zipping with VBA

[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