Another Simple VBA - Add to Zip

I don't see NewRef being set anywhere....

Jim.

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

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.

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

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.

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

<<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.

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

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.

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?

<<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.

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.

<<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.

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

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.

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.

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.

This isn't compile-able.  What is it?

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

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.

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?

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.

I'm still struggling with this.  Please stay tuned.

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

<<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.

Try  this code:  http://accessexperts.com/blog/2012/02/06/zipandunzipfrommicrosoftvba/

Also see:
http://www.rondebruin.nl/win/section7.htm

From my post here: MS Access VBA to Zip two files

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.

I'm not sure if this works but I'm requested to close this issue.  Thanks for all of your input.