Consulting

Results 1 to 8 of 8

Thread: Zipping with VBA

  1. #1

    Question Zipping with VBA

    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.

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master xld's Avatar
    Joined
    Apr 2005
    Posts
    24,827
    Location
    Show us the code that you tried and tell us where it doesn't do what you want.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    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 
    
    
    Formatting tags added by mark007
    Last edited by Paul_Hossler; 10-12-2017 at 11:56 AM.

  4. #4
    .
    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 
    
    
    Formatting tags added by mark007
    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 !
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.

  5. #5
    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!

  6. #6
    .
    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 ??

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

  8. #8
    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.
    codekabinett.com - Tips, tricks and code samples for Access & VBA

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •