Zip/Unzip on Windows Without Dependencies

[adeyblue]

Everybody knows Windows handles zips, but how to create and extract from them using only built-in stuff isn't that well known. Probably because creating them the way you *should* has been broken since they added zip handling. But then MS created a new API in Windows 7 which isn't broken, so you can use that.

Here's a zip/unzip program that uses the OPC interfaces for zipping and the shell interfaces for unzipping. Half the code is the file operation progress information interface, it really doesn't take that much code to do

Code: Select all

#define _WIN32_WINNT &h0600
#define _WIN32_IE &h0800
#define UNICODE 1
#define _UNICODE 1
#include "windows.bi"
#include "win/objbase.bi"
#include "win/shobjidl.bi"
#include "win/shlobj.bi"
#include "win/shellapi.bi"
#include "win/shlwapi.bi"
#include "msopc.bi"
#define DEBUG

#ifdef DEBUG
#macro FATAL_HR(x)
Scope
	dim hr As HRESULT = (x)
	If FAILED(hr) Then
		Print Using __FB_JOIN__(#x, " failed with terminal hresult &"); Hex(hr)
		ExitProcess(hr)
	End If
End Scope
#endmacro

#macro CHECK_HR(x)
Scope
	dim hr As HRESULT = (x)
	If FAILED(hr) Then
		Print Using __FB_JOIN__(#x, " failed with hresult &"); Hex(hr)
	End If
End Scope
#endmacro

#else

#define FATAL_HR(x) x
#define CHECK_HR(x) x

#endif

'' because I really dislike typing ->lpVtbl-> all the freaking time
#define ComCall(pInterface, functionName, args...) pInterface->lpVtbl->functionName(pInterface, args)
#define ComCall0(pInterface, functionName) pInterface->lpVtbl->functionName(pInterface)
#define ComRelease(pInterface) ComCall0(pInterface, Release)

'' smushes together two wstrings
Function AppendWString(ByVal first As Const WString Ptr, ByVal second As Const WString Ptr) As WString Ptr
	dim totalLen As Long = Len(*first) + Len(*second) + 1
	dim newStr As WString Ptr = CAllocate(totalLen * SizeOf(*first))
	*newStr = *first
	*newStr += *second
	Return newStr
End Function

'' Adds one file to an OPC package
Sub CopyFSFileToArchive( _
	byVal pPartSet As IOpcPartSet ptr, _
	Byval pPackageDirPath As Const WString Ptr, _
	byval pFilePath As Const WString Ptr, _
	byval fileSize As ULARGE_INTEGER Ptr, _
	byval pFactory As IOpcFactory Ptr _
)
	'' first we need to create the path of this file in the package
	'' which we're using as pPackageDirPath/pFileName
	'' (/dir/dir2/myfile.txt for example)
	dim pFileName As WString Ptr = PathFindFileName(pFilePath)
	dim itemUri As WString Ptr = AppendWString(pPackageDirPath, pFileName)
	dim pFullPartUri As IOpcPartUri ptr = 0
	dim pNewPart As IOpcPart ptr = 0
	dim As IStream ptr pNewPartData = 0, pLocalFile = 0

	'' create the item uri
	CHECK_HR(ComCall(pFactory, CreatePartUri, itemUri, @pFullPartUri))
	'' then actually create the item (the api will deal with creating any non-existant directories itself)
	''
	'' the n/a is the content-type of the file which must be in MIME format (text/plain, image/jpeg etc)
	'' but since we don't care about that here, set it the same for every file, and n/a is quite apt
	'' OPC_COMPRESSION_NORMAL is the middle compression level
	FATAL_HR(ComCall(pPartSet, CreatePart, pFullPartUri, "n/a", OPC_COMPRESSION_NORMAL, @pNewPart))
	'' Get a stream we can write the to-be-zipped data to
	CHECK_HR(ComCall(pNewPart, GetContentStream, @pNewPartData))
	'' Create a stream we can read the disk file data from
	CHECK_HR(SHCreateStreamOnFile(pFilePath, STGM_READ, @pLocalFile))
	'' copy it
	CHECK_HR(ComCall(pLocalFile, CopyTo, pNewPartData, *fileSize, 0, 0))
	'' all done
	ComRelease(pLocalFile)
	ComRelease(pNewPartData)
	ComRelease(pNewPart)
	ComRelease(pFullPartUri)
	DeAllocate(itemUri)
End Sub

'' adds everything in a directory to an OPC package
'' pFsDir path is the fully qualified path to the directory on disk, must end with a \ - such as C:\mydir\dir2\
'' pPackageDir is the path of this dir in the package, as a relative uri to the root ending with a / - such as /mydir/dir2/
Sub ZipADir( _
	ByVal pFsDirPath As Const WString Ptr, _
	ByVal pPackageDirPath As Const WString Ptr, _
	ByVal pPartSet As IOpcPartSet Ptr, _
	ByVal pFactory As IOpcFactory Ptr _
)
	dim pNextDirStar As WString Ptr = AppendWString(pFsDirPath, "*")
	dim findData As WIN32_FIND_DATA
	'' enum the contents of this directory
	dim hFind As HANDLE = FindFirstFile(pNextDirStar, @findData)
	DeAllocate(pNextDirStar)
	
	Print "Zip: entering dir " & *pPackageDirPath
	If (hFind <> INVALID_HANDLE_VALUE) Then
	
		do
			dim pThisItemName As Const WString Ptr = @findData.cFileName
			If (findData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
			
				If (*pThisItemName <> ".") AndAlso (*pThisItemName <> "..") Then
					'' found a good directory, setup the recursion with the new paths

					'' create fsDirPath\pThisItemName\
					dim stringBuffer As WString*300
					stringBuffer = *pThisItemName
					stringBuffer += "\"
					dim usedBufferLen As Long = Len(stringBuffer)
					dim pNextDirPattern As WString Ptr = AppendWString(pFsDirPath, stringBuffer)
					'' then create pPackagePath/pThisItem/
					Mid(stringBuffer, usedBufferLen, 1) = "/"
					dim pNextPackagePath As WString Ptr = AppendWString(pPackageDirPath, stringBuffer)

					ZipADir(pNextDirPattern, pNextPackagePath, pPartSet, pFactory)

					DeAllocate(pNextDirPattern)
					DeAllocate(pNextPackagePath)
				End If
				
			Else
				'' add this file
				dim pFileSize As ULARGE_INTEGER ptr = cast(ULARGE_INTEGER ptr, @findData.nFileSizeLow)
				dim pThisItemPath As WString Ptr = AppendWString(pFsDirPath, pThisItemName)

				CopyFSFileToArchive(pPartSet, pPackageDirPath, pThisItemPath, pFileSize, pFactory)
				Print Using "Zip: processed file & (& bytes)"; *pThisItemName; pFileSize->QuadPart

				DeAllocate(pThisItemPath)				
			End If
		Loop While (FindNextFile(hFind, @findData) <> FALSE)
		FindClose(hFind)
	End If
	Print "Zip: exiting dir " & *pPackageDirPath
End Sub

'' Zip a file or folder using OPC API
Sub DoZipStuff(ByVal inFile As Const WString Ptr, ByVal outFile As Const WString Ptr, ByVal isADir As Boolean)

	dim pFactory As IOpcFactory Ptr = 0
	dim pPackage As IOpcPackage Ptr = 0
	dim pPartSet As IOpcPartSet Ptr = 0

	'' Create the main OPC intefaces
	FATAL_HR(CoCreateInstance(@CLSID_OpcFactory, 0, CLSCTX_INPROC, @IID_IOpcFactory, @pFactory))
	'' create a new empty package
	FATAL_HR(ComCall(pFactory, CreatePackage, @pPackage))
	'' and the interface that'll let us add things to it
	CHECK_HR(ComCall(pPackage, GetPartSet, @pPartSet))
	
	If isADir Then

		dim inFileLen As Long = Len(*inFile)
		dim inFileToUse As Const WString Ptr = inFile
		If inFile[inFileLen - 1] <> WChr(&h2f) Then
			inFileToUse = AppendWString(inFile, "\")
		End If
		ZipADir(inFileToUse, "/", pPartSet, pFactory)
		If inFile <> inFileToUse Then DeAllocate(inFileToUse)
		
	Else

		'' get the file size
		dim fileData As WIN32_FILE_ATTRIBUTE_DATA
		GetFileAttributesEx(inFile, GetFileExInfoStandard, @fileData)
		dim pFileSize As ULARGE_INTEGER Ptr = cast(ULARGE_INTEGER Ptr, @fileData.nFileSizeLow)
		'' add it to the archive
		CopyFSFileToArchive(pPartSet, "/", inFile, pFileSize, pFactory)
		
	End If

	'' Now we've added all the files, create the zip file
	'' and use the factory to write the contents to it
	dim pNewZipFile As IStream Ptr = 0
	CHECK_HR(SHCreateStreamOnFile(outFile, STGM_CREATE Or STGM_WRITE, @pNewZipFile))
	CHECK_HR(ComCall(pFactory, WritePackageToStream, pPackage, OPC_WRITE_DEFAULT, pNewZipFile))
	ComRelease(pNewZipFile)
	ComRelease(pPartSet)
	ComRelease(pPackage)
	ComRelease(pFactory)
End Sub

'' implements IFileOperationProgressSink
'' This is the bulk of the code
type FileOpProgress extends object
Private:
	dim pMalloc As IMalloc ptr
	dim pOperation As Const WString Ptr
Public:
	Declare Virtual Function QueryInterface(byval riid As REFIID, byval ppv as Any ptr ptr) As HRESULT
	Declare Virtual Function AddRef() As ULong
	Declare Virtual Function Release() As ULong
	Declare Virtual Function StartOperations() As HRESULT
	Declare Virtual Function FinishOperations(byval result As HRESULT) As HRESULT
	Declare Virtual Function PreRenameItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	Declare Virtual Function PostRenameItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	Declare Virtual Function PreMoveItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	Declare Virtual Function PostMoveItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	Declare Virtual Function PreCopyItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	Declare Virtual Function PostCopyItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	Declare Virtual Function PreDeleteItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr) as HRESULT
	Declare Virtual Function PostDeleteItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	Declare Virtual Function PreNewItem(byVal dwFlags As ULong, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	Declare Virtual Function PostNewItem(byVal dwFlags As ULong, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr, byval pszTemplateName As WString Ptr, byval attributes as Ulong, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	Declare Virtual Function UpdateProgress(byval worktotal As ULong, byval workSoFar as ULong) as HRESULT
	Declare Virtual Function ResetTimer() As HRESULT
	Declare Virtual Function PauseTimer() As HRESULT
	Declare Virtual Function ResumeTimer() As HRESULT
	Declare Constructor(byval operation As Const WString Ptr)
	Declare Destructor()
end type

Constructor FileOpProgress(byval operation As Const WString Ptr)
	CoGetMalloc(1, @pMalloc)
	pOperation = operation
End Constructor

Destructor FileOpProgress()
	ComRelease(pMalloc)
End Destructor

Function FileOpProgress.QueryInterface(byval riid As REFIID, byval ppv as Any ptr ptr) As HRESULT
	dim good As Boolean = False

	If IsEqualIID(riid, @IID_IFileOperationProgressSink) OrElse IsEqualIID(riid, @IID_IUnknown) Then

		*ppv = @This
		AddRef()
		good = True
#ifdef DEBUG
	Else

		dim clsidText as WString*50
		StringFromGUID2(riid, @clsidText, 50)
		Print Using "&: got request for unknown interface &"; *pOperation; clsidText
#endif
	End If
	Return IIf(good, S_OK, E_NOINTERFACE)
End Function

'' This object is only stack based so AddRef and Release don't have to do anything
'' If you adapt this so it's dynamically allocated, you'll need to make these work properly
Function FileOpProgress.AddRef() As ULong
	Return 1
End Function

Function FileOpProgress.Release() As ULong
	Return 1
End Function

Function FileOpProgress.StartOperations() As HRESULT
	Print *pOperation & ": Starting operation"
	Return S_OK
End Function

Function FileOpProgress.FinishOperations(byval result As HRESULT) As HRESULT
	Print *pOperation & ": Finished";
	If FAILED(result) Then
		Print " with error " & Hex(result)
	End If
	Print
	Return S_OK
End Function

Function FileOpProgress.PreRenameItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: About to rename & to &, flags &"; *pOperation; *pItemName; *pszNewName; Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.PostRenameItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: Rename of & to & with flags & reutrned &"; *pOperation; *pItemName; *pszNewName; Hex(dwFlags); Hex(result)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.PreMoveItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	dim pDestFolder As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pDestFolder))
	Print Using "&: About to move & to &_\&, flags &"; *pOperation; *pItemName; *pDestFolder; *pszNewName; Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	ComCall(pMalloc, Free, pDestFolder)
	Return S_OK
End Function

Function FileOpProgress.PostMoveItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	dim pDestFolder As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pDestFolder))
	Print Using "&: Move of & to &_\& returned &, flags &"; *pOperation; *pItemName; *pDestFolder; *pszNewName; Hex(result); Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	ComCall(pMalloc, Free, pDestFolder)
	Return S_OK
End Function

Function FileOpProgress.PreCopyItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	dim pDestFolder As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pDestFolder))
	Print Using "&: About to copy & to &_\&, flags &"; *pOperation; *pItemName; *pDestFolder; *pszNewName; Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	ComCall(pMalloc, Free, pDestFolder)
	Return S_OK
End Function

Function FileOpProgress.PostCopyItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	dim pDestFolder As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pDestFolder))
	Print Using "&: Copy of & to &_\& returned &, flags &"; *pOperation; *pItemName; *pDestFolder; *pszNewName; Hex(result); Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	ComCall(pMalloc, Free, pDestFolder)
	Return S_OK
End Function

Function FileOpProgress.PreDeleteItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: About to delete &, flags &"; *pOperation; *pItemName; Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.PostDeleteItem(byVal dwFlags As ULong, byval psiItem As IShellItem ptr, byval result as HRESULT, byval psiNew As IShellItem ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiItem, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: Deletion of & returned &, flags &"; *pOperation; *pItemName; Hex(result); Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.PreNewItem(byVal dwFlags As ULong, byval psiDestinationFolder As IShellItem ptr, byval pszNewName As WString Ptr) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: Creating new item &_\&, flags &"; *pOperation; *pItemName; *pszNewName; Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.PostNewItem( _
	byVal dwFlags As ULong, _
	byval psiDestinationFolder As IShellItem ptr, _
	byval pszNewName As WString Ptr, _
	byval pszTemplateName As WString Ptr, _
	byval attributes as Ulong, _
	byval result as HRESULT, _
	byval psiNew As IShellItem ptr _
) as HRESULT
	dim pItemName As WString Ptr = 0
	CHECK_HR(ComCall(psiDestinationFolder, GetDisplayName, SIGDN_NORMALDISPLAY, @pItemName))
	Print Using "&: Creation of new item at &_\& returned &, attributes &, flags &"; *pOperation; *pItemName; *pszNewName; Hex(result); Hex(attributes); Hex(dwFlags)
	ComCall(pMalloc, Free, pItemName)
	Return S_OK
End Function

Function FileOpProgress.UpdateProgress(byval worktotal As ULong, byval workSoFar as ULong) as HRESULT
	Print Using "&: Progress update - &/&"; *pOperation; workSoFar; workTotal
	Return S_OK
End Function

Function FileOpProgress.ResetTimer() as HRESULT
	Print *pOperation & ": ResetTimer!"
	Return S_OK
End Function

Function FileOpProgress.PauseTimer() as HRESULT
	Print *pOperation & ": PauseTimer!"
	Return S_OK
End Function

Function FileOpProgress.ResumeTimer() As HRESULT
	Print *pOperation & ": ResumeTimer!"
	Return S_OK
End Function

'' implements IFileSystemBindData
'' This'll let us tell Windows we want it to create a directory instead of a file, as is default
Type FolderFileSysData extends Object
Public:
	Declare Virtual Function QueryInterface(byval riid As REFIID, byval ppv as Any ptr ptr) As HRESULT
	Declare Virtual Function AddRef() As ULong
	Declare Virtual Function Release() As ULong

	Declare Virtual Function SetFindData(byval pWfd As WIN32_FIND_DATA ptr) as HRESULT
	Declare Virtual Function GetFindData(byval pWfd As WIN32_FIND_DATA ptr) as HRESULT
End Type

Function FolderFileSysData.QueryInterface(byval riid As REFIID, byval ppv as Any ptr ptr) As HRESULT
	dim good As Boolean = False

	If IsEqualIID(riid, @IID_IFileSystemBindData) OrElse IsEqualIID(riid, @IID_IUnknown) Then

		*ppv = @This
		AddRef()
		good = True
#ifdef DEBUG
	Else

		dim clsidText as WString*50
		StringFromGUID2(riid, @clsidText, 50)
		Print "FolderFileSysData: got request for unknown interface " & clsidText
#endif
	End If
	Return IIf(good, S_OK, E_NOINTERFACE)
End Function

'' This object is only stack based so AddRef and Release don't have to do anything
'' If you adapt this so it's dynamically allocated, you'll need to make these work properly
Function FolderFileSysData.AddRef() As ULong
	Return 1
End Function

Function FolderFileSysData.Release() As ULong
	Return 1
End Function

Function FolderFileSysData.SetFindData(byval pWfd As WIN32_FIND_DATA ptr) as HRESULT
	Return S_OK
End Function

Function FolderFileSysData.GetFindData(byval pWfd As WIN32_FIND_DATA ptr) as HRESULT
'' This whole object exists for this
	dim findData As WIN32_FIND_DATA
	findData.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY
	*pwfd = findData
	Return S_OK
End Function

'' Creates a bind context that will, well, create things
Function CreateACreateBindContext() As IBindCtx Ptr

	dim pCtx As IBindCtx Ptr = 0
	CHECK_HR(CreateBindCtx(0, @pCtx))
	If pCtx <> 0 Then
		dim bo As BIND_OPTS
		bo.cbStruct = SizeOf(bo)
		bo.grfMode = STGM_CREATE Or STGM_WRITE
		CHECK_HR(ComCall(pCtx, SetBindOptions, @bo))
	End If
	Return pCtx
End Function

