Zip_Folder

Zipping content of folder into file.
Not tested and Not My Work.
Originally from https://www.vbausefulcodes.com.
PS: Image attached for this post was generated by Bing AI on 2023-03-26

CodeFunctionName
What is this?

Public

Not Tested

Imported
Sub Zip_Folder(Folder1, ZipFile) ' #### Needs testing / work to complete
    ' Zip all Files in a Folder Browse
    ' Zip all files in a folder without using any third party software and only using VBA Macros
    ' Needs FixPath, NewZip,
    ' Ready to use VBA Useful Codes! Try Now! http://play.google.com/store/apps/details?id=com.vbausefulcodes.dp https://www.vbausefulcodes.com
    ' ##NOT Tested## '
    Dim FolderName, oFolder
    Dim oApp As Object
    ' Dim FileNameZip, FolderName, oFolder
    ' Dim strDate As String, DefPath As String
    ' DefPath = Application.DefaultFilePath
    ' If Right(DefPath, 1) < > "\" Then DefPath = DefPath & "\"
    ' strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    ' FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
    Set oApp = CreateObject("Shell.Application")
    ' Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
    ' If Not oFolder Is Nothing Then
    ' Create empty Zip File
    Close
    Open ZipFile For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    FolderName = FixPath(Folder1)
    ' If Right(FolderName, 1) < > "\" Then FolderName = FolderName & "\"
    oApp.Namespace(ZipFile).CopyHere oApp.Namespace(FolderName).items ' Copy the files to the compressed folder
    On Error Resume Next
    Do Until oApp.Namespace(ZipFile).items.Count = oApp.Namespace(FolderName).items.Count ' Keep script waiting until Compressing is done
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
    ' MsgBox "You find the zipfile here: " & ZipFile
    ' End If
End Sub

Folder1, ZipFile

Views 122

Downloads 60

CodeID
DB ID