Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compile Exe
#Dim All
#Debug Error On
#Debug Display On
#Include "win32api.inc"
#Include "winshell.inc"
Function PBMain() As Long
Dim fList(1) As String
fList(0) = "c:\test\arguments.txt" '<--------- use your own --------
fList(1) = "c:\test\unicode.txt" '<--------- use your own --------
CreateZipFileFromList fList(), "c:\test\allfiles.zip" '<--------- use your own --------
End Function
'==================================================
' CreateZipFile - creates a zip file
'==================================================
Function CreateZipFileFromList(fList() As String, ByVal sTo As String) As Long
Local hFile As Dword
'Object Variables
Dim oShellClass As IShellDispatch
Dim oSourceFolder As Folder
Dim oTargetFolder As Folder
Dim oItem As FolderItem
'variants
Dim vSourceFolder As Variant
Dim vTargetFolder As Variant
Dim vOptions As Variant
Dim vFile As Variant
Dim sFile As String
Dim i As Long '-----------new---------------------------
'First we create a empty ZIP file using a standard zip file header
Try
hFile = FreeFile
Open sTo For Output As #hFile
Print #hFile, Chr$(80,75,5,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
Close #hFile
Catch
? "Error creating Zip file: " & sTo & " Error:" & Error$(Err)
Exit Function
End Try
' Get an instance of our Windows Shell
oShellClass = AnyCom $PROGID_SHELL32_SHELL
' Did we get the object? If not, terminate this app
If IsFalse IsObject(oShellClass) Or Err Then
? "Could not get the Windows Shell object. Error:" & Str$(Err)
Exit Function
End If
For i = 0 To UBound(fList) '-----------new----------------------
'assign the source folder we want to zip up
vSourceFolder = RTrim$(PathName$(Path, fList(i)),"\") '--------modified------------
oSourceFolder = oShellClass.NameSpace(vSourceFolder)
If IsFalse IsObject(oSourceFolder) Or Err Then
? "Could not get the Source folder object. Error:" & Str$(Err)
GoTo TerminateZip
End If
'assign the target folder we want to create (in this case it is a zip file)
vTargetFolder = sTo
oTargetFolder = oShellClass.NameSpace(vTargetFolder)
If IsFalse IsObject(oTargetFolder) Or Err Then
? "Could not get the Target folder object. " & sTo & " Error:" & Str$(Err)
GoTo TerminateZip
End If
'get the file name we are copying
'sFile = ucode$(PATHNAME$(NAME, sFrom) & PATHNAME$(EXTN, sFrom))
sFile = PathName$(Namex, fList(i)) '-----------modified for PBWin10 -----
'assign the file item
oItem = oSourceFolder.ParseName(sFile)
If IsFalse IsObject(oItem) Then
? "Could not get the Item object. " & sFile & " Error:" & Str$(Err)
GoTo TerminateZip
End If
'now we start the copy in to the new zip file
vOptions = 20
oTargetFolder.CopyHere(oItem, vOptions)
If Err Then
? "Got an Error during the CopyHere method. Error:" & Str$(Err)
GoTo TerminateZip
End If
Next i '-----------new----------------------
'NOTE: the above copyhere method starts a seperate thread to do the copy
'so the command could return before the copy is finished, so we need to
'allow time to complete. Thus the next Sleep command.
Sleep 6000 'increase for larger folders
'? sTo + " was successfully created."
Function = %TRUE
TerminateZip:
' Close all of the Interfaces
vFile = Empty
vSourceFolder = Empty
vTargetFolder = Empty
vOptions = Empty
oItem = Nothing
oTargetFolder = Nothing
oSourceFolder = Nothing
oShellClass = Nothing
End Function
'gbs_01268
'Date: 05-11-2013
http://www.garybeene.com/sw/gbsnippets.htm