'' Extracting from a zip with IShellItem and IFileOperation
''
'' Except there's nothing zip-specific here, so this'll also do 
'' generic folder copying, or extracting/copying from anything
'' you can click into in Explorer like cab files etc, probably
Sub DoUnzipStuff(ByVal zipFilePath As Const WString Ptr, ByVal outDirPath As Const WString Ptr)

	dim pZipFile As IShellItem Ptr = 0
	dim pDestDir As IShellItem Ptr = 0
	dim pContentTypeFile As IShellItem Ptr = 0
	dim pZipFileContents As IEnumShellItems ptr = 0
	dim pFileOperation As IFileOperation ptr = 0
	dim cookie As ULong

	'' The next three things are only needed to be able to
	'' get a shell item for something that doesn't exist (the output directory may not)
	'' Of course, we could (SH)CreateDirectory first then we wouldn't need this
	'' but since we're doing things the shell way, when in Rome...
	''
	'' without the bind context, outDirPath would have to already exist
	dim pCreateCtx As IBindCtx ptr = CreateACreateBindContext()
	'' and without these, Windows would create a file, not a directory
	dim folderBindInfo As FolderFileSysData
	dim tempPtr As Any Ptr = @folderBindInfo
	CHECK_HR(ComCall(pCreateCtx, RegisterObjectParam, STR_FILE_SYS_BIND_DATA, tempPtr))

	'' Get an interface so we can get the things in the zip
	FATAL_HR(SHCreateItemFromParsingName(zipFilePath, 0, @IID_IShellItem, @pZipFile))
	'' And one that can create files and folders on disk
	FATAL_HR(SHCreateItemFromParsingName(outDirPath, pCreateCtx, @IID_IShellItem, @pDestDir))

	'' Turn off 'folder mode' in the bind context so we can reuse it for a file
	CHECK_HR(ComCall(pCreateCtx, RevokeObjectParam, STR_FILE_SYS_BIND_DATA))
	'' Zips created with OPC contain a [Content_Type].xml file along with everything you want in them
	'' so we get an interface to the currently non-existant file in the maybe non-existant directory, so we can delete it.
	'' Isn't that fun :-)
	CHECK_HR(SHCreateItemFromRelativeName(pDestDir, "[Content_Types].xml", pCreateCtx, @IID_IShellItem, @pContentTypeFile))

	'' Create the object that'll actually do the copying
	FATAL_HR(CoCreateInstance(@CLSID_FileOperation, NULL, CLSCTX_INPROC, @IID_IFileOperation, @pFileOperation))

	'' if you don't want extraction progress updates, you can delete the FileOpProgress
	'' type and everything that uses it. That'll easily remove half the code in this file
	dim progress As FileOpProgress = ("Unzip")

	'' FB won't let you cast from an 'extends object' ptr type to IUnknown ptr
	'' so we need this Any Ptr as a temporary in between. And without it will
	'' produce a warning
	tempPtr = @progress 
	CHECK_HR(ComCall(pFileOperation, Advise, tempPtr, @cookie))
	'' Get the list of contents in the zip file
	CHECK_HR(ComCall(pZipFile, BindToHandler, 0, @BHID_EnumItems, @IID_IEnumShellItems, @pZipFileContents))
	'' setup the copy
	CHECK_HR(ComCall(pFileOperation, CopyItems, cast(IUnknown Ptr, pZipFileContents), pDestDir))
	'' and the delete on the unwanted file
	CHECK_HR(ComCall(pFileOperation, DeleteItem, pContentTypeFile, 0))

	'' don't want any UI
	ComCall(pFileOperation, SetOperationFlags, FOF_NO_UI)
	'' tell it to do the extraction, and we're done!
	CHECK_HR(ComCall0(pFileOperation, PerformOperations))

	ComRelease(pContentTypeFile)
	ComRelease(pZipFile)
	ComRelease(pDestDir)
	ComRelease(pFileOperation)
	ComRelease(pZipFileContents)
	ComRelease(pCreateCtx)
End Sub

'' Make any relative paths absolute
Function FullyQualifyFileName(ByVal pFileName As WString Ptr) As WString Ptr

	dim pFullPath As WString Ptr
	if PathIsRelative(pFileName) Then
	
		dim req As ULong = GetFullPathName(pFileName, 0, NULL, NULL)
		pFullPath = CAllocate(req * SizeOf(*pFullPath))
		req = GetFullPathName(pFileName, req, pFullPath, NULL)
	Else
		pFullPath = pFileName
	End If
	Return pFullPath
End Function

Sub MainSub()

	dim attributes As ULong
	dim numArgs As Long
	dim args As WString Ptr Ptr = CommandLineToArgvW(GetCommandLine(), @numArgs)
	
	If (numArgs < 3) Then
printUsage:
		Print "Usage: ZipAThing C:\path\to\thing output.zip Or"
		Print "Usage: ZipAThing C:\path\to\thing.zip outputDir unzip"
		Print "The 'thing' may be a single file or a folder. If a folder, everything inside"
		Print "it will be added to the zip"
		Print
		Print "If 'unzip' exists, contents of the zip will be extracted to 'outputDir' which will"
		Print "be created as a directory"
		LocalFree(args)
		End 1
		
	End If
	'' apparently FB can't both assign and test for equality in an if, so we'll do it here
	attributes = GetFileAttributes(args[1])
	If attributes = INVALID_FILE_ATTRIBUTES Then Goto printUsage

	FATAL_HR(CoInitializeEx(NULL, COINIT_APARTMENTTHREADED Or COINIT_DISABLE_OLE1DDE))

	dim inputThing As WString Ptr = FullyQualifyFileName(args[1])
	dim outputThing As WString Ptr = FullyQualifyFileName(args[2])

	If numArgs < 4 Then
	
		Print Using "Zipping from & to &"; *inputThing; *outputThing
		DoZipStuff(inputThing, outputThing, attributes And FILE_ATTRIBUTE_DIRECTORY)
		
	Else
		Print Using "Unzipping & to &"; *inputThing; *outputThing
		DoUnZipStuff(inputThing, outputThing)
		
	End If

	If inputThing <> args[1] Then
		DeAllocate(inputThing)
	End If
	If outputThing <> args[2] Then
		DeAllocate(outputThing)
	End If

	LocalFree(args)
	
	CoUninitialize()
End Sub

MainSub()

You'll also need this
MsOPC.bi

Code: Select all

#if _WIN32_WINNT <= &h0501
#error "Opc is only available on Win7+"
#endif

#include "win/urlmon.bi" '' for IUri
#include "win/objidl.bi" '' for IStream

'' CLSID_OpcFactory - 6B2D6BA0-9F3E-4f27-920B-313CC426A39E
dim Shared CLSID_OpcFactory as const GUID = (&h6B2D6BA0, &h9f3e, &h4f27, {&h92, &h0b, &h31, &h3c, &hc4, &h26, &ha3, &h9e})

'' IID - 7d3babe7-88b2-46ba-85cb-4203cb016c87
dim Shared IID_IOpcPartUri as const IID = (&h7d3babe7, &h88b2, &h46ba, {&h85, &hcb, &h42, &h03, &hcb, &h01, &h6c, &h87})
type IOpcPartUri As IOpcPartUri_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE71
dim Shared IID_IOpcPart as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h71})
type IOpcPart As IOpcPart_

'' IID - bc9c1b9b-d62c-49eb-aef0-3b4e0b28ebed
dim Shared IID_IOpcUri as const IID = (&hbc9c1b9b, &hd62c, &h49eb, {&hae, &hf0, &h3b, &h4e, &h0b, &h28, &heb, &hed})
type IOpcUri As IOpcUri_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE73
dim Shared IID_IOpcPartSet as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h73})
type IOpcPartSet As IOpcPartSet_

'' IID - 6d0b4446-cd73-4ab3-94f4-8ccdf6116154
dim Shared IID_IOpcFactory as const IID = (&h6d0b4446, &hcd73, &h4ab3, {&h94, &hf4, &h8c, &hcd, &hf6, &h11, &h61, &h54})
type IOpcFactory as IOpcFactory_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE70
dim Shared IID_IOpcPackage as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h70})
type IOpcPackage As IOpcPackage_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE75
dim Shared IID_IOpcPartEnumerator as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h75})
type IOpcPartEnumerator As IOpcPartEnumerator_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE74
dim Shared IID_IOpcRelationshipSet as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h74})
type IOpcRelationshipSet as IOpcRelationshipSet_

'' IID - 6e34c269-a4d3-47c0-b5c4-87ff2b3b6136
dim Shared IID_IOpcRelationshipSelectorSet as const IID = (&h6e34c269, &ha4d3, &h47c0, {&hb5, &hc4, &h87, &hff, &h2b, &h3b, &h61, &h36})
type IOpcRelationshipSelectorSet As IOpcRelationshipSelectorSet_

'' IID - f8f26c7f-b28f-4899-84c8-5d5639ede75f
dim Shared IID_IOpcRelationshipSelector as const IID = (&hf8f26c7f, &hb28f, &h4899, {&h84, &hc8, &h5d, &h56, &h39, &h3d, &he7, &h5f})
type IOpcRelationshipSelector As IOpcRelationshipSelector_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE76
dim Shared IID_IOpcRelationshipEnumerator as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h76})
type IOpcRelationshipEnumerator as IOpcRelationshipEnumerator_

'' IID - 5e50a181-a91b-48ac-88d2-bca3d8f8c0b1
dim Shared IID_IOpcRelationshipSelectorEnumerator as const IID = (&h5e50a181, &ha91b, &h48ac, {&h88, &hd2, &hbc, &ha3, &hd8, &hf8, &hc0, &hb1})
type IOpcRelationshipSelectorEnumerator as IOpcRelationshipSelectorEnumerator_

'' IID - 42195949-3B79-4fc8-89C6-FC7FB979EE72
dim Shared IID_IOpcRelationship as const IID = (&h42195949, &h3b79, &h4fc8, {&h89, &hc6, &hfc, &h7f, &hb9, &h79, &hee, &h72})
type IOpcRelationship as IOpcRelationship_

'' none of the digital signature or signing interfaces are described
'' but this is an out parameter on one of the documented interfaces
'' so define it like this so it will compile
extern IID_IOpcDigitalSignatureManager as const GUID
type IOpcDigitalSignatureManager as IUnknown

enum OPC_COMPRESSION_OPTIONS
	OPC_COMPRESSION_NONE		= -1
	OPC_COMPRESSION_NORMAL		= 0
	OPC_COMPRESSION_MAXIMUM		= 1
	OPC_COMPRESSION_FAST		= 2
	OPC_COMPRESSION_SUPERFAST	= 3
