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
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
' 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 93
Downloads 40
CodeID
DB ID
ANmarAmdeen
602
Revisions
v1.0
Wednesday
March
29
2023