Tweet
'==================================================
' CreateZipFile - creates a zip file
'==================================================
Function CreateZipFile(byval sFrom 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
'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
'assign the source folder we want to zip up
vSourceFolder = rtrim$(PATHNAME$(PATH, sFrom),"\")
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))
'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
'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
If CreateZipFile("C:\Path\MyData.mdb", "C:\Path\MyData.zip") Then
sFile = ucode$(PATHNAME$(NAME, sFrom) & PATHNAME$(EXTN, sFrom))
sFile = PathName$(Namex, sFrom)
' OfflineFolderStatus enumeration %OfflineFolderStatus_OFS_INACTIVE = -1 %OfflineFolderStatus_OFS_ONLINE = 0 %OfflineFolderStatus_OFS_OFFLINE = 1 %OfflineFolderStatus_OFS_SERVERBACK = 2 %OfflineFolderStatus_OFS_DIRTYCACHE = 3
Enum OfflineFolderStatus
OFS_INACTIVE = -1
OFS_ONLINE = 0
OFS_OFFLINE = 1
OFS_SERVERBACK = 2
OFS_DIRTYCACHE = 3
End Enum
#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
vOptions = 20
#IF 0
Optional. Specifies options FOR the COPY operation.
THIS value can be zero OR a combination OF the following values.
These values are based upon flags defined FOR use WITH the fFlags MEMBER OF the C++ SHFILEOPSTRUCT structure.
These flags are NOT defined AS such FOR Microsoft® Visual Basic®, Visual Basic Scripting Edition (VBScript),
OR Microsoft JScript®, so you must define them yourself OR use their NUMERIC equivalents
4 DO NOT DISPLAY a progress DIALOG box.
8 Give the file being operated ON a NEW NAME IN a move, COPY, OR rename operation IF a file WITH the target NAME already exists.
16 Respond WITH "Yes to All" FOR ANY DIALOG BOX that IS displayed.
64 PRESERVE undo information, IF possible.
128 Perform the operation ON files ONLY IF a wildcard file NAME (*.*) IS specified.
256 DISPLAY a progress DIALOG BOX but DO NOT SHOW the file names.
512 DO NOT confirm the creation OF a NEW directory IF the operation requires one TO be created.
1024 DO NOT DISPLAY a USER INTERFACE IF an ERROR occurs.
2048 Version 4.71. DO NOT COPY the security attributes OF the file.
4096 ONLY operate IN the LOCAL directory. Don't operate recursively into subdirectories.
9182 Version 5.0. DO NOT COPY connected files AS a group. ONLY COPY the specified files.
' I think this is a typo in the SDK doc and should be '8192' not "9182"
#ENDIF
ENUM CopyHereOptions
CHO_NOPROGRESS = 4
CHO_RENAMEONDUP = 8
CHO_YESTOALL = 16
CHO_PRESERVEUNDOINFO = 64
CHO_ONLYIFWILDCARD = 128
CHO_NONAMESPROGRESS = 256
CHO_NOCONFIRMNEWDIR = 512
CHO_NOUIONERROR = 1024
CHO_NOCOPYSECURITY = 2048
CHO_NORECURSE = 4096
CHO_NOCOPYCONNECTED = 8192 ' NOTE TYPO CORRECTED HERE
END ENUM
Comment