end enum

enum OPC_STREAM_IO_MODE
	OPC_STREAM_IO_READ	= 1
	OPC_STREAM_IO_WRITE	= 2
end enum

enum OPC_READ_FLAGS
	OPC_READ_DEFAULT		= 0
	OPC_VALIDATE_ON_LOAD	= 1
	OPC_CACHE_ON_ACCESS		= 2
end enum

enum OPC_WRITE_FLAGS
	OPC_WRITE_DEFAULT		= 0
	OPC_WRITE_FORCE_ZIP32	= 1
end enum

enum OPC_RELATIONSHIP_SELECTOR
	OPC_RELATIONSHIP_SELECT_BY_ID	= 0
	OPC_RELATIONSHIP_SELECT_BY_TYPE	= 1
end enum

enum OPC_URI_TARGET_MODE
	OPC_URI_TARGET_MODE_INTERNAL	= 0
	OPC_URI_TARGET_MODE_EXTERNAL	= 1
end enum

type IOpcUriVtbl field = 1
	QueryInterface as function(byval This as IOpcUri ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcUri ptr) as ULONG
	Release as function(byval This as IOpcUri ptr) as ULONG
	GetPropertyBSTR as function(byval This as IOpcUri ptr, byval uriProp as Uri_PROPERTY, byval pbstrProperty as BSTR ptr, byval dwFlags as DWORD) as HRESULT
	GetPropertyLength as function(byval This as IOpcUri ptr, byval uriProp as Uri_PROPERTY, byval pcchProperty as DWORD ptr, byval dwFlags as DWORD) as HRESULT
	GetPropertyDWORD as function(byval This as IOpcUri ptr, byval uriProp as Uri_PROPERTY, byval pdwProperty as DWORD ptr, byval dwFlags as DWORD) as HRESULT
	HasProperty as function(byval This as IOpcUri ptr, byval uriProp as Uri_PROPERTY, byval pfHasProperty as WINBOOL ptr) as HRESULT
	GetAbsoluteUri as function(byval This as IOpcUri ptr, byval pbstrAbsoluteUri as BSTR ptr) as HRESULT
	GetAuthority as function(byval This as IOpcUri ptr, byval pbstrAuthority as BSTR ptr) as HRESULT
	GetDisplayUri as function(byval This as IOpcUri ptr, byval pbstrDisplayString as BSTR ptr) as HRESULT
	GetDomain as function(byval This as IOpcUri ptr, byval pbstrDomain as BSTR ptr) as HRESULT
	GetExtension as function(byval This as IOpcUri ptr, byval pbstrExtension as BSTR ptr) as HRESULT
	GetFragment as function(byval This as IOpcUri ptr, byval pbstrFragment as BSTR ptr) as HRESULT
	GetHost as function(byval This as IOpcUri ptr, byval pbstrHost as BSTR ptr) as HRESULT
	GetPassword as function(byval This as IOpcUri ptr, byval pbstrPassword as BSTR ptr) as HRESULT
	GetPath as function(byval This as IOpcUri ptr, byval pbstrPath as BSTR ptr) as HRESULT
	GetPathAndQuery as function(byval This as IOpcUri ptr, byval pbstrPathAndQuery as BSTR ptr) as HRESULT
	GetQuery as function(byval This as IOpcUri ptr, byval pbstrQuery as BSTR ptr) as HRESULT
	GetRawUri as function(byval This as IOpcUri ptr, byval pbstrRawUri as BSTR ptr) as HRESULT
	GetSchemeName as function(byval This as IOpcUri ptr, byval pbstrSchemeName as BSTR ptr) as HRESULT
	GetUserInfo as function(byval This as IOpcUri ptr, byval pbstrUserInfo as BSTR ptr) as HRESULT

	#if defined(UNICODE) and (_WIN32_WINNT >= &h0600)
		GetUserNameW as function(byval This as IOpcUri ptr, byval pbstrUserName as BSTR ptr) as HRESULT
	#elseif (not defined(UNICODE)) and (_WIN32_WINNT >= &h0600)
		GetUserNameA as function(byval This as IOpcUri ptr, byval pbstrUserName as BSTR ptr) as HRESULT
	#endif

	GetHostType as function(byval This as IOpcUri ptr, byval pdwHostType as DWORD ptr) as HRESULT
	GetPort as function(byval This as IOpcUri ptr, byval pdwPort as DWORD ptr) as HRESULT
	GetScheme as function(byval This as IOpcUri ptr, byval pdwScheme as DWORD ptr) as HRESULT
	GetZone as function(byval This as IOpcUri ptr, byval pdwZone as DWORD ptr) as HRESULT
	GetProperties as function(byval This as IOpcUri ptr, byval pdwFlags as LPDWORD) as HRESULT
	IsEqual as function(byval This as IOpcUri ptr, byval pUri as IUri ptr, byval pfEqual as WINBOOL ptr) as HRESULT
	GetRelationshipsPartUri as function(byval This as IOpcUri ptr, byval relationshipPartUri As IOpcPartUri Ptr Ptr) as HRESULT
	GetRelativeUri as function(byval This as IOpcUri ptr, byval targetPartUri As IOpcPartUri Ptr, byval relativeUri As IUri Ptr Ptr) as HRESULT
	CombinePartUri as function(byval This as IOpcUri ptr, byval relativeUri as IUri Ptr, byval combinedUri as IOpcPartUri Ptr Ptr) as HRESULT
end type

type IOpcUri_
	lpVtbl as IOpcUriVtbl ptr
end type

type IOpcPartUriVtbl field = 1
	QueryInterface as function(byval This as IOpcPartUri ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcPartUri ptr) as ULONG
	Release as function(byval This as IOpcPartUri ptr) as ULONG
	GetPropertyBSTR as function(byval This as IOpcPartUri ptr, byval uriProp as Uri_PROPERTY, byval pbstrProperty as BSTR ptr, byval dwFlags as DWORD) as HRESULT
	GetPropertyLength as function(byval This as IOpcPartUri ptr, byval uriProp as Uri_PROPERTY, byval pcchProperty as DWORD ptr, byval dwFlags as DWORD) as HRESULT
	GetPropertyDWORD as function(byval This as IOpcPartUri ptr, byval uriProp as Uri_PROPERTY, byval pdwProperty as DWORD ptr, byval dwFlags as DWORD) as HRESULT
	HasProperty as function(byval This as IOpcPartUri ptr, byval uriProp as Uri_PROPERTY, byval pfHasProperty as WINBOOL ptr) as HRESULT
	GetAbsoluteUri as function(byval This as IOpcPartUri ptr, byval pbstrAbsoluteUri as BSTR ptr) as HRESULT
	GetAuthority as function(byval This as IOpcPartUri ptr, byval pbstrAuthority as BSTR ptr) as HRESULT
	GetDisplayUri as function(byval This as IOpcPartUri ptr, byval pbstrDisplayString as BSTR ptr) as HRESULT
	GetDomain as function(byval This as IOpcPartUri ptr, byval pbstrDomain as BSTR ptr) as HRESULT
	GetExtension as function(byval This as IOpcPartUri ptr, byval pbstrExtension as BSTR ptr) as HRESULT
	GetFragment as function(byval This as IOpcPartUri ptr, byval pbstrFragment as BSTR ptr) as HRESULT
	GetHost as function(byval This as IOpcPartUri ptr, byval pbstrHost as BSTR ptr) as HRESULT
	GetPassword as function(byval This as IOpcPartUri ptr, byval pbstrPassword as BSTR ptr) as HRESULT
	GetPath as function(byval This as IOpcPartUri ptr, byval pbstrPath as BSTR ptr) as HRESULT
	GetPathAndQuery as function(byval This as IOpcPartUri ptr, byval pbstrPathAndQuery as BSTR ptr) as HRESULT
	GetQuery as function(byval This as IOpcPartUri ptr, byval pbstrQuery as BSTR ptr) as HRESULT
	GetRawUri as function(byval This as IOpcPartUri ptr, byval pbstrRawUri as BSTR ptr) as HRESULT
	GetSchemeName as function(byval This as IOpcPartUri ptr, byval pbstrSchemeName as BSTR ptr) as HRESULT
	GetUserInfo as function(byval This as IOpcPartUri ptr, byval pbstrUserInfo as BSTR ptr) as HRESULT

	#if defined(UNICODE) and (_WIN32_WINNT >= &h0600)
		GetUserNameW as function(byval This as IOpcPartUri ptr, byval pbstrUserName as BSTR ptr) as HRESULT
	#elseif (not defined(UNICODE)) and (_WIN32_WINNT >= &h0600)
		GetUserNameA as function(byval This as IOpcPartUri ptr, byval pbstrUserName as BSTR ptr) as HRESULT
	#endif

	GetHostType as function(byval This as IOpcPartUri ptr, byval pdwHostType as DWORD ptr) as HRESULT
	GetPort as function(byval This as IOpcPartUri ptr, byval pdwPort as DWORD ptr) as HRESULT
	GetScheme as function(byval This as IOpcPartUri ptr, byval pdwScheme as DWORD ptr) as HRESULT
	GetZone as function(byval This as IOpcPartUri ptr, byval pdwZone as DWORD ptr) as HRESULT
	GetProperties as function(byval This as IOpcPartUri ptr, byval pdwFlags as LPDWORD) as HRESULT
	IsEqual as function(byval This as IOpcPartUri ptr, byval pUri as IUri ptr, byval pfEqual as WINBOOL ptr) as HRESULT
	GetRelationshipsPartUri as function(byval This as IOpcPartUri ptr, byval relationshipPartUri As IOpcPartUri Ptr Ptr) as HRESULT
	GetRelativeUri as function(byval This as IOpcPartUri ptr, byval targetPartUri As IOpcPartUri Ptr, byval relativeUri As IUri Ptr Ptr) as HRESULT
	CombinePartUri as function(byval This as IOpcPartUri ptr, byval relativeUri as IUri Ptr, byval combinedUri as IOpcPartUri Ptr Ptr) as HRESULT
	ComparePartUri as function(byval This as IOpcPartUri ptr, byval partUri as IOpcPartUri Ptr, byval comparisonResult as Long Ptr) as HRESULT
	GetSourceUri as function(byval This as IOpcPartUri ptr, byval sourceUri as IOpcUri ptr ptr) as HRESULT
	IsRelationshipsPartUri as function(byval This as IOpcPartUri ptr, byval isRelationshipUri as WINBOOL ptr) as HRESULT
