Создание (+распаковка) CAB архива

Public Function CabinetAddFiles(ByVal CabinetFullFileName As String, SourceFullFileNames As Variant, Optional DestFileNames As Variant, Optional CompressionMethod As cabCompressionMethod = cm_LZX21) As Boolean
    On Error GoTo errHdr
    Dim lErr&
    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 i As Long
    lErr = 1
    If Len(CabinetFullFileName) = 0 Then Exit Function
    lErr = 2
    If IsArray(SourceFullFileNames) Then ' If it is an array
        lErr = 3
        If CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' If the array is initialized
            lErr = 4
            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
                5:
                CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName
            Next
        Else
            Exit Function
        End If
    Else
        lErr = 6
        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
                lErr = 7
                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
    lErr = 8
        If CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' If the array is initialized
            lErr = 9
            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
                10:
                ' 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
                lErr = 10
                CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName ' There will be only one row in the array
                DestFileNamesArrayInitialized = True
            End If
        End If
    End If
    lErr = 11
    ' 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
    lErr = 12
    CabinetPath = StrConv(CabinetExtractFilePath(CabinetFullFileName), vbFromUnicode) ' Convert to ANSI
    
    ' Define structure values (rewriting from MSDN: https://learn.microsoft.com/ru-ru/windows/win32/devnotes/creating-a-cabinet)
    ccab.cb = &H7FFFFFFF ' The maximum size, in bytes, of a cabinet created by FCI
    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
    lErr = 13
    CopyMemory VarPtr(ccab.setID) + 2 + 256, StrPtr(CabinetName), LenB(CabinetName) ' ccab.szCab = CabinetName
    lErr = 14
    CopyMemory VarPtr(ccab.setID) + 2 + 512, StrPtr(CabinetPath), LenB(CabinetPath) ' ccab.szCabPath = CabinetPath
    cabFileName = CabinetFullFileName ' Remember the FileName of the future archive
    lErr = 15
    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)
            lErr = 16
            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
            lErr = 17
            FCIAddFile fci, _
                       StrPtr(AnsiSourceFileName), _
                       StrPtr(AnsiExtractFileName), _
                       0, _
                       AddressOf fnGetNextCabinet, _
                       AddressOf fnStatus, _
                       AddressOf fnOpenInfo, _
                       CompressionMethod
        Next
        lErr = 18
        If FCIFlushCabinet(fci, cFalse, AddressOf fnGetNextCabinet, AddressOf fnStatus) = cTrue Then
            CabinetAddFiles = True
        End If
        lErr = 19
        FCIDestroy fci
    End If
    
    cabFileName = vbNullString
Exit Function
ErrHdr:
    MsgBox "Ошибка в функции: CabinetAddFiles" & vbCr & Err.Description & vbCr & "Строка: " & lErr 'Erl
End Function