-
[RESOLVED] The CAB Archive packaging module
I suggested that you write code to packing CAB files. It was very difficult, but I wrote such a module anyway. You just need to understand that in order for the module to work in full, you need to use TwinBasic or you need to connect the CDeclFix add-on from The Trick.
Last update (2025-01-09): https://www.vbforums.com/showthread....=1#post5668210
The beginning of the first part of the module:
Code:
Option Explicit
'////////////////////////////////////////////
'// The CAB Archive packaging module //
'// Copyright (c) 21.11.2024 by HackerVlad //
'// e-mail: [email protected] //
'// Version 1.2 //
'////////////////////////////////////////////
' API declarations ...
Private Declare Function FCICreate CDecl Lib "cabinet.dll" (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.dll" (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.dll" (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.dll" (ByVal hfci As Long) As BOOL
Private Declare Function SHCreateMemStream Lib "shlwapi.dll" Alias "#12" (ByVal pInit As Long, ByVal cbInit As Long) As Long
Private Declare Function PathStripPathW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
Private Declare Function PathRemoveFileSpecW Lib "shlwapi.dll" (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 OpenFile Lib "kernel32" (ByVal lpFileName As Long, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
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 GetMem4 Lib "msvbvm60" (ByVal Addr As Long, ByRef dstValue As Long) As Long
' 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 As Long = -1
Private Const CREATE_ALWAYS = 2
Private Const MAX_PATH As Long = 260
Private Const tcompTYPE_MSZIP = &H1&
Private Const tcompTYPE_LZX = &H3& ' 0x0003
Private Const tcompLZX_WINDOW_LO = &HF00& ' 0x0F00
Private Const tcompLZX_WINDOW_HI = &H1500& ' 0x1500
' 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
' Variables for temporary data storage ...
Dim fh As Long
Dim fh_cab As Long
Dim cabFileName As String
' Enums ...
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
' For compatibility with TwinBasic and VBA7
#If (VBA7 <> 0) Or (TWINBASIC <> 0) Then
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
#Else
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
#End If
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 Long, ByVal pv As Long, 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 Long, ByVal pv As Long, 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 Long, 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 Long)
DispCallByVtbl ptrIStream, 2
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 Long
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(ByRef pszTempName As Long, ByVal cbTempName As Long, ByVal pv As Long) 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 Long
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
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(ByRef pszFile As Long, ByVal oFlag As Long, ByVal pMode As Long, ByRef ErrNo As Long, ByVal pv As Long) As Long
If oFlag <> &H8302& Then ' Hack
fnOpen = pszFile
Else
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
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 Long, ByVal hMemory As Long, ByVal cbSize As Long, ByRef ErrNo As Long, ByVal pv As Long) 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 a temporary IStream 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 Long, ByVal hMemory As Long, ByVal cbSize As Long, ByRef ErrNo As Long, ByVal pv As Long) 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 a temporary IStream stream is 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 Long)
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 Long, ByVal dist As Long, ByVal seektype As Long, ByRef ErrNo As Long, pv As Long) 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 ' Positioning of the "temporary file" that is, the stream
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 Long, ErrNo As Long, pv As Long) 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(ByRef pszFile As Long, ErrNo As Long, pv As Long) As Long
IStream_Release pszFile
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 Long) 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 Long) As Long
Dim LocalTime As FILETIME
Dim CreationTime As FILETIME
Dim LastAccessTime As FILETIME
Dim LastWriteTime As FILETIME
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
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 Long) 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 Long) As BOOL
fnGetNextCabinet = 0
End Function
' --- FCIAddFile CallBack's ---
' To pack files into a CAB archive
' The function accepts as parameters SourceFullFileNames, DestFileNames a string (if there is one file) or an array of strings (a list of files)
' DestFileNames - this is an optional parameter, it is the path and file name inside the CAB archive
Public Function CabinetAddFiles(ByVal CabinetFullFileName As String, SourceFullFileNames 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 Long
Dim CabinetDisk As String
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 i As Long
If Len(CabinetFullFileName) = 0 Then Exit Function
If IsArray(SourceFullFileNames) Then ' If it is an array
If CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' If the array is initialized
For i = 0 To UBound(SourceFullFileNames)
AnsiSourceFileName = StrConv(SourceFullFileNames(i), vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for packaging
Exit Function
End If
' We copy the array, only the resulting array will contain the file names in ANSI encoding
CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName
Next
Else
Exit Function
End If
Else
If VarType(SourceFullFileNames) = vbString Then
If SourceFullFileNames <> vbNullString Then
AnsiSourceFileName = StrConv(SourceFullFileNames, vbFromUnicode) ' Convert to ANSI
If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
' Cabinet.dll does not support unicode file names for packaging
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
Else ' Data type error (not an array or a string)
Exit Function
End If
End If
If IsArray(DestFileNames) Then
If CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' If the array is initialized
If UBound(SourceFullFileNames) <> 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 packaging
Exit Function
End If
' We copy the array, only the resulting array will contain the file names in ANSI encoding
CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName
Next
DestFileNamesArrayInitialized = True
End If
Else
If 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 packaging
Exit Function
End If
CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName ' There will be only one row in the array
DestFileNamesArrayInitialized = True
End If
End If
End If
' 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(CabinetFullFileName), vbFromUnicode) ' Convert to ANSI
CabinetPath = StrConv(CabinetExtractFilePath(CabinetFullFileName), vbFromUnicode) ' Convert to ANSI
' Define structure values
ccab.cb = &H7FFFFFFF ' The maximum size, in bytes, of a cabinet created by FCI
ccab.iDisk = 1
CabinetDisk = StrConv("DISK1", vbFromUnicode) ' I do not know why, but it is necessary to write "DISK1"
CopyMemory VarPtr(ccab.setID) + 2, StrPtr(CabinetDisk), LenB(CabinetDisk) ' ccab.szDisk = CabinetDisk
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 = CabinetFullFileName ' Remember the FileName of the future archive
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
For i = 0 To UBound(AnsiSourceFullFileNames)
AnsiSourceFileName = AnsiSourceFullFileNames(i)
If DestFileNamesArrayInitialized = True Then
AnsiExtractFileName = AnsiDestFileNames(i)
Else
If IsArray(SourceFullFileNames) Then ' If it is an array
AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNames(i)), vbFromUnicode) ' Convert to ANSI
Else
AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNames), vbFromUnicode) ' Convert to ANSI
End If
End If
FCIAddFile fci, StrPtr(AnsiSourceFileName), StrPtr(AnsiExtractFileName), 0, AddressOf fnGetNextCabinet, AddressOf fnStatus, AddressOf fnOpenInfo, CompressionMethod
Next
If FCIFlushCabinet(fci, cFalse, AddressOf fnGetNextCabinet, AddressOf fnStatus) = cTrue Then
CabinetAddFiles = True
End If
FCIDestroy fci
End If
cabFileName = vbNullString
End Function
-
Re: The CAB Archive packaging module
The beginning of the second part of the module:
Code:
' 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 Long
GetMem4 VarPtr(arr) + 8, saAddress
GetMem4 saAddress, saAddress
CabinetIsArrayInitialized = (saAddress <> 0)
If CabinetIsArrayInitialized Then CabinetIsArrayInitialized = UBound(arr) >= LBound(arr)
End Function
-
1 Attachment(s)
Re: The CAB Archive packaging module
You'd better download the module file right away
-
1 Attachment(s)
Re: The CAB Archive packaging module
-
1 Attachment(s)
Re: The CAB Archive packaging module
After you download the sample program for this module, you will have such a window-the program.
-
Re: The CAB Archive packaging module
Unfortunately, there are limits on the number of megabytes of uploaded file on this forum. That's why I can't even upload the full version of my program to this forum. Therefore, I have to give you a link to the Russian forum (there are no such restrictions and everything is there): https://www.cyberforum.ru/visual-bas...l#post17493673
-
Re: The CAB Archive packaging module
-
2 Attachment(s)
Re: The CAB Archive packaging module
Today I fixed some bugs in my module. Here is a new version 1.3 of the CAB archive compressing project on VB6 and on Twin Basic.
-
Re: The CAB Archive packaging module
Not sure how this is creating valid files when you're passing Unicode to ANSI functions... I know GetFileAttributes is failing; does CreateFileA have some mechanism that's detecting the error? Have to look further into it.
-
Re: The CAB Archive packaging module
I am not passing unicode to the ANSI functions.
I'm only passing ANSI strings to the API functions. Except for creating the archive file itself (CreateFileW). I've been working on this code for many, many days. Everything works correctly there, don't even doubt it.
And the GetFileAttributes function also receives ANSI string. Read my code more carefully and you will understand.
-
Re: The CAB Archive packaging module
My bad, was tripped up by the unusual arrangement of using StrPtr on an ANSI LPSTR put in the memory of a BSTR (it's would be missing the length prefix so anything non-API would break).
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
fafalone
My bad, was tripped up by the unusual arrangement of using StrPtr on an ANSI LPSTR put in the memory of a BSTR (it's would be missing the length prefix so anything non-API would break).
To be honest, this is the first time I've applied StrPtr to an ANSI function. It can really be confusing. But it's necessary there.
-
Re: The CAB Archive packaging module
Could just declare pszName as Long then skip the StrPtr.
One minor issue is PathSkipPathW should def be a Sub though... Might sometimes get away with it in x86 but I was gonna make the tB version support x64 too :bigyello:
Great work.
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
fafalone
Could just declare pszName as Long then skip the StrPtr.
One minor issue is PathSkipPathW should def be a Sub though... Might sometimes get away with it in x86 but I was gonna make the tB version support x64 too :bigyello:
Great work.
Thank you. If you want, you can change this module yourself for 64-bit compatibility. I did not do this because I am quite satisfied with 32 bits.
Is it really necessary to check the return value of PathStripPathW? Everything works there anyway. Or do you think it's possible to write there in some other way?
-
1 Attachment(s)
Re: The CAB Archive packaging module
PathStripPathW has no return value (LWSTDAPI_(void)); it's currently declared as a Function returning a Long but should be a Sub.
Notes from x64:
-Seek/close/delete should have ByVal pv As Long(Ptr) like the others; it's fine in x86 because a pointer and a Long are the same size, but in x64 it risks trying to copy 8 bytes into 4.
-Some of the hacks you used drove me a little nuts... the ByRef IStream thing; I altered it a little so the callback signatures didn't differ from the documentation.
-In your DispCallFuncVtbl, you have #If (VBA7 <> 0) Or (TWINBASIC <> 0) Then... since tB is fully compatible with VBA7 syntax (LongPtr/PtrSafe/LongLong), you only need to check one for that... in tB, VBA7 is also true.
So here it is, an x64 compatible version. Just the twinproj here but the code should be fine in VB6 as well since I just added a conditional compilation block for PtrSafe APIs.
-
Re: The CAB Archive packaging module
Thank you for your work, but have you checked the 64-bit version in the EXE executable? It doesn't work for me for some reason. It works only through the IDE, starting via F5.
-
1 Attachment(s)
Re: The CAB Archive packaging module
I didn't pay attention to this, but it turns out that in my code, even before you changed everything to 64, the execution of the program in EXE did not work initially, even in my 32-bit version, if compiled via Twin Basic. I don't know why...
And if you compile this project via VB6, then everything works. Strangely, I think it has to do with the DispCallFunc call...
-
Re: The CAB Archive packaging module
Hmm I'll take a look when I get home later but if it's working in tB IDE (it was for me) and not compiled probably a bug for Wayne.
-
Re: The CAB Archive packaging module
I cannot reproduce on Windows 10 with either your original version or my port (both 32 and 64bit); compiled works fine.
What version OS, and have you been doing clean installs of new tB versions? Some very odd bugs have been tracked to not deleting all the old files or using a new folder when updating IDE versions.
-
1 Attachment(s)
Re: The CAB Archive packaging module
Quote:
Originally Posted by
fafalone
I cannot reproduce on Windows 10 with either your original version or my port (both 32 and 64bit); compiled works fine.
What version OS, and have you been doing clean installs of new tB versions? Some very odd bugs have been tracked to not deleting all the old files or using a new folder when updating IDE versions.
Yes, I have Windows 7, but I don't think it's about the system. To reproduce the problems, you not only need to just take and run the EXE, but also you need to start the program by calling the CabinetAddFiles function, to do this, click on one of these buttons in the picture.
-
Re: The CAB Archive packaging module
I will even attach my compiled EXE file just in case, run it and you will see for yourself that the program does not work if you click on the specified buttons to package the CAB.
I also asked my friend to test this on another computer (he has Windows 8), he gets exactly the same error. Moreover, as I found out, this is not related to DispCallFunc.
-
Re: The CAB Archive packaging module
So this is a TwinBasic bugs. We need to deal with this and send a bug report.
-
1 Attachment(s)
Re: The CAB Archive packaging module
The most amazing thing is that in version 1.0 of my module everything works fine, even in the EXE compiled in Twin Basic.
Download the archive and take a look. But I still couldn't figure out why the new version of my module has already stopped working in the EXE compiled on Twin.
-
Re: The CAB Archive packaging module
fafalone, is there a built-in function in TwinBasic to check if the array is initialized?
-
Re: The CAB Archive packaging module
Yes I ran those two tests, worked fine in Windows 10. Did you test on Windows 10?
I am able to reproduce the bug on Windows 7.
It's a tB bug since tB is meant to support Windows 7 and 8 (and XP; 2000 is planned but currently not working due to bug. Win95/98/NT4 and earlier will not be supported), but it's important for the bug report to know what OS is impacted by the bug. I posted a report on the tB Discord.
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
HackerVlad
fafalone, is there a built-in function in TwinBasic to check if the array is initialized?
I don't think so but the same methods you use in VB6 should work. Even if they use an ArrPtr variant of VarPtr in the code because that msvbvm60 call is redirected to an internal implementation (but the built in way for that is to use VarPtr, which in tB supports arrays natively).
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
fafalone
Yes I ran those two tests, worked fine in Windows 10. Did you test on Windows 10?
I am able to reproduce the bug on Windows 7.
It's a tB bug since tB is meant to support Windows 7 and 8 (and XP; 2000 is planned but currently not working due to bug. Win95/98/NT4 and earlier will not be supported), but it's important for the bug report to know what OS is impacted by the bug. I posted a report on the tB Discord.
Yes, I told you that I have Windows 7, unfortunately I do not have Windows 10 on my computer and therefore I cannot check...
My friend has Windows 8 and my EXE doesn't work for him either. I haven't personally checked on Windows 10 myself, but it works for you, you say.
Please tell me, will EXE programs written in Twin Basic not run in Windows XP at all?
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
fafalone
I don't think so but the same methods you use in VB6 should work. Even if they use an ArrPtr variant of VarPtr in the code because that msvbvm60 call is redirected to an internal implementation (but the built in way for that is to use VarPtr, which in tB supports arrays natively).
You know, it turns out there is such a built-in function! A friend told me that it is called "IsArrayInitialized"!
-
Re: The CAB Archive packaging module
fafalone, do you have Windows 7 or Windows 8? To check the operation of the EXE
-
1 Attachment(s)
Re: The CAB Archive packaging module
Quote:
Originally Posted by
HackerVlad
You know, it turns out there is such a built-in function! A friend told me that it is called "IsArrayInitialized"!
Oh yeah forgot about that lol. tB has so many new features even Wayne forgets about some.
Quote:
Please tell me, will EXE programs written in Twin Basic not run in Windows XP at all?
They should run in XP yes, and AFAIK they do (but the IDE itself requires Vista+).
Ironically, I tested your program on XP and it worked without error. So only 7-8 seems impacted.
Attachment 193563
Quote:
fafalone, do you have Windows 7 or Windows 8? To check the operation of the EXE
Yes like I said I was able to reproduce the issue (i.e. got the same error message) in Windows 7; I tested it in a Win7 VM this morning.
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
HackerVlad
You know, it turns out there is such a built-in function! A friend told me that it is called "IsArrayInitialized"!
IsArrayInitialized is going to be very useful. The other ways I tried using NOT NOT or something in VB6 had dire consequences...
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
yereverluvinuncleber
IsArrayInitialized is going to be very useful. The other ways I tried using NOT NOT or something in VB6 had dire consequences...
If it didn't work make sure to report it... I thought the Not Not trick worked, might be a regression.
-
Re: The CAB Archive packaging module
This is exactly what "Not Not" was trying to accomplish and messing up the VB6 IDE in the process:
Code:
Private Function IsArrayInitialized(ByVal pSA As LongPtr) As Boolean
CopyMemory pSA, ByVal pSA, LenB(pSA)
IsArrayInitialized = pSA <> 0
End Function
Debug.Print IsArrayInitialized(ArrPtr(baData))
Probably tB does the same thing under the hood.
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
yereverluvinuncleber
IsArrayInitialized is going to be very useful. The other ways I tried using NOT NOT or something in VB6 had dire consequences...
The easiest way to check if an array is initialized in vb6 is to use the SafeArrayGetDim function
Code:
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (arr() As Any) As Long
If SafeArrayGetDim(lngArr) > 0 Then ' If the array is initialized
However, you should not use this function on very large arrays with a large amount of data, since this API function will read the entire array and load it into memory for verification, with the exception of UDT arrays. UDT arrays can be safely checked with this function, even if you have huge giant data in the array.
-
Re: The CAB Archive packaging module
I haven't tried the NOT NOT trick in TB, only in VB6, it now scares me. I am happy to use IsArrayInitialized and give that a go.
-
Re: The CAB Archive packaging module
IsArrayInitialized I personally have already tried it in Twin Basic, this built-in function works fine there.
For vb6, this function will look like this (I used it in my module under the name CabinetIsArrayInitialized)
Code:
' Is the array initialized
Public Function IsArrayInitialized(arr) As Boolean
Dim saAddress As Long
GetMem4 VarPtr(arr) + 8, saAddress
GetMem4 saAddress, saAddress
IsArrayInitialized = (saAddress <> 0)
If IsArrayInitialized Then IsArrayInitialized = UBound(arr) >= LBound(arr)
End Function
I have never used the trick NOT NOT because of the known problems associated with it.
I have always used either the SafeArrayGetDim API-function or the self-written IsArrayInitializedfunction.
-
Re: The CAB Archive packaging module
Code:
#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
' Is the array initialized
Public Function IsArrayInitialized(arr) As Boolean
Dim saAddress As LongPtr
GetMemPtr VarPtr(arr) + 8, saAddress
GetMemPtr saAddress, saAddress
IsArrayInitialized = (saAddress <> 0)
If IsArrayInitialized Then IsArrayInitialized = UBound(arr) >= LBound(arr)
End Function
ftfy :wave:
-
Re: The CAB Archive packaging module
In Twin Basic, in my opinion, you should write like this. All GetMem functions are built in there.
Code:
Public DeclareWide PtrSafe Sub GetMemPtr Lib "<hiddenmodule>" Alias "#7" (ByVal Address As LongPtr, ByRef retVal As LongPtr)
-
Re: The CAB Archive packaging module
fafalone, have you sent a bug report that the program does not work in Windows 7?
I didn't find something here: https://github.com/twinbasic/twinbasic/issues
Could you drop the link?
-
Re: The CAB Archive packaging module
Quote:
Originally Posted by
HackerVlad
In Twin Basic, in my opinion, you should write like this. All GetMem functions are built in there.
Code:
Public DeclareWide PtrSafe Sub GetMemPtr Lib "<hiddenmodule>" Alias "#7" (ByVal Address As LongPtr, ByRef retVal As LongPtr)
For the built in ones you don't even need a declaration. Only need your own declaration if you need to alter the signature.
---
I posted on the tB Discord bugs channel: https://discord.com/channels/9276381...61549574656001
-
Re: The CAB Archive packaging module
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.
-
Re: The CAB Archive packaging module
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.
-
Re: The CAB Archive packaging module
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.
-
Re: The CAB Archive packaging module
fafalone, please replace all the lines "cabinet.dll " on "cabinet", to fix errors
-
1 Attachment(s)
Re: [RESOLVED] The CAB Archive packaging module
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):
-
Re: [RESOLVED] The CAB Archive packaging module
The beginning of the first part of the module:
Code:
Option Explicit
'////////////////////////////////////////////
'// Module for compressing CAB archives //
'// Copyright (c) 2025-01-09 by HackerVlad //
'// e-mail: [email protected] //
'// 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 ---
-
Re: [RESOLVED] The CAB Archive packaging module
The beginning of the second part of the module:
Code:
' +++ 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
The module should have 690 (691) lines.