end type

type IOpcPartUri_
	lpVtbl as IOpcPartUriVtbl ptr
end type

type IOpcFactoryVtbl field = 1
	QueryInterface as function(byval This as IOpcFactory ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcFactory ptr) as ULONG
	Release as function(byval This as IOpcFactory ptr) as ULONG
	CreatePackageRootUri as function(byval This as IOpcFactory ptr, byval rootUri as IOpcUri ptr ptr) as HRESULT
	CreatePartUri as function(byval This as IOpcFactory ptr, byval pwzUri as LPCWSTR, byval partUri as IOpcPartUri ptr ptr) as HRESULT
	CreateStreamOnFile as function(byval This as IOpcFactory ptr, byval filename as LPCWSTR, byval ioMode as OPC_STREAM_IO_MODE, byval securityAttributes as LPSECURITY_ATTRIBUTES, byval dwFlagsAndAttributes as DWORD, byval stream as IStream ptr ptr) as HRESULT
	CreatePackage as function(byval This as IOpcFactory ptr, byval package as IOpcPackage ptr ptr) as HRESULT
	ReadPackageFromStream as function(byval This as IOpcFactory ptr, byval stream as IStream ptr, byval flags as OPC_READ_FLAGS, byval package as IOpcPackage ptr ptr) as HRESULT
	WritePackageToStream as function(byval This as IOpcFactory ptr, byval package as IOpcPackage ptr, byval flags as OPC_READ_FLAGS, byval stream as IStream ptr) as HRESULT
	CreateDigitalSignatureManager as function(byval This as IOpcFactory ptr, byval package as IOpcPackage ptr, byval signatureManager as IOpcDigitalSignatureManager) as HRESULT
end type

type IOpcFactory_
	lpVtbl as IOpcFactoryVtbl ptr
end type

type IOpcPackageVtbl field = 1
	QueryInterface as function(byval This as IOpcPackage ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcPackage ptr) as ULONG
	Release as function(byval This as IOpcPackage ptr) as ULONG
	GetPartSet as function(byval This as IOpcPackage ptr, byval partSet as IOpcPartSet ptr ptr) as HRESULT
	GetRelationshipSet as function(byval This as IOpcPackage ptr, byval relationshipSet as IOpcRelationshipSet ptr ptr) as HRESULT
end type

type IOpcPackage_
	lpVtbl as IOpcPackageVtbl ptr
end type

type IOpcPartSetVtbl field = 1
	QueryInterface as function(byval This as IOpcPartSet ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcPartSet ptr) as ULONG
	Release as function(byval This as IOpcPartSet ptr) as ULONG
	GetPart as function(byval This as IOpcPartSet ptr, byval name_ as IOpcPartUri ptr, byval part as IOpcPart ptr ptr) as HRESULT
	CreatePart as function(byval This as IOpcPartSet ptr, byval name_ as IOpcPartUri ptr, byval contentType as LPCWSTR, byval compressionOptions as OPC_COMPRESSION_OPTIONS, byval part as IOpcPart ptr ptr) as HRESULT
	DeletePart as function(byval This as IOpcPartSet ptr, byval name_ as IOpcPartUri ptr) as HRESULT
	PartExists as function(byval This as IOpcPartSet ptr, byval name_ as IOpcPartUri ptr, byval partExists as WINBOOL ptr) as HRESULT
	GetEnumerator as function(byval This as IOpcPartSet ptr, byval partEnumerator as IOpcPartEnumerator ptr ptr) as HRESULT
end type

type IOpcPartSet_
	lpVtbl as IOpcPartSetVtbl ptr
end type

type IOpcPartEnumeratorVtbl field = 1
	QueryInterface as function(byval This as IOpcPartEnumerator ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcPartEnumerator ptr) as ULONG
	Release as function(byval This as IOpcPartEnumerator ptr) as ULONG
	MoveNext as function(byval This as IOpcPartEnumerator ptr, byval hasNext as WINBOOL ptr) as HRESULT
	MovePrevious as function(byval This as IOpcPartEnumerator ptr, byval hasPrevious as WINBOOL ptr) as HRESULT
	GetCurrent as function(byval This as IOpcPartEnumerator ptr, byval part as IOpcPart ptr ptr) as HRESULT
	Clone as function(byval This as IOpcPartEnumerator ptr, byval copy_ as IOpcPartEnumerator ptr ptr) as HRESULT
end type

type IOpcPartEnumerator_
	lpVtbl as IOpcPartEnumeratorVtbl ptr
end type

type IOpcRelationshipEnumeratorVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationshipEnumerator ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationshipEnumerator ptr) as ULONG
	Release as function(byval This as IOpcRelationshipEnumerator ptr) as ULONG
	MoveNext as function(byval This as IOpcRelationshipEnumerator ptr, byval hasNext as WINBOOL ptr) as HRESULT
	MovePrevious as function(byval This as IOpcRelationshipEnumerator ptr, byval hasPrevious as WINBOOL ptr) as HRESULT
	GetCurrent as function(byval This as IOpcRelationshipEnumerator ptr, byval part as IOpcPart ptr ptr) as HRESULT
	Clone as function(byval This as IOpcRelationshipEnumerator ptr, byval copy_ as IOpcRelationshipEnumerator ptr ptr) as HRESULT
end type

type IOpcPartVtbl field = 1
	QueryInterface as function(byval This as IOpcPart ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcPart ptr) as ULONG
	Release as function(byval This as IOpcPart ptr) as ULONG
	GetRelationshipSet as function(byval This as IOpcPart ptr, byval relationshipSet as IOpcRelationshipSet ptr ptr) as HRESULT
	GetContentStream as function(byval This as IOpcPart ptr, byval stream as IStream ptr ptr) as HRESULT
	GetName as function(byval This as IOpcPart ptr, byval name_ as IOpcPartUri ptr ptr) as HRESULT
	GetContentType as function(byval This as IOpcPart ptr, byval contentType as LPWSTR ptr) as HRESULT
	GetCompressionOptions as function(byval This as IOpcPart ptr, byval compressionOptions as OPC_COMPRESSION_OPTIONS ptr) as HRESULT
end type

type IOpcPart_
	lpVtbl as IOpcPartVtbl ptr
end type

type IOpcRelationshipEnumerator_
	lpVtbl as IOpcRelationshipEnumeratorVtbl ptr
end type

type IOpcRelationshipSelectorEnumeratorVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationshipSelectorEnumerator ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationshipSelectorEnumerator ptr) as ULONG
	Release as function(byval This as IOpcRelationshipSelectorEnumerator ptr) as ULONG
	MoveNext as function(byval This as IOpcRelationshipSelectorEnumerator ptr, byval hasNext as WINBOOL ptr) as HRESULT
	MovePrevious as function(byval This as IOpcRelationshipSelectorEnumerator ptr, byval hasPrevious as WINBOOL ptr) as HRESULT
	GetCurrent as function(byval This as IOpcRelationshipSelectorEnumerator ptr, byval part as IOpcPart ptr ptr) as HRESULT
	Clone as function(byval This as IOpcRelationshipSelectorEnumerator ptr, byval copy_ as IOpcRelationshipSelectorEnumerator ptr ptr) as HRESULT
end type

type IOpcRelationshipSelectorEnumerator_
	lpVtbl as IOpcRelationshipSelectorEnumeratorVtbl ptr
end type

type IOpcRelationshipSelectorVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationshipSelector ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationshipSelector ptr) as ULONG
	Release as function(byval This as IOpcRelationshipSelector ptr) as ULONG
	GetSelectorType as function(byval This as IOpcRelationshipSelector ptr, byval selector as OPC_RELATIONSHIP_SELECTOR ptr) as HRESULT
	GetSelectionCriterion as function(byval This as IOpcRelationshipSelector ptr, byval selectionCriterion as LPWSTR ptr)as HRESULT
end type

type IOpcRelationshipSelector_
	lpVtbl as IOpcRelationshipSelectorVtbl ptr
end type

type IOpcRelationshipSelectorSetVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationshipSelectorSet ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationshipSelectorSet ptr) as ULONG
	Release as function(byval This as IOpcRelationshipSelectorSet ptr) as ULONG
	Create as function(byval This as IOpcRelationshipSelectorSet ptr, byval selector as OPC_RELATIONSHIP_SELECTOR, byval selectionCriterion as LPCWSTR, byval relationshipSelector as IOpcRelationshipSelector ptr ptr) as HRESULT
	Delete_ as function(byval This as IOpcRelationshipSelectorSet ptr, byval relationshipSelector as IOpcRelationshipSelector ptr) as HRESULT
	GetEnumerator as function(byval This as IOpcRelationshipSelectorSet ptr, byval relationshipSelectorEnumerator as IOpcRelationshipSelectorEnumerator ptr ptr) as HRESULT
end type

type IOpcRelationshipSelectorSet_
	lpVtbl as IOpcRelationshipSelectorSetVtbl ptr
