?
Solved

Another Simple VBA - Add to Zip

Posted on 2013-05-20
28
Medium Priority
?
836 Views
Last Modified: 2013-07-15
This should be such a no-brainer considering that you've posted the answer repeatedly.  I just cannot get the following code to zip a file.  I know the NewMo,ExportDir, and sDest are correct.  In the immediate window, they correspond appropriately.  Why doesn't the "sDest" add to an existing (ExportDir & NewMo & " WAs.zip") file?

Dim sDest As String
Dim NewRef As String
Dim NewMo As String
Dim ExportDir As String

    NewMo = Format(Now(), "yyyymm")
    ExportDir = "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\WAs\"
    sDest = ExportDir & NewRef & "_Direct Download STI-CSV with Text_0.txt"
   
Dim oApp As Object
 
Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
Set oApp = Nothing
0
Comment
Question by:CFMI
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 14
  • 12
  • +1
28 Comments
 
LVL 58
ID: 39182165
I don't see NewRef being set anywhere....

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39182448
Good catch.

Actually it was in my original code as "NewRef = Format(Now(), "mmddyy")."  That code was stripped because I had other steps in it.  Really it's just the above - with NewRef - which doesn't error but also doesn't move file to zip.  Since FileCopy will become mute when I get the zip code to work, I didn't send the FileCopy because it unnecessarily confuses the issue.  Full code is

Function DCA_Copy()
Dim sDest As String
Dim sSource As String
Dim NewRef As String
Dim ImportDir As String
Dim ExportDir As String
    NewRef = Format(Now(), "mmddyy")
    ImportDir = "\\Sv-appdev-p1\Cash\Receipts Allocation\Import Files\"
    ExportDir = "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\DCAs\"
    NewMo = Format(Now(), "yyyymm")

sSource = ImportDir & "Daily Cashier Adjustments.xlsx"
sDest = ExportDir & NewRef & "_Daily Cashier Adjustments.xlsx"

FileCopy sSource, sDest

'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv

Dim oApp As Object

Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
    Set oApp = Nothing

End Function
0
 
LVL 58
ID: 39182543
What may be happening is that your compression is not done before you exit the procedure.

Try doing this:

Dim oApp As Object

Set oApp = CreateObject("Shell.Application")

oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest

' Wait until complete.
Do Until oApp.Namespace(ExportDir & NewMo & " WAs.zip").items.Count = 1
     DoEvents
Loop

Set oApp = Nothing

Jim.
0
Industry Leaders: 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 1

Author Comment

by:CFMI
ID: 39182577
Run-time error '91'
Object variable or With block variable not set
0
 
LVL 58
ID: 39184231
Alright, before we go crazy then, take your original procedure (without the loop) and place a stop right after trying to add to the zip.

When you hit it, wait about 20 seconds and then hit F5 to continue; was the file added to the archive?

If so, then we'll figure out the wait loop.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39184680
I tried two things.
1) took original procedure (without the loop) and placed a stop right after trying to add to the zip. The same result occurred:
      Run-time error '91'
      Object variable or With block variable not set
The code doesn't even get to
      DoEvents line.
2) took original procedure (with the loop remarked out) and placed a stop right after trying to add to the zip.
      compile error do without loop

The Do Until Event is clearly causing an issue.
     Do Until oApp.Namespace(ExportDir & NewMo & " WAs.zip").items.Count = 1
     DoEvents
0
 
LVL 58
ID: 39184979
<<e Do Until Event is clearly causing an issue.
     Do Until oApp.Namespace(ExportDir & NewMo & " WAs.zip").items.Count = 1
     DoEvents >>

 As I said, go back to your original code without the loop I gave you:

Dim oApp As Object

Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
    Set oApp = Nothing

End Function

 Just place a stop after calling CopyHere and wait, then continue.

 If the file is added to the zip, then we'll see about getting the loop right.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39185051
Well you've been so patient but I'm frustrated now because I swear yesterday before the looping, the code ran but did nothing.  Now, the same original code

Dim oApp As Object

Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
    Set oApp = Nothing

End Function

 returns
      Run-time error '91':
      Object variable or With block variable not set

