Solved

Another Simple VBA - Add to Zip

Posted on 2013-05-20
28
793 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
  • 14
  • 12
  • +1
28 Comments
 
LVL 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
I don't see NewRef being set anywhere....

Jim.
0
 
LVL 1

Author Comment

by:CFMI
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
 
LVL 1

Author Comment

by:CFMI
Comment Utility
Run-time error '91'
Object variable or With block variable not set
0
 
LVL 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
<<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
Comment Utility
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 84
Comment Utility
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
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
<<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
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
<<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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 1

Author Comment

by:CFMI
Comment Utility
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
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
Comment Utility
This isn't compile-able.  What is it?

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

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
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
Comment Utility
I'm still struggling with this.  Please stay tuned.
0
 
LVL 1

Author Comment

by:CFMI
Comment Utility
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 57

Expert Comment

by:Jim Dettman (Microsoft MVP/ EE MVE)
Comment Utility
<<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 21
Comment Utility
0
 
LVL 1

Author Comment

by:CFMI
Comment Utility
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 57

Accepted Solution

by:
Jim Dettman (Microsoft MVP/ EE MVE) earned 500 total points
Comment Utility
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
Comment Utility
I'm not sure if this works but I'm requested to close this issue.  Thanks for all of your input.
0

Featured Post

Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

Join & Write a Comment

This article is a continuation or rather an extension from Cascading Combos (http://www.experts-exchange.com/A_5949.html) and builds on examples developed in detail there. It should be understandable alone, but I recommend reading the previous artic…
I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

771 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now