end type

type IOpcRelationshipVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationship ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationship ptr) as ULONG
	Release as function(byval This as IOpcRelationship ptr) as ULONG
	GetId as function(byval This as IOpcRelationship ptr, byval relationshipIdentifier as LPWSTR ptr) as HRESULT
	GetRelationshipType as function(byval This as IOpcRelationship ptr, byval relationshipType as LPWSTR ptr) as HRESULT
	GetSourceUri as function(byval This as IOpcRelationship ptr, byval sourceUri as IOpcUri ptr ptr) as HRESULT
	GetTargetUri as function(byval This as IOpcRelationship ptr, byval targetUri as IUri ptr ptr) as HRESULT
	GetTargetMode as function(byval This as IOpcRelationship ptr, byval targetMode as OPC_URI_TARGET_MODE ptr) as HRESULT
end type

type IOpcRelationship_
	lpVtbl as IOpcRelationshipVtbl ptr
end type

type IOpcRelationshipSetVtbl field = 1
	QueryInterface as function(byval This as IOpcRelationshipSet ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
	AddRef as function(byval This as IOpcRelationshipSet ptr) as ULONG
	Release as function(byval This as IOpcRelationshipSet ptr) as ULONG
	GetRelationship as function(byval This as IOpcRelationshipSet ptr, byval relationshipIdentifier as LPCWSTR, byval relationship as IOpcRelationship ptr ptr) as HRESULT
	CreateRelationship as function(byval This as IOpcRelationshipSet ptr, byval relationshipIdentifier as LPCWSTR, byval targetUri as IUri ptr, byval targetMode as OPC_URI_TARGET_MODE, byval relationship as IOpcRelationship ptr ptr) as HRESULT
	DeleteRelationship as function(byval This as IOpcRelationshipSet ptr, byval relationshipIdentifier as LPCWSTR) as HRESULT
	RelationshipExists as function(byval This as IOpcRelationshipSet ptr, byval relationshipIdentifier as LPCWSTR, byval relationshipExists as WINBOOL ptr) as HRESULT
	GetEnumerator as function(byval This as IOpcRelationshipSet ptr, byval relationshipEnumerator as IOpcRelationship ptr ptr) as HRESULT
	GetEnumeratorForType as function(byval This as IOpcRelationshipSet ptr, byval relationshipType as LPCWSTR, byval relationshipEnumerator as IOpcRelationshipEnumerator ptr ptr) as HRESULT
	GetRelationshipContentStream as function(byval This as IOpcRelationshipSet ptr, byval contents as IStream ptr ptr) as HRESULT
end type        

type IOpcRelationshipSet_
	lpVtbl as IOpcRelationshipSetVtbl ptr
end type

You can extract using the OPC api too, but it can only extract files created with it (or that intentionally have a valid '[Content_Types].xml' file put in) otherwise it fails.

[UEZ]

Getting error when trying to compile

Code: Select all

Zip.bas(73) error 42: Variable not declared, __FB_JOIN__ in 'CHECK_HR(ComCall(pFactory, CreatePartUri, itemUri, @pFullPartUri))'
Zip.bas(79) error 9: Expected expression, found '__FB_JOIN__' in 'FATAL_HR(ComCall(pPartSet, CreatePart, pFullPartUri, "n/a", OPC_COMPRESSION_NORMAL, @pNewPart))'
Zip.bas(81) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(ComCall(pNewPart, GetContentStream, @pNewPartData))'
Zip.bas(83) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(SHCreateStreamOnFile(pFilePath, STGM_READ, @pLocalFile))'
Zip.bas(85) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(ComCall(pLocalFile, CopyTo, pNewPartData, *fileSize, 0, 0))'
Zip.bas(159) error 9: Expected expression, found '__FB_JOIN__' in 'FATAL_HR(CoCreateInstance(@CLSID_OpcFactory, 0, CLSCTX_INPROC, @IID_IOpcFactory, @pFactory))'
Zip.bas(161) error 9: Expected expression, found '__FB_JOIN__' in 'FATAL_HR(ComCall(pFactory, CreatePackage, @pPackage))'
Zip.bas(163) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(ComCall(pPackage, GetPartSet, @pPartSet))'
Zip.bas(189) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(SHCreateStreamOnFile(outFile, STGM_CREATE Or STGM_WRITE, @pNewZipFile))'
Zip.bas(190) error 9: Expected expression, found '__FB_JOIN__' in 'CHECK_HR(ComCall(pFactory, WritePackageToStream, pPackage, OPC_WRITE_DEFAULT, pNewZipFile))'
Zip.bas(190) error 133: Too many errors, exiting

Any idea what it missing?

[SARG]

Added in version 1.08 :

- __FB_UNIQUEID_PUSH__(), __FB_UNIQUEID__(), __FB_UNIQUEID_POP__(), __FB_ARG_LEFTOF__(), __FB_ARG_RIGHTOF__(), __FB_JOIN__() builtin macros

[fxm]

There are other recent macros or keywords (added in rev 1.08):
__FB_BUILD_DATE_ISO__
__FB_BUILD_SHA1__
__FB_ARG_COUNT__
__FB_QUOTE__
__FB_UNQUOTE_
__FB_EVAL__
__FB_ARG_EXTRACT__

fb_MemMove()
fb_MemCopy()
fb_MemCopyClear()
ThreadSelf()

[jj2007]

It works fine with FB 1.07 with minor modifications in line 14ff:

Code: Select all

#ifdef DEBUG
#macro FATAL_HR(x)
Scope
   dim hr As HRESULT = (x)
   If FAILED(hr) Then
      ' Print Using __FB_JOIN__(#x, " failed with terminal hresult &"); Hex(hr)
      Print x; " failed with terminal hresult &"; Hex(hr)
      ExitProcess(hr)
   End If
End Scope
#endmacro

#macro CHECK_HR(x)
Scope
   dim hr As HRESULT = (x)
   If FAILED(hr) Then
      Print x; " failed with hresult &"; Hex(hr)
      ' Print Using __FB_JOIN__(#x, " failed with hresult &"); Hex(hr)
   End If
End Scope
#endmacro

7zip achieves a 3% better compression ratio, but this is more than sufficient. Compliments, adeyblue!

[adeyblue]

Oh, you don't actually need FB_JOIN for this. Has anybody realised I don't actually know what I'm doing when writing FB code yet?

For fun, completeness and because I'd already written it, here's the zipfldr only way which works from XP. As mentioned, it's broken without hacks (comment out the call to SwapDodgyPidlFuncs and watch as it fails) and has other weird quirks which means it takes a relatively long time to compress compared to other methods but it somehow works (haven't tested it on Win 10, but it should be good).

Code: Select all

#define UNICODE 1
#define _UNICODE 1
#include once "windows.bi"
#include "win/shellapi.bi"
#include "win/shlwapi.bi"
#include "win/imagehlp.bi"
#include "win/shobjidl.bi"
#include "win/shlobj.bi"

#macro FATAL_HR(x)
Scope
	hr = (x)
	If FAILED(hr) Then
		Print Using #x " failed with terminal hresult &"; Hex(hr)
		ExitProcess(hr)
	End If
End Scope
#endmacro

#macro CHECK_HR(x)
Scope
	hr = (x)
	If FAILED(hr) Then
		Print Using #x " failed with hresult &"; Hex(hr)
	End If
End Scope
#endmacro

Common Shared g_desktopFolder As IShellFolder Ptr

Function AppendWString(ByVal first As WString Ptr, ByVal second As WString Ptr) As WString Ptr
	dim totalLen As Long = Len(*first) + Len(*second) + 1
	dim newStr As WString Ptr = CAllocate(totalLen * SizeOf(*first))
	*newStr = *first
	*newStr += *second
	Return newStr
End Function

Function MakeSureItsAZip(ByVal name1 As WString Ptr) As WString Ptr

	dim res As WString Ptr = name1
	dim pExt As Wstring Ptr = PathFindExtension(name1)
	If (LCase(*pExt) <> ".zip") Then
		res = AppendWString(res, ".zip")
	End If
	Return res
End Function

'' Without swapping out SHILCreateFromPath and ILCreateFromPathW in zipfldr for something like SHSimpleIDListFromPath
'' you can't use normal IStorage and IStream for zipping. With this change, you can. Which means you can know when
'' the file actually finishes compression (since it happens synchronously when you release the interface)
'' unlike when faking a drag & drop, where it happens on a different thread that nobody can wait for and unavoidably
'' shows the progress bar
''
'' Why is this needed? SHILCreateFromPath & ILCreateFromPath check that the path you give them exists before returning an id
'' SHSimpleIDListFromPath doesn't. This is necessary in zipfldr when creating new folders inside the zip file.
'' They obviously don't exist before you create them (so you can't get an id) yet you need an id to create them!
'' So chicken and the egg scenario. The swap thus allows us to create a pidl to something that doesn't exist
'' before we actually make it exist
''
'' This is only required for creating or adding to zip files, the unzip code works fine without this hack.
''
'' If the code/exe makes your anti-virus scanner throw a wobbler, this'll be why. Patching IATs isn't big or clever but it is sometimes necessary

'' our replacements
Function SHILCreateFromPath_Wrap stdcall(ByVal pPath As LPCWSTR, byVal pPidl As LPITEMIDLIST Ptr, ByRef notUsed As ULong) As Long
	*pPidl = SHSimpleIDListFromPath(pPath)
	Return S_OK
End Function

Function ILCreateFromPath_Wrap stdcall(ByVal pPath As LPCWSTR) As LPITEMIDLIST
	Return SHSimpleIDListFromPath(pPath)
End Function

