fafalone, thank you for writing to the developers of twin BASIC. It's nice to be heard. I was surprised to read it here https://nolongerset.com/twinbasic-up...ember-26-2024/ that the problem has not been ignored. However, it is not clear if they have corrected the error. When will there be a new release of twin BASIC?
By the way, there they have in their article, an uncorrected link to this section of the forum "The CAB Archive packaging module", their link does not open with a direct transition for some reason.
It wasn't on the list of fixes for the release due any day now... That's not final but also there's a huge backlog of bugs and no clear system for order they're fixed. Seems significant in preventing execution and easy to reproduce, but not affecting 10/11.. so it will definitely be fixed I just couldn't guess at when.
For the url just post a comment on the article or find Mike's email on the site I'm sure he'd correct it; looks like it just automatically appended referrer info that VBF can't handle.
Last edited by fafalone; Nov 29th, 2024 at 04:47 PM.
Wayne Phillips discovered that the error occurs due to writing ".dll" in the declaration. I removed the ".dll" and left only "cabinet" instead of the full "cabinet.dll "and everything started working right away. And I used to puzzle for half a day and couldn't even understand the nature of this error.
I have written a new version 1.5 of the module for compressing CAB archives. The version is fully compatible with 64-bit systems. Improvements in the new version:
compression of CAB archives into a byte array or into an IStream
compression of CAB archives from a byte array or from an IStream
the ability to compress the buffer inside the memory, without using files at all and saving to disk
the ability to compress a byte array inside memory, for example, instead of using the well-known RtlCompressBuffer/RtlDecompressBuffer functions, while the compression ratio will be significantly higher
the ability to transfer an IStream object or an IStream object descriptor in a universal function CabinetAddFiles, or a byte array, or a file path
Decompression I haven't written it yet, but this module itself is intended only for data compression. Decompression (unpacking) will be left for later.
Here is a new version of the module, divided into two parts (you need to copy the first part first, then the second part and connect them, sorry this is a limitation of the forum):
Last edited by HackerVlad; Jan 19th, 2025 at 02:27 PM.
Option Explicit
'////////////////////////////////////////////
'// Module for compressing CAB archives //
'// Copyright (c) 2025-01-09 by HackerVlad //
'// e-mail: vladislavpeshkov@ya.ru //
'// Version 1.5 (32 and 64-bit compatible) //
'////////////////////////////////////////////
' API declarations ...
#If VBA7 = 0 Then
Private Declare Function FCICreate CDecl Lib "cabinet" (perf As TERF, ByVal fnFilePlaced As Long, ByVal fnAlloc As Long, ByVal fnFree As Long, ByVal fnOpen As Long, ByVal fnRead As Long, ByVal fnWrite As Long, ByVal fnClose As Long, ByVal fnSeek As Long, ByVal fnDelete As Long, ByVal fnFciGTF As Long, ByVal ccab As Long, Optional ByVal pv As Long) As Long
Private Declare Function FCIAddFile CDecl Lib "cabinet" (ByVal hfci As Long, ByVal pszSourceFile As Long, ByVal pszFileName As Long, ByVal fExecute As BOOL, ByVal pfnGetNextCabinet As Long, ByVal pfnProgress As Long, ByVal pfnOpenInfo As Long, ByVal typeCompress As Long) As Long
Private Declare Function FCIFlushCabinet CDecl Lib "cabinet" (ByVal hfci As Long, ByVal fGetNextCab As BOOL, ByVal pfnfcignc As Long, ByVal pfnfcis As Long) As BOOL
Private Declare Function FCIDestroy CDecl Lib "cabinet" (ByVal hfci As Long) As BOOL
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (ByVal pInit As Long, ByVal cbInit As Long) As Long
Private Declare Function IStream_Size Lib "shlwapi" Alias "#214" (ByVal ptrIStream As Long, ULARGE_INTEGER As Currency) As Long
Private Declare Sub PathStripPathW Lib "shlwapi" (ByVal pszPath As Long)
Private Declare Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToDosDateTime Lib "kernel32" (lpFileTime As FILETIME, lpFatDate As Integer, lpFatTime As Integer) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As BOOL
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As BOOL
Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Private Enum LongPtr
[_]
End Enum
#Else
Private Declare PtrSafe Function FCICreate CDecl Lib "cabinet" (perf As TERF, ByVal pfnfcifp As LongPtr, ByVal pfna As LongPtr, ByVal pfnf As LongPtr, ByVal pfnopen As LongPtr, ByVal pfnread As LongPtr, ByVal pfnwrite As LongPtr, ByVal pfnclose As LongPtr, ByVal pfnseek As LongPtr, ByVal pfndelete As LongPtr, ByVal pfnfcigtf As LongPtr, pccab As TCCAB, Optional ByVal pv As LongPtr) As LongPtr
Private Declare PtrSafe Function FCIAddFile CDecl Lib "cabinet" (ByVal hfci As LongPtr, ByVal pszSourceFile As LongPtr, ByVal pszFileName As LongPtr, ByVal fExecute As BOOL, ByVal pfnfcignc As LongPtr, ByVal pfnfcis As LongPtr, ByVal pfnfcigoi As LongPtr, [TypeHint(FdiFciTcompValues)] ByVal typeCompress As Integer) As BOOL
Private Declare PtrSafe Function FCIFlushCabinet CDecl Lib "cabinet" (ByVal hfci As LongPtr, ByVal fGetNextCab As BOOL, ByVal pfnfcignc As LongPtr, ByVal pfnfcis As LongPtr) As BOOL
Private Declare PtrSafe Function FCIDestroy CDecl Lib "cabinet" (ByVal hfci As LongPtr) As BOOL
Private Declare PtrSafe Function SHCreateMemStream Lib "shlwapi" Alias "#12" (ByVal pInit As LongPtr, ByVal cbInit As Long) As LongPtr
Private Declare PtrSafe Function IStream_Size Lib "shlwapi" Alias "#214" (ByVal ptrIStream As LongPtr, ULARGE_INTEGER As Currency) As Long
Private Declare PtrSafe Sub PathStripPathW Lib "shlwapi" (ByVal pszPath As LongPtr)
Private Declare PtrSafe Function PathRemoveFileSpecW Lib "shlwapi" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal uFlags As GMEM, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As BOOL
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As LongPtr) As Long
Private Declare PtrSafe Function GetFileTime Lib "kernel32" (ByVal hFile As LongPtr, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare PtrSafe Function FileTimeToDosDateTime Lib "kernel32" (lpFileTime As FILETIME, lpFatDate As Integer, lpFatTime As Integer) As Long
Private Declare PtrSafe Function SetFilePointer Lib "kernel32" (ByVal hFile As LongPtr, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare PtrSafe Function ReadFile Lib "kernel32" (ByVal hFile As LongPtr, ByVal lpBuffer As LongPtr, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As BOOL
Private Declare PtrSafe Function WriteFile Lib "kernel32" (ByVal hFile As LongPtr, ByVal lpBuffer As LongPtr, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As BOOL
Private Declare PtrSafe Function CreateFileA Lib "kernel32" (ByVal lpFileName As LongPtr, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateFileW Lib "kernel32" (ByVal lpFileName As LongPtr, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
#End If
#If Win64 Then
Private Declare PtrSafe Function GetMemPtr Lib "msvbvm60" Alias "GetMem8" (ByVal Addr As LongLong, ByRef dstValue As LongLong) As Long
#Else
Private Declare Function GetMemPtr Lib "msvbvm60" Alias "GetMem4" (ByVal Addr As Long, ByRef dstValue As Long) As Long
#End If
' Constants ...
Private Const CB_MAX_DISK_NAME = 256
Private Const CB_MAX_CABINET_NAME = 256
Private Const CB_MAX_CAB_PATH = 256
Private Const OFS_MAXPATHNAME = 128
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const INVALID_HANDLE_VALUE = -1
Private Const CREATE_ALWAYS = 2
Private Const MAX_PATH As Long = 260
' Types ...
Private Type TCCAB
cb As Long ' size available for cabinet on this media
cbFolderThresh As Long ' Thresshold for forcing a new Folder
cbReserveCFHeader As Long ' Space to reserve in CFHEADER
cbReserveCFFolder As Long ' Space to reserve in CFFOLDER
cbReserveCFData As Long ' Space to reserve in CFDATA
iCab As Long ' sequential numbers for cabinets
iDisk As Long ' Disk number
fFailOnIncompressible As Long ' TRUE => Fail if a block is incompressible
setID As Integer ' Cabinet set ID
szDisk(0 To (CB_MAX_DISK_NAME - 1)) As Byte ' current disk name
szCab(0 To (CB_MAX_CABINET_NAME - 1)) As Byte ' current cabinet name
szCabPath(0 To (CB_MAX_CAB_PATH - 1)) As Byte ' path for creating cabinet
End Type
Private Type TERF
erfOper As Long
erfType As Long
fError As Byte
End Type
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(0 To (OFS_MAXPATHNAME - 1)) As Byte
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
' Enums ...
Private Enum FdiFciTcompValues
tcompMASK_TYPE = &HF ' Mask for compression type
tcompTYPE_NONE = &H0 ' No compression
tcompTYPE_MSZIP = &H1 ' MSZIP
tcompTYPE_QUANTUM = &H2 ' Quantum
tcompTYPE_LZX = &H3 ' LZX
tcompBAD = &HF ' Unspecified compression type
tcompMASK_LZX_WINDOW = &H1F00 ' Mask for LZX Compression Memory
tcompLZX_WINDOW_LO = &HF00 ' Lowest LZX Memory (15)
tcompLZX_WINDOW_HI = &H1500 ' Highest LZX Memory (21)
tcompSHIFT_LZX_WINDOW = 8 ' Amount to shift over to get int
tcompMASK_QUANTUM_LEVEL = &HF0 ' Mask for Quantum Compression Level
tcompQUANTUM_LEVEL_LO = &H10 ' Lowest Quantum Level (1)
tcompQUANTUM_LEVEL_HI = &H70 ' Highest Quantum Level (7)
tcompSHIFT_QUANTUM_LEVEL = 4 ' Amount to shift over to get int
tcompMASK_QUANTUM_MEM = &H1F00 ' Mask for Quantum Compression Memory
tcompQUANTUM_MEM_LO = &HA00 ' Lowest Quantum Memory (10)
tcompQUANTUM_MEM_HI = &H1500 ' Highest Quantum Memory (21)
tcompSHIFT_QUANTUM_MEM = 8 ' Amount to shift over to get int
tcompMASK_RESERVED = &HE000& ' Reserved bits (high 3 bits)
End Enum
Private Enum GMEM
GMEM_FIXED = &H0
GMEM_MOVEABLE = &H2
GMEM_NOCOMPACT = &H10
GMEM_NODISCARD = &H20
GMEM_ZEROINIT = &H40
GMEM_MODIFY = &H80
GMEM_DISCARDABLE = &H100
GMEM_NOT_BANKED = &H1000
GMEM_SHARE = &H2000
GMEM_DDESHARE = &H2000
GMEM_NOTIFY = &H4000
GMEM_LOWER = &H1000
GMEM_VALID_FLAGS = &H7F72
GMEM_INVALID_HANDLE = &H8000&
GHND = GMEM_MOVEABLE Or GMEM_ZEROINIT
GPTR = GMEM_FIXED Or GMEM_ZEROINIT
GMEM_DISCARDED = &H4000
GMEM_LOCKCOUNT = &HFF
End Enum
Private Enum BOOL
cFalse
cTrue
End Enum
Private Enum Stream_Seek
STREAM_SEEK_SET
STREAM_SEEK_CUR
STREAM_SEEK_END
End Enum
Public Enum cabCompressionMethod
cm_MSZIP = tcompTYPE_MSZIP
cm_LZX15 = tcompTYPE_LZX Or tcompLZX_WINDOW_LO
cm_LZX16 = &H1003&
cm_LZX17 = &H1103&
cm_LZX18 = &H1203&
cm_LZX19 = &H1303&
cm_LZX20 = &H1403&
cm_LZX21 = tcompTYPE_LZX Or tcompLZX_WINDOW_HI
End Enum
' Variables for temporary data storage ...
Dim fh As LongPtr
Dim fh_cab As LongPtr
Dim cabFileName As String
Dim cabIStream As LongPtr
Dim SourceIStream As LongPtr
Private Function DispCallByVtbl(ByVal pUnk As LongPtr, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
Const CC_STDCALL As Long = 4
#If Win64 Then
Const PTR_SIZE As Long = 8
#Else
Const PTR_SIZE As Long = 4
#End If
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As LongPtr
Dim hResult As Long
vParam = A
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(pUnk, lIndex * PTR_SIZE, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
Private Function IStream_Read(ByVal ptrIStream As LongPtr, ByVal pv As LongPtr, ByVal BytesRead As Long) As Long
Dim BytesReaded As Long
DispCallByVtbl ptrIStream, 3, pv, BytesRead, VarPtr(BytesReaded)
IStream_Read = BytesReaded
End Function
Private Function IStream_Write(ByVal ptrIStream As LongPtr, ByVal pv As LongPtr, ByVal BytesWrite As Long) As Long
Dim BytesWritten As Long
DispCallByVtbl ptrIStream, 4, pv, BytesWrite, VarPtr(BytesWritten)
IStream_Write = BytesWritten
End Function
Private Function IStream_Seek(ByVal ptrIStream As LongPtr, ByVal Offset As Currency, ByVal Origin As Stream_Seek) As Long
Dim NewPosition As Currency
DispCallByVtbl ptrIStream, 5, Offset, Origin, VarPtr(NewPosition)
IStream_Seek = NewPosition * 10000@
End Function
Private Sub IStream_Release(ByVal ptrIStream As LongPtr)
DispCallByVtbl ptrIStream, 2
End Sub
' Convert an IStream stream to a byte array
Public Sub IStream2ByteArray(ByVal ptrIStream As Variant, ByteArray() As Byte, Optional ClearIStreamAfterCompletion As Boolean)
Dim hStream As LongPtr
Dim sizeStream As Currency
Dim sizeByteArray As Long
If VarType(ptrIStream) = vbLong Or VarType(ptrIStream) = 20 Then ' Or VarType = LongPtr
hStream = ptrIStream
ElseIf VarType(ptrIStream) = vbDataObject Then
hStream = ObjPtr(ptrIStream)
Else
Exit Sub
End If
IStream_Size hStream, sizeStream
If sizeStream > 0 Then sizeByteArray = sizeStream * 10000@
If sizeByteArray > 0 Then
ReDim ByteArray(sizeByteArray - 1)
IStream_Seek hStream, 0, STREAM_SEEK_SET ' Go to the beginning of the stream
IStream_Read hStream, VarPtr(ByteArray(0)), sizeByteArray ' Copy to a byte array
If ClearIStreamAfterCompletion = True Then
IStream_Release hStream ' Clear the IStream stream
End If
End If
End Sub
' +++ FCICreate CallBack's +++
' 1. Memory allocation
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnalloc
' Delphi: function fnAlloc(Size: ULONG): Pointer; cdecl;
Private Function fnAlloc CDecl(ByVal lngSize As Long) As LongPtr
fnAlloc = GlobalAlloc(0, lngSize)
End Function
' 2. Creating a temporary file (stream)
' Delphi: function fnFciGTF(pszTempName: PAnsiChar; cbTempName: Integer; pv: Pointer): BOOL; cdecl;
Private Function fnFciGTF CDecl(ByVal pszTempName As LongPtr, ByVal cbTempName As Long, ByVal pv As LongPtr) As BOOL
' Special hack:
' We are deceiving the operating system, which will "think" that it works with TMP files on the disk
' Instead of a temporary file on disk, we will create an IStream stream in the RAM of our process
Dim hStream As LongPtr
hStream = SHCreateMemStream(0, 0) ' Create a new IStream for a temporary file
' pszTempName = hStream ' Here we will use a hack: we put the Long value in the String variable
CopyMemory pszTempName, VarPtr(hStream), LenB(hStream)
fnFciGTF = 1
End Function
' 3. Opening a file (stream)
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnopen
' Delphi: function fnOpen(pszFile: PAnsiChar; oflag: Integer; pmode: Integer; err: PInteger; pv: Pointer): Integer; cdecl;
Private Function fnOpen CDecl(ByVal pszFile As LongPtr, ByVal oFlag As Long, ByVal pMode As Long, ByRef ErrNo As Long, ByVal pv As LongPtr) As LongPtr
If oFlag <> &H8302& Then ' Hack
' fnOpen = pszFile
CopyMemory VarPtr(fnOpen), pszFile, LenB(pszFile)
Else
If Len(cabFileName) > 0 Then
fh_cab = CreateFileW(StrPtr(cabFileName), GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_ARCHIVE, 0)
If fh_cab <> INVALID_HANDLE_VALUE Then
ErrNo = Err.LastDllError
fnOpen = fh_cab
Else
ErrNo = Err.LastDllError
fnOpen = -1
End If
Else
fnOpen = cabIStream
End If
End If
End Function
' 4. Reading data
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnread
' Delphi: function fnRead(hf: Integer; memory: Pointer; cb: UINT; err: PInteger; pv: Pointer): UINT; cdecl;
Private Function fnRead CDecl(ByVal hf As LongPtr, ByVal hMemory As LongPtr, ByVal cbSize As Long, ByRef ErrNo As Long, ByVal pv As LongPtr) As Long
Dim dwBytesRead As Long
If hf = fh Then ' If a file is opened for reading, which is added to the archive
If ReadFile(fh, hMemory, cbSize, dwBytesRead, ByVal 0&) = cFalse Then
ErrNo = Err.LastDllError
fnRead = -1
Exit Function
End If
Else ' If an IStream stream is opened for reading
dwBytesRead = IStream_Read(hf, hMemory, cbSize)
End If
fnRead = dwBytesRead
End Function
' 5. Writing data
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnwrite
' Delphi: function fnWrite(hf: Integer; memory: Pointer; cb: UINT; err: PInteger; pv: Pointer): UINT; cdecl;
Private Function fnWrite CDecl(ByVal hf As LongPtr, ByVal hMemory As LongPtr, ByVal cbSize As Long, ByRef ErrNo As Long, ByVal pv As LongPtr) As Long
Dim dwBytesWritten As Long
If hf = fh_cab Then ' If an archive file is opened for recording
If WriteFile(fh_cab, hMemory, cbSize, dwBytesWritten, ByVal 0&) = cFalse Then
ErrNo = Err.LastDllError
fnWrite = -1
Exit Function
End If
Else ' If an IStream is being opened for writing
dwBytesWritten = IStream_Write(hf, hMemory, cbSize)
End If
fnWrite = dwBytesWritten
End Function
' 6. Freeing up memory
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnfree
' Delphi: procedure fnFree(memory: Pointer); cdecl;
Private Sub fnFree CDecl(ByVal lngMemory As LongPtr)
GlobalFree lngMemory
End Sub
' 7. Positioning the pointer
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnseek
' Delphi: function fnSeek(hf: Integer; dist: Longint; seektype: Integer; err: PInteger; pv: Pointer): Longint; cdecl;
Private Function fnSeek CDecl(ByVal hf As LongPtr, ByVal dist As Long, ByVal seektype As Long, ByRef ErrNo As Long, ByVal pv As LongPtr) As Long
Dim newPos As Long
If hf = fh Or hf = fh_cab Then ' If a file is opened for positioning, which is added to the archive, or the archive file itself
newPos = SetFilePointer(hf, dist, ByVal 0&, seektype)
ErrNo = Err.LastDllError
Else ' IStream positioning
newPos = IStream_Seek(hf, dist / 10000@, seektype)
End If
fnSeek = newPos
End Function
' 8. Closing a file (stream)
' Description of the macro: https://learn.microsoft.com/en-us/windows/win32/api/fdi/nf-fdi-fnclose
' Delphi: function fnClose(hf: Integer; err, pv: Pointer): Integer; cdecl;
Private Function fnClose CDecl(ByVal hf As LongPtr, ErrNo As Long, ByVal pv As LongPtr) As Long
If hf = fh Or hf = fh_cab Then ' If you need to close a file that is being added to the archive, or you need to close the archive file itself
CloseHandle hf
End If
fnClose = 0
End Function
' 9. Deleting a temporary file (stream)
' Delphi: function fnDelete(pszFile: PAnsiChar; err: PInteger; pv: Pointer): Integer; cdecl;
Private Function fnDelete CDecl(ByVal pszFile As LongPtr, ErrNo As Long, ByVal pv As LongPtr) As Long
Dim ptr As LongPtr
CopyMemory VarPtr(ptr), pszFile, LenB(ptr)
IStream_Release ptr
fnDelete = 0
End Function
' 10. It is called every time a new file is added to the archive
' Delphi: function fnFilePlaced(var ccab: TCCAB; pszFile: PAnsiChar; cbFile: Longint; fContinuation: BOOL; pv: Pointer): THandle; cdecl;
Private Function fnFilePlaced CDecl(ccab As TCCAB, ByVal pszFile As String, ByVal FileSize As Long, ByVal fContinuation As BOOL, ByVal pv As LongPtr) As Long
' Here you can get useful data:
' 1. FileSize
' 2. StrConv(ccab.szCabPath, vbUnicode)
' 3. StrConv(ccab.szCab, vbUnicode)
fnFilePlaced = 0
End Function
' --- FCICreate CallBack's ---
' +++ FCIAddFile CallBack's +++
' 11. Setting the file attributes
' Delphi: function fnOpenInfo(pszName: PAnsiChar; var pDate: WORD; var pTime: WORD; var pAttrib: WORD; err: PInteger; pv: Pointer): Integer; cdecl;
' Syntax C++
' ;; void FNFCIGETOPENINFO(
' ;; [in] LPSTR pszName,
' ;; USHORT *pdate,
' ;; USHORT *ptime,
' ;; USHORT *pattribs,
' ;; int FAR *err,
' ;; void FAR *pv
' ;; );
Private Function fnOpenInfo CDecl(ByVal pszName As String, pDate As Integer, pTime As Integer, pAttribs As Integer, ErrNo As Long, ByVal pv As LongPtr) As LongPtr
Dim LocalTime As FILETIME
Dim CreationTime As FILETIME
Dim LastAccessTime As FILETIME
Dim LastWriteTime As FILETIME
If StrConv(pszName, vbUnicode) <> SourceIStream Then
pAttribs = GetFileAttributes(StrPtr(pszName))
fh = CreateFileA(StrPtr(pszName), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If fh <> INVALID_HANDLE_VALUE Then
GetFileTime fh, CreationTime, LastAccessTime, LastWriteTime
FileTimeToLocalFileTime LastWriteTime, LocalTime
FileTimeToDosDateTime LocalTime, pDate, pTime
fnOpenInfo = fh
Else
ErrNo = Err.LastDllError
fnOpenInfo = -1
End If
Else
fnOpenInfo = SourceIStream
End If
End Function
' 12. It is called at several stages of file processing: block compression, adding a compressed block and writing an archive
' Delphi: function fnStatus(typeStatus: UINT; cb1, cb2: ULONG; pv: Pointer): Longint; cdecl;
Private Function fnStatus CDecl(ByVal typeStatus As Long, ByVal cb1 As Long, ByVal cb2 As Long, ByVal pv As LongPtr) As Long
fnStatus = 0
End Function
' 13. Called before creating a new archive volume
' Delphi: function fnGetNextCabinet(var ccab: TCCAB; cbPrevCab: ULONG; pv: Pointer): BOOL; cdecl;
Private Function fnGetNextCabinet CDecl(ccab As TCCAB, ByVal cbPrevCab As Long, ByVal pv As LongPtr) As BOOL
fnGetNextCabinet = 0
End Function
' --- FCIAddFile CallBack's ---
' A universal function for compressing files into a CAB archive or for compressing buffers
' The function takes as parameters:
' CabinetDestination - this is the full file name of the future CAB archive, either a byte array or an IStream stream
' SourceFullFileNamesOrBuffer - string (if there is one file) or an array of strings (if it is a list of files to compress) or a buffer (an Istream stream or a byte array)
' DestFileNames - this is an optional parameter. This string is the path and file name inside the CAB archive, or an array of strings is a list of files inside the CAB archive
Public Function CabinetAddFiles(CabinetDestination As Variant, SourceFullFileNamesOrBuffer As Variant, Optional DestFileNames As Variant, Optional CompressionMethod As cabCompressionMethod = cm_LZX21) As Boolean
Dim ccab As TCCAB
Dim erf As TERF
Dim fci As LongPtr
Dim CabinetName As String
Dim CabinetPath As String
Dim AnsiSourceFileName As String
Dim AnsiExtractFileName As String
Dim AnsiDestinationFileName As String
Dim AnsiSourceFullFileNames() As String
Dim AnsiDestFileNames() As String
Dim DestFileNamesArrayInitialized As Boolean
Dim ByteArray() As Byte
Dim i As Long
If VarType(CabinetDestination) = vbString Then
If Len(CabinetDestination) = 0 Then Exit Function
ElseIf VarType(CabinetDestination) = vbLong Or VarType(CabinetDestination) = 20 Then ' Or VarType = LongPtr
If CabinetDestination = 0 Then Exit Function
End If
If VarType(SourceFullFileNamesOrBuffer) = vbArray + vbString Then ' If it is an array of strings
If CabinetIsArrayInitialized(SourceFullFileNamesOrBuffer) = True Then ' If the array is initialized
For i = 0 To UBound(SourceFullFileNamesOrBuffer)
AnsiSourceFileName = StrConv(SourceFullFileNamesOrBuffer(i), vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for compressing
Exit Function
End If
' We copy the array, only the destination array will contain the filenames in ANSI encoding
CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName
Next
Else
Exit Function
End If
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbString Then ' If it is a string
If SourceFullFileNamesOrBuffer <> vbNullString Then
AnsiSourceFileName = StrConv(SourceFullFileNamesOrBuffer, vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for compressing
Exit Function
End If
CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName ' There will be only one row in the array
Else ' String not be empty
Exit Function
End If
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbLong Or VarType(SourceFullFileNamesOrBuffer) = 20 Then ' Or VarType = LongPtr
SourceIStream = SourceFullFileNamesOrBuffer ' Remember the original IStream
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbDataObject Then ' If it is an object
SourceIStream = ObjPtr(SourceFullFileNamesOrBuffer) ' Remember the original IStream
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbArray + vbByte Then ' If it is a byte array
If CabinetIsArrayInitialized(SourceFullFileNamesOrBuffer) = True Then ' If the array is initialized
ByteArray = SourceFullFileNamesOrBuffer
SourceIStream = SHCreateMemStream(VarPtr(ByteArray(0)), UBound(ByteArray) + 1)
Else
Exit Function ' The byte array of the source data for packaging must be initialized
End If
Else ' Data type error
Exit Function
End If
If SourceIStream = 0 Then
If VarType(DestFileNames) = vbArray + vbString Then ' If it is an array of strings
If CabinetIsArrayInitialized(SourceFullFileNamesOrBuffer) = True Then ' If the array is initialized
If UBound(SourceFullFileNamesOrBuffer) <> UBound(DestFileNames) Then Exit Function ' The boundaries of the arrays do not match
For i = 0 To UBound(DestFileNames)
AnsiDestinationFileName = StrConv(DestFileNames(i), vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiDestinationFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for compressing
Exit Function
End If
' We copy the array, only the destination array will contain the filenames in ANSI encoding
CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName
Next
DestFileNamesArrayInitialized = True
End If
ElseIf VarType(DestFileNames) = vbString Then
If DestFileNames <> vbNullString Then
AnsiDestinationFileName = StrConv(DestFileNames, vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiDestinationFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for compressing
Exit Function
End If
CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName ' There will be only one row in the array
DestFileNamesArrayInitialized = True
End If
End If
End If
If VarType(CabinetDestination) = vbString Then
' First of all, you need to take the FullFileName of the future archive and extract the folder path and file name from it
CabinetName = StrConv(CabinetExtractFileName(CabinetDestination), vbFromUnicode) ' Convert to ANSI
CabinetPath = StrConv(CabinetExtractFilePath(CabinetDestination), vbFromUnicode) ' Convert to ANSI
End If
' Define structure values (rewriting from MSDN: https://learn.microsoft.com/ru-ru/windows/win32/devnotes/creating-a-cabinet)
ccab.cb = &H7FFFFFFF ' The maximum size of the archive to be created will be 2 GB (we will increase it by a maximum compared to the example from MSDN)
ccab.cbFolderThresh = &H7FFFFFFF ' Important! If this is not written, then the old versions of the CAB archivers will read the archive incorrectly
ccab.setID = 555
ccab.iCab = 1
ccab.iDisk = 0
If VarType(CabinetDestination) = vbString Then
CopyMemory VarPtr(ccab.setID) + 2 + 256, StrPtr(CabinetName), LenB(CabinetName) ' ccab.szCab = CabinetName
CopyMemory VarPtr(ccab.setID) + 2 + 512, StrPtr(CabinetPath), LenB(CabinetPath) ' ccab.szCabPath = CabinetPath
cabFileName = CabinetDestination ' Remember the FileName of the future archive
ElseIf VarType(CabinetDestination) = vbLong Or VarType(CabinetDestination) = 20 Then ' Or VarType = LongPtr
' If it is an IStream stream and not a FileName
cabIStream = CabinetDestination ' Memorize the IStream of the future archive
ElseIf VarType(CabinetDestination) = vbDataObject Then
cabIStream = ObjPtr(CabinetDestination) ' Memorize the IStream of the future archive
ElseIf VarType(CabinetDestination) = vbArray + vbByte Then ' If it is a byte array
cabIStream = SHCreateMemStream(0, 0) ' Create a new IStream for a byte array
Else ' Data type error
Exit Function
End If
fci = FCICreate(erf, AddressOf fnFilePlaced, AddressOf fnAlloc, AddressOf fnFree, AddressOf fnOpen, AddressOf fnRead, AddressOf fnWrite, AddressOf fnClose, AddressOf fnSeek, AddressOf fnDelete, AddressOf fnFciGTF, VarPtr(ccab))
If fci <> 0 Then
If SourceIStream = 0 Then
For i = 0 To UBound(AnsiSourceFullFileNames)
AnsiSourceFileName = AnsiSourceFullFileNames(i)
If DestFileNamesArrayInitialized = True Then
AnsiExtractFileName = AnsiDestFileNames(i)
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbArray + vbString Then ' If it is an array of strings
AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNamesOrBuffer(i)), vbFromUnicode) ' Convert to ANSI
ElseIf VarType(SourceFullFileNamesOrBuffer) = vbString Then ' If it is a string
AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNamesOrBuffer), vbFromUnicode) ' Convert to ANSI
End If
FCIAddFile fci, StrPtr(AnsiSourceFileName), StrPtr(AnsiExtractFileName), 0, AddressOf fnGetNextCabinet, AddressOf fnStatus, AddressOf fnOpenInfo, CompressionMethod
Next
Else
AnsiSourceFileName = StrConv(SourceIStream, vbFromUnicode)
AnsiExtractFileName = StrConv(SourceIStream, vbFromUnicode)
FCIAddFile fci, StrPtr(AnsiSourceFileName), StrPtr(AnsiExtractFileName), 0, AddressOf fnGetNextCabinet, AddressOf fnStatus, AddressOf fnOpenInfo, CompressionMethod
End If
If FCIFlushCabinet(fci, cFalse, AddressOf fnGetNextCabinet, AddressOf fnStatus) = cTrue Then
CabinetAddFiles = True
If IsArray(CabinetDestination) = True Then
ByteArray = CabinetDestination
IStream2ByteArray cabIStream, ByteArray, True
CabinetDestination = ByteArray
End If
End If
FCIDestroy fci
If CabinetAddFiles <> True And IsArray(CabinetDestination) = True Then IStream_Release cabIStream
If VarType(SourceFullFileNamesOrBuffer) = vbArray + vbByte Then IStream_Release SourceIStream
End If
' Be sure to clear the memory
cabFileName = vbNullString
SourceIStream = 0
cabIStream = 0
fh_cab = 0
fh = 0
End Function
' Convert the full cabinet path to a file name
Public Function CabinetExtractFileName(ByVal FileName As String) As String
Dim lNullPos As Long
Dim pszPath As String
pszPath = FileName
PathStripPathW StrPtr(pszPath)
lNullPos = InStr(1, pszPath, vbNullChar)
If lNullPos Then
CabinetExtractFileName = Left$(pszPath, lNullPos - 1)
Else
CabinetExtractFileName = FileName
End If
End Function
' Convert the full cabinet path to the folder path (always returns "\" at the end)
Public Function CabinetExtractFilePath(ByVal FileName As String) As String
Dim lNullPos As Long
Dim pszPath As String
pszPath = FileName
PathRemoveFileSpecW StrPtr(pszPath)
lNullPos = InStr(1, pszPath, vbNullChar)
If lNullPos Then
pszPath = Left$(pszPath, lNullPos - 1)
If Right$(pszPath, 1) <> "\" Then pszPath = pszPath & "\"
CabinetExtractFilePath = pszPath
Else
CabinetExtractFilePath = FileName
End If
End Function
' Add a string to the array, regardless of whether it has been initialized
Public Sub CabinetInsertArrayString(ByRef strArr() As String, ByVal InsertString As String)
Dim NewIndex As Long
If CabinetIsArrayInitialized(strArr) = False Then
ReDim strArr(0)
strArr(0) = InsertString
Else
NewIndex = UBound(strArr) + 1
ReDim Preserve strArr(NewIndex)
strArr(NewIndex) = InsertString
End If
End Sub
' Is the array initialized
Public Function CabinetIsArrayInitialized(arr) As Boolean
Dim saAddress As LongPtr
GetMemPtr VarPtr(arr) + 8, saAddress
GetMemPtr saAddress, saAddress
CabinetIsArrayInitialized = (saAddress <> 0)
If CabinetIsArrayInitialized Then CabinetIsArrayInitialized = UBound(arr) >= LBound(arr)
End Function
Reply With Quote
