open a folder; zip files inside

[ankita.sethi]

Hi,
I am trying to create a code that opens a particular folder and zip each file that is inside it. Then I want to copy each of these files to another folder.
Lets say the first folder is C:\Old Folder
And when all the files in this folder are zipped, I want to move it to a folder:
J:\new folder\documents\

I am not familiar with the basics of using external applications in VBA. So any help would be appreciated.

 

[ankita.sethi]

I have found the following code which works fine, except that I do not want to change the names of the files; I want the original file name to be intact.

Sub Zip_All_Files_in_Folder()
Dim FileNameZip, FolderName
Dim strDate As String
Dim oApp As Object
Dim newpath As String
newpath = "C:\Documents and Settings\43581569\Desktop\zip vba"

If Right(newpath, 1) <> "\" Then
newpath = newpath & "\"
End If

FolderName = "C:\Documents and Settings\43581569\Desktop\ankita\" 'folder in which the files are kept

'strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = newpath & "MyFilesZip " & strDate & ".zip"
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = _
oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End Sub



Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub


Any ideas??

 

[Case_Germany]

Hi,

that's the answer:

http://www.rondebruin.nl/7zipwithexcel.htm

 

[ankita.sethi]

Hi,

I did see this code before. However, I cant figure out how to overcome the problem of retaining the original filename. Can you help me with that?

 

[Case_Germany]

Hi,

try it this way, with appropriate modifications to the code and try a few test files:

Option Explicit
Sub Main()
    Dim strFilename As String
    Dim strCopyPath As String
    Dim strZipPath As String
    Dim strZipName As String
    Dim sngTime As Single
    On Error GoTo Fin
    strCopyPath = Environ("UserProfile") & "\Desktop\" & "New\"
    strZipPath = Environ("UserProfile") & "\Desktop\" & "Zip\"
    strCopyPath = IIf(Right$(strCopyPath, 1) = "\", _
        strCopyPath, strCopyPath & "\")
    strZipPath = IIf(Right$(strZipPath, 1) = "\", _
        strZipPath, strZipPath & "\")
    strFilename = Dir$(strZipPath & "*.*")
    Do Until strFilename = vbNullString
        strZipName = Mid(strFilename, 1, _
            InStr(strFilename, ".") - 1) & ".zip"
        Shell "C:\Programme\7-Zip\7z.exe a " & Chr(34) & strZipPath & _
            strZipName & Chr(34) & " " & Chr(34) & strFilename & Chr(34)
        sngTime = Timer
        Do While sngTime + 1 > Timer
            DoEvents
        Loop
        strFilename = Dir$()
    Loop
    Kill strCopyPath & "*.zip"
    CreateObject("Scripting.FileSystemObject").MoveFile _
        strZipPath & "*.zip", strCopyPath
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

 

[ankita.sethi]

Hi,
thanks for your help.
However, this is giving an error saying that path not found. The error is in the following line:

Shell "C:\Programme\7-Zip\7z.exe a " & Chr(34) & strZipPath & _
strZipName & Chr(34) & " " & Chr(34) & strFilename & Chr(34)

Does this use some software 7-zip or something? If yes, then I do not have this. I cannot install something too because of the restrictions in office

Can you please try to modify the code which I gave earlier?That one doesn't use any external software at all.
I hope I am not asking for too much. Thanks a lot in advance :P

 

[Case_Germany]

Hi,

the following code zipping every file in a specified folder:

Option Explicit
Sub Main()
    Dim strCopyPath As String
    Dim varZipName As Variant
    Dim varZipPath As Variant
    Dim objCount As Object
    Dim sngTime As Single
    Dim objApp As Object
    On Error GoTo Fin
    strCopyPath = Environ("UserProfile") & "\Desktop\" & "New\"
    varZipPath = Environ("UserProfile") & "\Desktop\" & "Zip\"
    strCopyPath = IIf(Right$(strCopyPath, 1) = "\", _
        strCopyPath, strCopyPath & "\")
    varZipPath = IIf(Right$(varZipPath, 1) = "\", _
        varZipPath, varZipPath & "\")
    Set objApp = CreateObject("Shell.Application")
    For Each objCount In objApp.Namespace(varZipPath).Items
        varZipName = strCopyPath & Mid(objCount.Name, 1, _
            InStr(objCount.Name, ".") - 1) & ".zip"
        Call NewZip(varZipName)
        objApp.Namespace(varZipName).CopyHere _
            varZipPath & varZipName
        sngTime = Timer
        Do While sngTime + 1 > Timer
            DoEvents
        Loop
    Next objCount
    MsgBox "Ready!"
Fin:
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Sub NewZip(ByVal strPath As String)
    Dim intFile As Integer
    intFile = FreeFile
    If Len(Dir(strPath)) > 0 Then Kill strPath
    Open strPath For Output As #intFile
    Print #intFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #intFile
End Sub

With 7zip also works without any installation, there is also a portable version.