Sub SwapDodgyPidlFuncs()

	'' get the dlls of interest
	dim pZipDll As Any Ptr = GetModuleHandle("zipfldr.dll")
	dim hShell32 As HMODULE = GetModuleHandle("shell32.dll")
	'' and the addresses of the functions we're looking for
	dim shilCreate As Any Ptr = GetProcAddress(hShell32, "SHILCreateFromPath")
	dim ilCreate As Any Ptr = GetProcAddress(hShell32, "ILCreateFromPathW")
	dim size As ULong = 0
	'' find zipfldr's list of imports
	dim pDescriptor As PIMAGE_IMPORT_DESCRIPTOR = ImageDirectoryEntryToData(pZipDll, TRUE, IMAGE_DIRECTORY_ENTRY_IMPORT, @size)
	'' loop through the dlls it imports from
	While pDescriptor->OriginalFirstThunk <> 0
	
		'' get this dlls name
		dim pDll As ZString Ptr = pZipDll + pDescriptor->Name
		'' if its shell32
		If LCase(*pDll) = "shell32.dll" Then
			dim seen As Long = 0
			dim hCurProc As HANDLE = GetCurrentProcess()
			'' start looping through the shell32 functions that zipldr imports
			dim pThunk As PIMAGE_THUNK_DATA = cast(PIMAGE_THUNK_DATA, pZipDll + pDescriptor->FirstThunk)
			While pThunk->u1.Function <> 0
			
				'' see if this function is one of the two we're interested in
				dim pThisImport As Any Ptr = cast(Any Ptr, pThunk->u1.AddressOfData)
				dim toSwapWith As Any Ptr = 0
				If (pThisImport = shilCreate) Then				
					toSwapWith = @SHILCreateFromPath_Wrap
					seen += 1
				ElseIf (pThisImport = ilCreate) Then				
					toSwapWith = @ILCreateFromPath_Wrap
					seen += 1
				End If
				'' if it is, do the swap
				If toSwapWith <> 0 Then
				
					dim oldProt As ULong = 0
					VirtualProtect(@pThunk->u1, SizeOf(pThisImport), PAGE_EXECUTE_READWRITE, @oldProt)
					pThunk->u1.AddressOfData = cast(DWORD_PTR, toSwapWith)
					VirtualProtect(@pThunk->u1, SizeOf(pThisImport), oldProt, 0)
					FlushInstructionCache(hCurProc, @pThunk->u1, SizeOf(pThisImport))
					'' if we've done both, we're finished
					If seen = 2 Then 
						Exit Sub
					End If
					
				End If
				pThunk += 1
			Wend
		End If
		pDescriptor += 1
	Wend
End Sub

Function CreateACreateBindContext() As IBindCtx Ptr

	dim hr As HRESULT
	dim pCtx As IBindCtx Ptr = 0
	CHECK_HR(CreateBindCtx(0, @pCtx))
	If pCtx <> 0 Then
		dim bo As BIND_OPTS
		bo.cbStruct = SizeOf(bo)
		bo.grfMode = STGM_CREATE Or STGM_WRITE
		CHECK_HR(pCtx->lpVtbl->SetBindOptions(pCtx, @bo))
	End If
	Return pCtx
End Function

Function PidlToFolderName(ByVal pFolder As IShellFolder Ptr, ByVal pFilePidl As LPITEMIDLIST) As WString Ptr

	dim pItemName As WString Ptr = 0
	dim strretName As STRRET
	dim hr As HRESULT
	'' Get the folder name for this id
	CHECK_HR(pFolder->lpVtbl->GetDisplayNameOf(pFolder, pFilePidl, SHGDN_INFOLDER, @strretName))
	'' transform it into a string
	StrRetToStr(@strretName, pFilePidl, @pItemName)
	Return pItemName
End Function

Sub ZipAFolder(ByVal pFolder As IShellFolder Ptr, ByVal pZipFolder As IStorage Ptr, ByVal pFolderName As WString Ptr, ByVal pFullZipFolderPath As WString Ptr)

	dim pEnum As IEnumIDList Ptr
	dim hr As HRESULT
	dim got As ULong
	dim pFilePidl As LPITEMIDLIST
	dim fileEnumType As ULong = SHCONTF_NONFOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN
	dim folderEnumType As ULong = SHCONTF_FOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN

	Print "Zip: entered folder " & *pFolderName

	'' get an interface to loop over the files in file system folder
	if SUCCEEDED(pFolder->lpVtbl->EnumObjects(pFolder, NULL, fileEnumType, @pEnum)) Then
	
		'' get an interface to create file system files and folders
		dim pSourceFolderStorage As IStorage Ptr
		pFolder->lpVtbl->QueryInterface(pFolder, @IID_IStorage, @pSourceFolderStorage)
		'' while we find files
		While (pEnum->lpVtbl->Next(pEnum, 1, @pFilePidl, @got) = S_OK) AndAlso (got = 1)
		
			'' get the file name
			dim pItemName As WString Ptr = PidlToFolderName(pFolder, pFilePidl)
			'' Copy the file into the zip file
			hr = pSourceFolderStorage->lpVtbl->MoveElementTo(pSourceFolderStorage, pItemName, pZipFolder, pItemName, STGMOVE_COPY)
			If SUCCEEDED(hr) Then
			
				Print Using "Zipped '&_\&'"; *pFolderName; *pItemName
			Else
			
				Print Using "Couldn't zip '&_\&' because of error &"; *pFolderName; *pItemName; Hex(hr)
				
			End If
			CoTaskMemFree(pItemName)
			CoTaskMemFree(pFilePidl)
			got = 0 
		Wend
		pSourceFolderStorage->lpVtbl->Release(pSourceFolderStorage)
		pEnum->lpVtbl->Release(pEnum)
	End If
	'' we need to release all hold on the zip before moving onto sub or sibling folders
	'' This is because using the zip folder like this (with IStorage) marks the temp files it creates as read-only
	'' but it doesn't mimic the folder structure you create (it just dumps all the temp files
	'' in a single, flat directory)
	'' so if there are files in sub/sibling directory with the same name (eg Dir1\photo.jpg and Dir2\photo.jpg)
	'' then Dir2\photo.jpg will fail to be added, because a photo.jpg already exists from Dir1 and it can't be
	'' overwritten because its marked read-only.
	''
	'' This is why the enumeration is split into files (above) and folder (below)
	pZipFolder->lpVtbl->Release(pZipFolder)
	'' get the interface to enum file system folders
	If SUCCEEDED(pFolder->lpVtbl->EnumObjects(pFolder, NULL, folderEnumType, @pEnum)) Then

		'' Create an interface that will force the shell to give us an id for something
		'' that doesn't currently exists
		dim pCtx As IBindCtx Ptr = CreateACreateBindContext()
		While (pEnum->lpVtbl->Next(pEnum, 1, @pFilePidl, @got) = S_OK) AndAlso (got = 1)
		
			dim pSubFolder As IShellFolder Ptr
			If SUCCEEDED(pFolder->lpVtbl->BindToObject(pFolder, pFilePidl, NULL, @IID_IShellFolder, @pSubFolder)) Then
			
				'' create a sub folder in the zip file
				''
				'' we can't use pZipFolder->CreateStorage like you'd expect to create folders in the zip
				'' since the Zip Folders CreateStorage does
				'' funky things like trying to compress an empty directory and will always fail.
				'' so first we have to bind to a non-existant folder in the zip file
				'' and create streams (aka files) through that (which makes it then exist!)
				''
				'' Don't ask me, I didn't program it

				'' Get the name of this folder
				dim pItemName As WString Ptr = PidlToFolderName(pFolder, pFilePidl)

				dim pathSoFar As WString Ptr = pFullZipFolderPath
				dim addend As WString*MAX_PATH = "\" & *pItemName
				pathSoFar = AppendWString(pathSoFar, addend)

				'' get the shell id for the new (non-existant) zip file directory
				dim pZipFullPidl As LPITEMIDLIST = 0
				CHECK_HR(g_desktopFolder->lpVtbl->ParseDisplayName(g_desktopFolder, 0, pCtx, pathSoFar, 0, @pZipFullPidl, 0))
				'' Get the interface for it
				dim pZipSubFolder As IStorage Ptr
				hr = g_desktopFolder->lpVtbl->BindToStorage(g_desktopFolder, pZipFullPidl, pCtx, @IID_IStorage, @pZipSubFolder)
				If SUCCEEDED(hr) Then
					'' recurse to the child folder
					ZipAFolder(pSubFolder, pZipSubFolder, pItemName, pathSoFar)
				Else
				
					Print Using "Couldn't create sub folder '&_\&' in zip file. Error &"; *pFolderName; *pItemName; Hex(hr)
					
				End If
				CoTaskMemFree(pZipFullPidl)
				CoTaskMemFree(pItemName)
				DeAllocate(pathSoFar)
				pSubFolder->lpVtbl->Release(pSubFolder)
			End If
			CoTaskMemFree(pFilePidl)
			got = 0
		Wend
		If (pCtx <> 0) Then pCtx->lpVtbl->Release(pCtx)
		pEnum->lpVtbl->Release(pEnum)
	End If
	Print "Zip: leaving directory " & *pFolderName
End Sub

