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,906
    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
    Last edited by Paul_Hossler; 10-12-2017 at 11:56 AM.

  4. #4
    VBAX Tutor Logit's Avatar
    Joined
    Sep 2016
    Posts
    288
    Location
    .
    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 !
    Attached Files Attached Files

  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
    VBAX Tutor Logit's Avatar
    Joined
    Sep 2016
    Posts
    288
    Location
    .
    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
  •