[RESOLVED] The CAB Archive packaging module

[HackerVlad]

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:

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

[HackerVlad]

The beginning of the second part of the module:

' 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

[HackerVlad]

You'd better download the module file right away

[HackerVlad]

7Z archive

[HackerVlad]

After you download the sample program for this module, you will have such a window-the program.

[HackerVlad]

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

[yokesee]

good job

[HackerVlad]

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.

[fafalone]

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.

[HackerVlad]

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.

[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).

[HackerVlad]

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.

[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

Great work.

[HackerVlad]

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

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?

[fafalone]

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.

[HackerVlad]

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.

[HackerVlad]

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...

[fafalone]

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.

[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.

[HackerVlad]

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.

[HackerVlad]

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.

[HackerVlad]

So this is a TwinBasic bugs. We need to deal with this and send a bug report.

[HackerVlad]

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.

[HackerVlad]

fafalone, is there a built-in function in TwinBasic to check if the array is initialized?

[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.

[fafalone]

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).

[HackerVlad]

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?

[HackerVlad]

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"!

[HackerVlad]

fafalone, do you have Windows 7 or Windows 8? To check the operation of the EXE

[fafalone]

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.

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.

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.

[yereverluvinuncleber]

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...

[fafalone]

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.

[VanGoghGaming]

This is exactly what "Not Not" was trying to accomplish and messing up the VB6 IDE in the process:

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.

[HackerVlad]

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

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.

[yereverluvinuncleber]

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.

[HackerVlad]

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)

' 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.

[fafalone]

    #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

[HackerVlad]

In Twin Basic, in my opinion, you should write like this. All GetMem functions are built in there.

Public DeclareWide PtrSafe Sub GetMemPtr Lib "<hiddenmodule>" Alias "#7" (ByVal Address As LongPtr, ByRef retVal As LongPtr)

[HackerVlad]

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?

[fafalone]

In Twin Basic, in my opinion, you should write like this. All GetMem functions are built in there.

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