Sub DoZipStuff(ByVal inFile As WString Ptr, ByVal outFile As WString Ptr, ByVal isADir As Boolean)

	dim hr As HRESULT = 0
	'' zip file detection ois based on file extension, so add on .zip if it doesn't exist
	dim outFileName As WString Ptr = MakeSureItsAZip(outFile)
	
	Print "Using the zip file name " & *outFileName
	'' create the output file
	Scope
		Dim f As Long = Freefile
		Open *outFileName For Binary As #f
		Close #f
	End Scope

	'' translate the file system paths to shell ids
	dim srcPidl As LPITEMIDLIST = ILCreateFromPath(inFile)
	dim dstPidl As LPITEMIDLIST = ILCreateFromPath(outFileName)

	'' get the interface that'll let us create things inside the zip
	dim pZipFolder As IStorage Ptr = 0
	FATAL_HR(g_desktopFolder->lpVtbl->BindToObject(g_desktopFolder, dstPidl, 0, @IID_IStorage, @pZipFolder))

	'' important, doesnt work without this
	SwapDodgyPidlFuncs()

	If isADir Then
		'' get an interface so we can find out whats in the to-be-compressed directory
		dim pRootFolder As IShellFolder Ptr = 0
		FATAL_HR(g_desktopFolder->lpVtbl->BindToObject(g_desktopFolder, srcPidl, NULL, @IID_IShellFolder, @pRootFolder))
		ZipAFolder(pRootFolder, pZipFolder, PathFindFileName(inFile), outFileName)
		'' pZipFolder is released inside ZipAFolder
		pRootFolder->lpVtbl->Release(pRootFolder)
		
	Else
		'' just a single file
		dim pSourceFileFolder As IStorage Ptr = 0
		dim pidlPart As LPCITEMIDLIST = 0
		'' get an file manipulation interface of the file's parent directory
		FATAL_HR(SHBindToParent(srcPidl, @IID_IStorage, @pSourceFileFolder, @pidlPart))
		dim pFileName As WString Ptr = PathFindFileName(inFile)
		'' Use it to copy the file into the zip
		FATAL_HR(pSourceFileFolder->lpVtbl->MoveElementTo(pSourceFileFolder, pFileName, pZipFolder, pFileName, STGMOVE_COPY))
		pSourceFileFolder->lpVtbl->Release(pSourceFileFolder)
		pZipFolder->lpVtbl->Release(pZipFolder)
		Print "Zipped one file: " & *pFileName
	End If

	ILRemoveLastID(dstPidl)
	SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_IDLIST, dstPidl, 0)

	CoTaskMemFree(srcPidl)
	CoTaskMemFree(dstPidl)
	If outFileName <> outFile Then
		DeAllocate(outFileName)
	End If
End Sub

Sub UnZipAFolder(ByVal pZipFolder As IShellFolder Ptr, ByVal pFSFolder As IStorage Ptr, ByVal pFolderName As WString Ptr)

	dim hr As HRESULT = 0
	dim pEnum As IEnumIDList Ptr = 0
	'' find everything in the zip
	dim enumType As ULong = SHCONTF_NONFOLDERS Or SHCONTF_FOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN

	Print "Unzip: entering directory " & *pFolderName

	'' get an interface we can use to loop over the contents of the zip
	CHECK_HR(pZipFolder->lpVtbl->EnumObjects(pZipFolder, NULL, enumType, @pEnum))
	If SUCCEEDED(hr) Then
	
		dim itemsGot As ULong = 0
		dim pFilePidl As LPITEMIDLIST = 0
		dim pZipFolderStorage As IStorage Ptr = 0

		'' Get an interface that can do the copy the items out of this zip directory
		pZipFolder->lpVtbl->QueryInterface(pZipFolder, @IID_IStorage, @pZipFolderStorage)
       
       		'' while we're finding items
        	While SUCCEEDED(pEnum->lpVtbl->Next(pEnum, 1, @pFilePidl, @itemsGot)) AndAlso (itemsGot = 1)
		
			'' attriobute to query whether the thing is a file or not
			dim attributes As DWORD = SFGAO_STREAM
			'' see what type of item this is
			pZipFolder->lpVtbl->GetAttributesOf(pZipFolder, 1, @pFilePidl, @attributes)
			
			'' translate the id into a name
			dim pFileName As WString Ptr = PidlToFolderName(pZipFolder, pFilePidl)
           
			If ((attributes And SFGAO_STREAM) <> 0) Then '' we found a file

				'' extract it
				hr = pZipFolderStorage->lpVtbl->MoveElementTo(pZipFolderStorage, pFileName, pFSFolder, pFileName, STGMOVE_COPY)
				If SUCCEEDED(hr) Then
				
					Print Using "UnZipped &_\&"; *pFolderName; *pFileName
				
				Else				
					Print Using "Couldn't unzip &_\& because of error &"; *pFolderName; *pFileName; Hex(hr)
				End If

			Else '' we found a folder, recurse to extract its files

				dim pZipSubFolder As IShellFolder Ptr = 0
				dim pFSSubFolder As IStorage Ptr = 0

				'' get the interface for the zip folder
				CHECK_HR(pZipFolder->lpVtbl->BindToObject(pZipFolder, pFilePidl, 0, @IID_IShellFolder, @pZipSubFolder))
				'' create a new corresponding folder on disk
				CHECK_HR(pFSFolder->lpVtbl->CreateStorage(pFSFolder, pFileName, STGM_CREATE, 0, 0, @pFSSubFolder))

				If (pZipFolder <> 0) AndAlso (pFSSubFolder <> 0) Then

					UnZipAFolder(pZipSubFolder, pFSSubFolder, pFileName)
					pFSSubFolder->lpVtbl->Release(pFSSubFolder)
				End If
				if pZipSubFolder <> 0 Then pZipSubFolder->lpVtbl->Release(pZipSubFolder)
			End If
           
			CoTaskMemFree(pFilePidl)
			CoTaskMemFree(pFileName)
			itemsGot = 0
		Wend
		pZipFolderStorage->lpVtbl->Release(pZipFolderStorage)
		pEnum->lpVtbl->Release(pEnum)
	End If
   
	Print "Unzip: leaving directory " & *pFolderName
End Sub

Sub DoUnZipStuff(ByVal inputFile As WString Ptr, ByVal outputFile As WString Ptr)

	dim hr As HRESULT = 0
	'' Don't bother checking the input is a zip file, so you could use the 'unzip'
	'' part of this program for generic folder copying!
	SHCreateDirectory(NULL, outputFile)
   
	Print Using "Unzipping & to &"; *inputFile; *outputFile
   
	'' Turn our filenames to pidls
	dim srcPidl As LPITEMIDLIST = ILCreateFromPath(inputFile)
	dim dstPidl As LPITEMIDLIST = ILCreateFromPath(outputFile)

	'' Get an interface so we can see what's in the zip file
	dim pZipFolder As IShellFolder Ptr = 0
	FATAL_HR(g_desktopFolder->lpVtbl->BindToObject(g_desktopFolder, srcPidl, NULL, @IID_IShellFolder, @pZipFolder))
   
	'' And one so we can create files and folders on disk
	dim pFSFolder As IStorage Ptr = 0
	FATAL_HR(g_desktopFolder->lpVtbl->BindToStorage(g_desktopFolder, dstPidl, NULL, @IID_IStorage, @pFSFolder))
   
	UnZipAFolder(pZipFolder, pFSFolder, PathFindFileName(outputFile))
   
	Print "Finished"
   
	pFSFolder->lpVtbl->Release(pFSFolder)
	pZipFolder->lpVtbl->Release(pZipFolder)

	ILRemoveLastID(dstPidl)
	SHChangeNotify(SHCNE_UPDATEDIR, SHCNF_IDLIST, dstPidl, 0)
   
	CoTaskMemFree(srcPidl)
	CoTaskMemFree(dstPidl)
End Sub

Function FullyQualifyFileName(ByVal pFileName As WString Ptr) As WString Ptr

	dim pFullPath As WString Ptr
	if PathIsRelative(pFileName) Then
	
		dim req As ULong = GetFullPathName(pFileName, 0, NULL, NULL)
		pFullPath = CAllocate(req * SizeOf(*pFullPath))
		req = GetFullPathName(pFileName, req, pFullPath, NULL)
	Else
		pFullPath = pFileName
	End If
	Return pFullPath
End Function

Sub MainSub()

	dim hr As HRESULT = S_OK
	dim attributes As ULong
	dim numArgs As Long
	dim args As WString Ptr Ptr = CommandLineToArgvw(GetCommandLine(), @numArgs)
	
	If (numArgs < 3) Then
printUsage:
		Print "Usage: ZipAThing C:\path\to\thing output.zip [doUnzip]"
		Print "The 'thing' may be a single file or a folder. If a folder, everything inside"
		Print "it will be added to the zip"
		Print
		Print "If doUnzip exists, contents of the zip will be extracted to 'thing' which will"
		Print "be created as a directory"
		LocalFree(args)
		End 1
		
	End If
	attributes = GetFileAttributes(args[1])
	If attributes = INVALID_FILE_ATTRIBUTES Then Goto printUsage

	FATAL_HR(CoInitializeEx(NULL, COINIT_APARTMENTTHREADED Or COINIT_DISABLE_OLE1DDE))

	SHGetDesktopFolder(@g_desktopFolder)

	dim fsFile As WString Ptr = FullyQualifyFileName(args[1])
	dim zipFile As WString Ptr = FullyQualifyFileName(args[2])

	If numArgs < 4 Then
	
		''Print Using "Zipping from & to &"; *fsFile; *zipFile
		DoZipStuff(fsFile, zipFile, attributes And FILE_ATTRIBUTE_DIRECTORY)
		
	Else
		''Print Using "Unzipping & to &"; *zipFile; *fsFile
		DoUnZipStuff(zipFile, fsFile)
		
	End If

	If fsFile <> args[1] Then
		DeAllocate(fsFile)
	End If
	If zipFile <> args[2] Then
		DeAllocate(zipFile)
	End If

	LocalFree(args)
	
	g_desktopFolder->lpVtbl->Release(g_desktopFolder)
	CoUninitialize()
End Sub

MainSub()

[jj2007]

Both have identical compression rates. Interesting...