What the. . . .?
0
 
LVL 85
ID: 39186032
It would help GREATLY if you would do the following:

1) Post the full block of code you're currently using.
2) Indicate exactly where the error is occurring - the exact line is most helpful.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39188069
All right.  Back to the drawing board.  
1)  "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\WAs" directory holds two files
      a.  052213_Direct Download STI-CSV with Text_0.txt
      b.  201305 WAs.zip  (The key here is the file was last modified 5/17/2013.)

2)  I copied the code from above to make the function as shown:

Function Zip_File()
Dim sDest As String
Dim NewRef As String
Dim NewMo As String
Dim ExportDir As String
    NewMo = Format(Now(), "yyyymm")
    ExportDir = "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\WAs\"
    sDest = ExportDir & NewRef & "_Direct Download STI-CSV with Text_0.txt"
   
Dim oApp As Object
 
Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
Set oApp = Nothing

End Function

3)  The code DOES run without error so that's a start.
4)  I set a break at "Set oApp = Nothing" and ran the code.
5)  No event occurred.  I know that because the "date modified" of the " 201305 WAs.zip" didn't change.

Am I correct in thinking this code can add to an existing zip?
0
 
LVL 58
ID: 39188438
<<Am I correct in thinking this code can add to an existing zip? >>

Sure seems like you can (see "ZIP folders with System.Shell Folder's CopyHere method"):

http://www.robvanderwoude.com/vbstech_files_zip.php

Never tried it myself, but that link contains a complete procedure, so you might want to start with that rather then trying to write one.

<<5)  No event occurred.  I know that because the "date modified" of the " 201305 WAs.zip" didn't change.>>

 If you want to stick with what you have, put a STOP higher up in the code and step through with F8 making sure it's executing as it should.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39192250
Yeah.  I know there are facilitative tools out there.  Unfortunately I'm prohibited from using them.  So I'm kind of stuck without some guidance to get me over the hurdle.  I did place the break at the "oApp.Namespace(ExportDir & NewMo & " WAs.zip").CopyHere sDest" step.  The code is reading everything right (I can see that as I step through).  When I get to "Set oApp = Nothing," it reads "Nothing = Nothing" and that's just what I get. .  Nothing.  Code runs with NO RESULTS.
0
 
LVL 58
ID: 39194356
<<When I get to "Set oApp = Nothing,">>

  You did wait about ten or fifteen seconds to give it a chance to do the operation correct?  Assuming you did, just want to double check.

<<Code runs with NO RESULTS>>

 Hum....not sure what to tell you, let me try it here.

Jim.
0
 
LVL 58
ID: 39194441
Ok I dug around and tested and came up with a couple of things:

1. The copyhere will work (complete code below).  However since you are using the Windows Copy function, you can get dialogs that pop up, so it's not a fully automated solution.  Paste the code below into a module in a new DB.  Try zipping a couple of files.  Then try zipping the same files to the same zip.  You'll get an overwrite dialog.

2. If you want more control over the process, there is a zip/unzip example here by a fellow MVP:

http://www.kallal.ca/zip/index.htm

  This relies on two DLL's, but they are simple to use. You just need to drop them into the directory of the DB and use the routines as is in the sample DB's.

  That should get you going one way or another.  Note that I may not be able to respond before Monday if you have any questions.  I'm only in for a couple more hours today.

Jim.

Private Declare Sub Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long _
)

