CODEWITHSUNDEEP
vbscriptzipcompression
Edrei
Edrei

Reputation: 11

Copy file to compressed folder

I'm trying to copy an existing file to an existing compressed folder without any 3rd party tools.

I tried two different ways but none were successful. I use a text file for my examples, in reality I need to copy an Excel File to an existing compressed folder in a shared drive.

1st Way (FileSystemObject):

Call MoveToZip()

Function MoveToZip()
    Dim FromPath, ToPath, ObjFSO

    FromPath = "C:\Users\User\Desktop\New_Folder\TestFile.txt"
    ToPath = "C:\Users\User\Desktop\NewCompressed.zip"

    Set ObjFSO = CreateObject("Scripting.FileSystemObject")

    ObjFSO.CopyFile FromPath, ToPath
End Function

2nd Way (Shell):

Call fnMoveToZip()

Function fnMoveToZip()
    Dim objShell
    Dim objFolder

    Set objShell = CreateObject("shell.Application")
    Set objFolder = objShell.NameSpace("C:\Users\User\Desktop\NewCompressed.zip")

    objFolder.CopyHere("C:\Users\User\Desktop\New_Folder\TestFile.txt")


    Set objShell = nothing
    Set objFolder = nothing
End Function

Upvotes: 0

Views: 1968

Answers (5)

Jean-Marc
Jean-Marc

Reputation: 109

As I was testing my archiving process some files were allready archived and my function was stuck in a loop. So I made theses changes:
(in MS-Access 2013 VBA)

Public Function addToZip(destZip As String, filename As String) As Boolean
On Error GoTo copyErr
Dim oShell, oFolder, cFlags
Dim i As Integer, k As Integer, t As Single
cFlags = FOF_RENAMEONCOLLISION + FOF_NOCONFIRMATION + FOF_NOERRORUI ' (&H8& + &H10& + &H400&)=1048
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.namespace("" & destZip) ' zip file was created previously
k = oFolder.items.Count
' asynchronous process
oFolder.CopyHere ("" & filename), cFlags
On Error Resume Next
Do Until oFolder.items.Count = k + 1
    'Application.Wait (Now + TimeValue("0:00:01")) ' MS-Excel only
    t = Timer
    Do
        DoEvents
    Loop Until (Timer > (t + 1))
    If (Timer - t) > 10 Then
        Debug.Print "Operation timed out."
        Exit Do
    End If
    ' file should be zipped within 10 sec for most files here or it was cancelled
Loop
On Error GoTo 0
addToZip = True
Exit Function
copyErr:
addToZip = False
End Function

Upvotes: 0

Amardeep Singh Randhawa
Amardeep Singh Randhawa

Reputation: 1

Even i need same function, but i need to copy same file in multiple zips

Call fnMoveToZip()

Function fnMoveToZip()
    Dim objShell
    Dim objFolder

    Set objShell = CreateObject("shell.Application")
    Set objFolder = objShell.NameSpace("C:\Users\User\Desktop\NewCompressed.zip")
   'here i need reference which will select the path from column A  
    objFolder.CopyHere("C:\Users\User\Desktop\New_Folder\TestFile.txt")    

    'New code
    Wscript.sleep (5000) 

    Set objShell = nothing
    Set objFolder = nothing

End Function

Upvotes: 0

Stephen Quan
Stephen Quan

Reputation: 26324

In addition to @ansgar-wiechers great answer, I wanted to highlight the fact that both Namespace and CopyHere require absolute path names which you can create with GetAbsolutePathName. Whatever you put in CopyHere will appear at the root level of your ZIP, so, if you wanted a folder structure, you have to pre-prepare a staging folder structure prior to using it. I also recommend having a blank.zip template ZIP file when you want to construct ZIP files from scratch with CopyFile.

Preparing a blank.zip by creating any ZIP file and deleting its contents.

The following example creates a hello.zip archive from a staging folder in your current working directory. It requires that you have the template blank.zip in the current working directory as well.

Option Explicit

Dim fso, shell, dst
Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("shell.Application")

Call fso.CopyFile("blank.zip", "hello.zip")

Set dst = shell.Namespace(fso.GetAbsolutePathName("hello.zip"))
dst.CopyHere(fso.GetAbsolutePathName("staging"))

while dst.Items.count = 0
  WScript.Sleep 100
wend

Upvotes: 0

Ansgar Wiechers
Ansgar Wiechers

Reputation: 200523

As @JosefZ mentioned in the comments to your own answer: the CopyHere method runs asynchronously, i.e. it returns immediately without waiting for the copy operation to complete. Your workaround only works, because you incidentally chose the wait time long enough for the file to be added to the archive. A better approach, however, would be to wait until the file has actually been added:

Set objShell = CreateObject("shell.Application")
Set objFolder = objShell.NameSpace("C:\Users\User\Desktop\NewCompressed.zip")
cnt = objFolder.Items.Count + 1

objFolder.CopyHere("C:\Users\User\Desktop\New_Folder\TestFile.txt")

While objFolder.Items.Count < cnt
    WScript.Sleep 100
Wend

The FileSystemObject approach doesn't work, because the FileSystemObject doesn't know anything about archives. The Copy method would simply (try to) copy the source file over the destination file, not into it.

Upvotes: 2

Edrei
Edrei

Reputation: 11

Figured out a solution to my own question. Before setting my variables to nothing use:

Wscript.sleep (5000)

So it would look like this:

Call fnMoveToZip()

Function fnMoveToZip()
    Dim objShell
    Dim objFolder

    Set objShell = CreateObject("shell.Application")
    Set objFolder = objShell.NameSpace("C:\Users\User\Desktop\NewCompressed.zip")

    objFolder.CopyHere("C:\Users\User\Desktop\New_Folder\TestFile.txt")

    'New code
    Wscript.sleep (5000) 

    Set objShell = nothing
    Set objFolder = nothing
End Function

Upvotes: 0

Related Questions