Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Zipping a folder in Access 2003 using VBA

Posted on 2011-02-12
13
Medium Priority
?
513 Views
Last Modified: 2012-05-11
Hi experts,

I would like to zip up a folder on my C:\ drive. The folder is just a normal folder that you find in the C:\drive.

I had this code from a couple of years back I think, which came from Experts Exchange.  It works, but only if I am zipping up an MDB.  

Please could somebody help me with the code to so that it zips up the whole folder?

Thank you.

Terry
Private Sub Command0_Click()
Set objFSO = CreateObject("Scripting.FileSystemObject") 'Create instance of FSO

Compress ("C:\FolderA")
Set objFSO = Nothing
End Sub


Sub Compress(fil)
    Dim strPath, strExt, strfile As String

    strPath = Left(fil, InStrRev(fil, "\"))     'Acquire Path
    strfile = Mid(fil, InStrRev(fil, "\") + 1)     'Acquire filename
    strExt = Mid(strfile, InStrRev(strfile, ".") + 1, 3)     'Acquire extension
    Dim strZip As String
    strZip = strPath & Replace(strfile, "mdb", "zip")

    Dim zipFil As Object

    Set zipFil = objFSO.CreateTextFile(strZip)
    zipFil.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
    zipFil.Close

    Dim oApp As Object


    Set oApp = CreateObject("Shell.Application")
    'oApp.NameSpace(strZip).CopyHere strPath & strfile
    oApp.NameSpace(CStr(strZip)).CopyHere strPath & strfile
    DoEvents

    Set oApp = Nothing
    Set zipFil = Nothing
    'uncomment next line to delete file after zipped
    'If objFSO.FileExists(strZip) Then objFSO.DeleteFile (fil) '- only delete source file is zip file is present
End Sub

Open in new window

0
Comment
Question by:TerenceHewett
  • 7
  • 3
  • 3
13 Comments
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 34880451
test this



Private Sub Command0_Click()
Set objFSO = CreateObject("Scripting.FileSystemObject") 'Create instance of FSO

Compress ("C:\FolderA")
Set objFSO = Nothing
End Sub


Sub Compress(fil)
    Dim strPath, strExt, strfile As String

    strPath = Left(fil, InStrRev(fil, "\"))     'Acquire Path
'    strfile = Mid(fil, InStrRev(fil, "\") + 1)     'Acquire filename
'    strExt = Mid(strfile, InStrRev(strfile, ".") + 1, 3)     'Acquire extension
    Dim strZip As String
    strZip = mid(fil,instr(fil,"\")+1)

    Dim zipFil As Object

    Set zipFil = objFSO.CreateTextFile(strZip)
    zipFil.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
    zipFil.Close

    Dim oApp As Object


    Set oApp = CreateObject("Shell.Application")
    'oApp.NameSpace(strZip).CopyHere strPath & strfile
    'oApp.NameSpace(CStr(strZip)).CopyHere strPath & strfile
    oApp.NameSpace(CStr(strZip)).CopyHere oApp.NameSpace(fil &"\").items
    DoEvents
    On Error Resume Next
    Do Until oApp.NameSpace(ZipFileName).Items.Count = _
                oApp.NameSpace(fil & "\").Items.Count
    DoEvents
    Loop
    On Error GoTo 0


    Set oApp = Nothing
    Set zipFil = Nothing
    'uncomment next line to delete file after zipped
    'If objFSO.FileExists(strZip) Then objFSO.DeleteFile (fil) '- only delete source file is zip file is present
End Sub

Open in new window

0
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 34880454
oops,

change this
strZip = mid(fil,instr(fil,"\")+1)

with
strZip = mid(fil,instr(fil,"\")+1) & ".zip"
0
 

Author Comment

by:TerenceHewett
ID: 34880484
Hi Cap, and thanks for your help.

I get a runtime error 424 object required on the following line:

Set zipFil = objFSO.CreateTextFile(strZip)

As a note, when I hover over strZip, it does give me "FolderA.zip", but zipFil is empty when hovered over.

Any ideas why?

Your help is really appreciated as usual.

Regards
Terry
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 34880537
change these lines

    Set zipFil = objFSO.CreateTextFile(strZip)
    zipFil.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
    zipFil.Close

with


        Open strZip For Output As #1
        Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
        Close #1
0
 

Author Comment

by:TerenceHewett
ID: 34880618
Hi Cap,

I get run time error 91 : object variable or with block variable not set on the following line:

oApp.NameSpace(CStr(strZip)).CopyHere oApp.NameSpace(fil & "\").Items

When I hover over "fil" I get the following exact text:

 "c:\folderA"

and when I hover over "strZip" I get the following exact text:

"FolderA.zip"  (does not contain the path)

Your continued help would be so appreciated on this. I am pulling my hair out.

Regards
Terry
0
 

Author Comment

by:TerenceHewett
ID: 34881778
Just to mention, in case it is relevant to the problem, I am using Win Vista Business.  

Regards,

Terry
0
 
LVL 11

Accepted Solution

by:
RgGray3 earned 2000 total points
ID: 34882581
The routine I created for my own use...  takes SourceFolder and TargetFileName

The only bit of code that would need modification is that I use another function to return the users home desktop path and place the zip on the users desktop.

as stated in the comments it requires references to Shell32.dll and Windows Scripting




Sub CreateZipFromFolder(strSourceFolder As String, strZipFileName As String)
' --------------------------------------------------------------------
' (C) 2005-2011, Richard Gray, III Software     All rights reserved.
' --------------------------------------------------------------------
' Parameters: strSourceFolder - The Full Path Folder Name
'             strZipFileName  - The FileName for the ZipFile (No Path
' -----------------------------------------------------------------------------------------
' Comments  : Tested and placed in library 2/6/2011
'               Requires references to Shell32.dll and Windows Scripting Host
'               IWshRuntimeLibrary  C:\WINDOWS\system32\wshom.ocx
'               Shell32             C:\WINDOWS\system32\SHELL32.dll
' -----------------------------------------------------------------------------------------
On Error GoTo PROC_ERR

Dim ShellApp            As Shell
Dim fso                 As New FileSystemObject
Dim strFpTargetFileName As String

Const cstrExt           As String = ".zip"

    Set ShellApp = CreateObject("Shell.Application")
        
    '---------------------------------------
    'Confirm that we have a Zip extension
    '---------------------------------------
    If Right(strZipFileName, 4) <> cstrExt Then
        strZipFileName = strZipFileName & cstrExt
    End If
    
    '---------------------------------------
    'Create the Full Path Target FileName
    '---------------------------------------
    strFpTargetFileName = GetHomeDesktop() & "\" & strZipFileName
    
    '---------------------------------------
    'Create the Zip Header
    '---------------------------------------
    fso.CreateTextFile(strFpTargetFileName, True).WriteLine "PK" & Chr(5) & Chr(6) & String(18, 0)

    '---------------------------------------
    'Copy the files into the zip file
    '---------------------------------------
    ShellApp.NameSpace(strFpTargetFileName).CopyHere (strSourceFolder)

    '-------------------------------------------------------------------------------
    'Tell the user the good news
    '-------------------------------------------------------------------------------
    DoCmd.Beep
    gstrMbMessage = "Compressed File Name" & vbCrLf & _
                    strZipFileName & vbCrLf & _
                    "Created on your Desktop"
    gintMbStyle = vbInformation + vbOKOnly + vbDefaultButton1
    gstrMbTitle = "Compressed File Created"

PROC_EXIT:
    MsgBox gstrMbMessage, gintMbStyle, gstrMbTitle
    Set ShellApp = Nothing
    Set fso = Nothing

    Exit Sub

PROC_ERR:
    gstrMbMessage = Err.Number & ": " & Err.Description
    gstrMbTitle = "Zip File Creation Error"
    gintMbStyle = vbInformation + vbOKOnly + vbDefaultButton1
    Resume PROC_EXIT

End Sub

Open in new window

0
 
LVL 11

Expert Comment

by:RgGray3
ID: 34882586
BTW:  I also use 3 global vars for my message boxes so you would need to modify the msgbox calls to suit your own style of coding
0
 

Author Comment

by:TerenceHewett
ID: 34882838
Thanks RgGray3,

I have set the references as instructed and I have debugged and no errors are reported.  Although - I get run time error 91 : object variable or with block variable not set when I run the code.

Any ideas to what i am doing wrong?

Regards
Terry
0
 

Author Comment

by:TerenceHewett
ID: 34882847
The 91 error in the post above highlights the following line of code:

    '---------------------------------------
    'Copy the files into the zip file
    '---------------------------------------
    ShellApp.NameSpace(strFpTargetFileName).CopyHere (strSourceFolder)

Not sure what I am doing wrong.
0
 

Author Comment

by:TerenceHewett
ID: 34882889
No matter - all fixed.  I was being thick as usual.

Regards

Terry
0
 

Author Comment

by:TerenceHewett
ID: 34882891
Sorry - manners....thank you very much for all the help.

Regards

Terry
0
 
LVL 11

Expert Comment

by:RgGray3
ID: 34882989
Well...   It's funny because I was going nutz just a week ago with the same problem...
Found a series of routines that either were not complete or would not compile...

When I finally distilled what I had found I was suprised to realize how little code was actually involved...

Glad to help and share...

Rich
0

Featured Post

NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you’re using QODBC to update QuickBooks data from Microsoft® Access but Access is not showing the updated data, you could have set up QODBC incorrectly.
Windows Explorer lets you open cabinet (cab) files like any other folder. In VBA you can easily handle normal files and folders, but opening and indeed creating cabinet files takes a lot more - and that's you'll find here.
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …
Add bar graphs to Access queries using Unicode block characters. Graphs appear on every record in the color you want. Give life to numbers. Hopes this gives you ideas on visualizing your data in new ways ~ Create a calculated field in a query: …

783 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question