Public Sub Zip( _
    ZipFile As String, _
    InputFile As String _
)
On Error GoTo ErrHandler
    Dim FSO As Object 'Scripting.FileSystemObject
    Dim oApp As Object 'Shell32.Shell
    Dim oFld As Object 'Shell32.Folder
    Dim oShl As Object 'WScript.Shell
    Dim i As Long
    Dim l As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FileExists(ZipFile) Then
        'Create empty ZIP file
        FSO.CreateTextFile(ZipFile, True).Write _
            "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    End If

    Set oApp = CreateObject("Shell.Application")
    Set oFld = oApp.NameSpace(CVar(ZipFile))
    i = oFld.Items.Count
    oFld.CopyHere (InputFile)

    Set oShl = CreateObject("WScript.Shell")

    'Search for a Compressing dialog
    Do While oShl.AppActivate("Compressing...") = False
        If oFld.Items.Count > i Then
            'There's a file in the zip file now, but
            'compressing may not be done just yet
            Exit Do
        End If
        If l > 30 Then
            '3 seconds has elapsed and no Compressing dialog
            'The zip may have completed too quickly so exiting
            Exit Do
        End If
        DoEvents
        Sleep 100
        l = l + 1
    Loop

    ' Wait for compression to complete before exiting
    Do While oShl.AppActivate("Compressing...") = True
        DoEvents
        Sleep 100
    Loop

ExitProc:
    On Error Resume Next
        Set FSO = Nothing
        Set oFld = Nothing
        Set oApp = Nothing
        Set oShl = Nothing
    Exit Sub
ErrHandler:
    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & _
                   ": " & Err.Description, _
                   vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Sub

Public Sub UnZip( _
    ZipFile As String, _
    Optional TargetFolderPath As String = vbNullString, _
    Optional OverwriteFile As Boolean = False _
)
On Error GoTo ErrHandler
    Dim oApp As Object
    Dim FSO As Object
    Dim fil As Object
    Dim DefPath As String
    Dim strDate As String

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Len(TargetFolderPath) = 0 Then
        DefPath = CurrentProject.Path & ""
    Else
        If FSO.folderexists(TargetFolderPath) Then
            DefPath = TargetFolderPath & ""
        Else
            Err.Raise 53, , "Folder not found"
        End If
    End If

    If FSO.FileExists(ZipFile) = False Then
        MsgBox "System could not find " & ZipFile _
            & " upgrade cancelled.", _
            vbInformation, "Error Unziping File"
        Exit Sub
    Else
        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        With oApp.NameSpace(ZipFile & "")
            If OverwriteFile Then
                For Each fil In .Items
                    If FSO.FileExists(DefPath & fil.Name) Then
                        Kill DefPath & fil.Name
                    End If
                Next
            End If
            oApp.NameSpace(CVar(DefPath)).CopyHere .Items
        End With

        On Error Resume Next
        Kill Environ("Temp") & "Temporary Directory*"

        'Kill zip file
        Kill ZipFile
    End If

ExitProc:
    On Error Resume Next
    Set oApp = Nothing
    Exit Sub
ErrHandler:
    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Sub
0
 
LVL 1

Author Comment

by:CFMI
ID: 39194466
Jim,  You have been sooo patient and amazingly supportive.  I'm also working a "one foot in the office" mode.  I'll respond back next week.  TTYL.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39202789
I pulled the dll files.  From VBA Tools > References > Browse, I "Can't add a reference to the specified file."  I wonder if they're from a *mdb.  I'm using Access 2010 v 14.0.6112.5000 (32-bit).  I also don't know if I've got reference conflicts. I'm using the DAO 3.6 Reference Library because some of the code I'm using is old.
0
 
LVL 58
ID: 39203086
Don't believe you need to set a reference.  DLL's just need to be in the same directory as the DB that's using the functions provided (assume were talking about approach #2 above).

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39205675
This isn't compile-able.  What is it?

Private Declare Sub Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long _
)
0
 
LVL 58
ID: 39205742
Get rid of the line continue characters and place it all on one line.

 It's a Windows API call to suspend execution for a number of milliseconds and is commonly used.

 DoEvents can be used, but you need to put it in a loop as execution doesn't stop.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39205803
I did that
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

I even added a "End Sub" statement.  I'm wondering if the "Declare" or "Sleep Lib "kernel32"" are throwing down.  VBA doesn't recognize it as a sub or function.

Let me explain better the situation.  I'm trying to expedite this zip routine in a function and to call that function when necessary.  I'm seeing your recommendation to use this "Sleep API function" but there is no form associated with it.  Does that make a difference?
0
 
LVL 58
ID: 39207898
That is a windows API declaration and it belongs at the top of a standard module (not a class module nor in a form or report).   End sub is not required as it is not a procedure.

If the code doesn't use it, you can remove it.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39217353
I'm still struggling with this.  Please stay tuned.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39257204
I'm trying to keep this simple so while the above "oShl.AppActivate" might work, but it's too complex for my novice brain.  

New information:
1)  The original code works if I don't use a variant after "CopyHere."  So "sDest" is the problem.  If I provide a full path and filename after "CopyHere,"  EVERYTHING WORKS.  YAY!!

2)  The problem is there are already the same filenames within the zip file but each has a date prefix.  I'm just trying to add another of the same but WITH that current date as a prefix to distinguish it from the other files in the zip.  Please see variant "sDest" and help me to enable it to behave as a literal after "CopyHere."  

Dim sDest As String
Dim NewRef As String
Dim NewMo As String
Dim ExportDir As String

    NewMo = Format(Now(), "yyyymm")
    ExportDir = "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\WAs\"
    sDest = ExportDir & NewRef & "_Direct Download STI-CSV with Text_0.txt"
   
Dim oApp As Object
 
Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
    PAUSE 3
Set oApp = Nothing
0
 
LVL 58
ID: 39259221
<<2)  The problem is there are already the same filenames within the zip file but each has a date prefix.  I'm just trying to add another of the same but WITH that current date as a prefix to distinguish it from the other files in the zip.  Please see variant "sDest" and help me to enable it to behave as a literal after "CopyHere."  >>

 Delete the zip file with the Kill statement, then let it re-create the zip with the new files.

 or do you want the archive to build up with a series of files and act as an archive?

<<Please see variant "sDest" and help me to enable it to behave as a literal after "CopyHere."  >>

 It's already doing that.  I still don't see NewRef  used anywhere.

 Do this:

1. Put a STOP in the procedure like this:

Dim sDest As String
Dim NewRef As String
Dim NewMo As String
Dim ExportDir As String

STOP

    NewMo = Format(Now(), "yyyymm")
    ExportDir = "\\carefirst.com\corp\shared\Finance\Finance Shared\Cash Management\Receipts Allocations\WAs\"
    sDest = ExportDir & NewRef & "_Direct Download STI-CSV with Text_0.txt"
   
Dim oApp As Object
 
Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(ExportDir & NewMo & " WAs.zip").CopyHere sDest
    PAUSE 3
Set oApp = Nothing


 and execute.   Now step through line by line with F8.   You can hover over variables after they've been assigned or print them out in the debug window (Ctrl/G) like this:

?  sDest

and the value of sDest is what I would double check.

Jim.
0
 
LVL 1

Author Comment

by:CFMI
ID: 39279106
Jim,
I guess I should have clarified earlier that I DID check the variables in VBA debug as:
1)  ?ExportDir & NewMo & " WAs.zip"
2)  ?sDest
Both returned accurate path/filename strings.

The odd thing was that when I replaced the sDest variable with a literal (written out) path and filename, the zip process worked.  I feel like I'm so close because all I did was to change the variable (which I know was correct) to a literal.

TheHiTechCoach,
I am reviewing the code you shared and will respond back with my understanding or lack thereof.  Thanks.
0
 
LVL 58

Accepted Solution

by:
Jim Dettman (Microsoft MVP/ EE MVE) earned 1500 total points
ID: 39279306
Try:

  sDest = chr$(34) & ExportDir & NewRef & "_Direct Download STI-CSV with Text_0.txt" & chr$(34)

Jim.
0
 
LVL 1

Author Closing Comment

by:CFMI
ID: 39327397
I'm not sure if this works but I'm requested to close this issue.  Thanks for all of your input.
0

Featured Post

Prepare for your VMware VCP6-DCV exam.

Josh Coen and Jason Langer have prepared the latest edition of VCP study guide. Both authors have been working in the IT field for more than a decade, and both hold VMware certifications. This 163-page guide covers all 10 of the exam blueprint sections.

Question has a verified solution.

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

Phishing attempts can come in all forms, shapes and sizes. No matter how familiar you think you are with them, always remember to take extra precaution when opening an email with attachments or links.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…
Suggested Courses

765 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