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

Private Declare Function ExtractFiles Lib "advpack.dll" Alias "ExtractFilesA" (ByVal CabName As String, ByVal ExpandDir As String, ByVal Flags As Long, ByVal FileList As String, ByVal LReserved As Long, ByVal Reserved As Long) As Long
 
Private Sub Command1_Click()
    ExtractFiles App.Path & "\CabFile1.cab", App.Path, 0, "nemiro.ico", 0, 0 ' Просто здесь пишешь полный путь и имя архива и потом какой файл выдернуть из архива и всё! Вуаля! Всю сложную работу за нас уже давно написали в этой библиотеке advpack.dll
End Sub

Private Sub Command3_Click()
    If ExtractFiles(App.Path & "\CabFile1.cab", App.Path, 0, vbNullString, 0, 0) = 0 Then
        Print "Архив успешно извлечён"
    Else
        Print "Ошибка"
    End If
End Sub

Option Explicit
'////////////////////////////////////////////
'// Модуль для чтения CAB-архивов          //
'// Copyright (c) 11.11.2024 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.0                             //
'////////////////////////////////////////////
 
Private Declare Function SetupIterateCabinet Lib "setupapi" Alias "SetupIterateCabinetA" (ByVal CabinetFile As String, ByVal Reserved As Long, ByVal MsgHandler As Long, ByVal Context As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
 
Private Const MAXPATH = 260
Private Const NO_ERROR = 0
'
' Notification messages, handled in the callback
' procedure. This class doesn't handle them all.
'
Private Const SPFILENOTIFY_FILEINCABINET = &H11
Private Const SPFILENOTIFY_NEEDNEWCABINET = &H12
Private Const SPFILENOTIFY_FILEEXTRACTED = &H13
 
Private Const sicList = 568
Private Const sicCount = 569
 
Dim mstrFileToExtract As String
Dim mstrOutputPath As String
Dim mstrOutputFile As String
Dim mlngCount As Long
Dim mlngcnt As Long
Dim arrListFilesCab() As CabInfo
 
Public Type CabInfo
    cabFileName As String
    cabFileSize As Long
End Type
 
Private Type FileInCabinetInfo
    NameInCabinet As Long
    FileSize      As Long
    Win32Error    As Long
    DosDate       As Integer
    DosTime       As Integer
    DosAttribs    As Integer
    FullTargetName(0 To MAXPATH - 1) As Byte
End Type
 
Private Enum FILEOP
    FILEOP_ABORT = 0
    FILEOP_DOIT = 1
    FILEOP_SKIP = 2
End Enum
 
Private Function CabinetCallback(ByVal Context As Long, ByVal Notification As Long, ByRef Param1 As FileInCabinetInfo, ByVal Param2 As Long) As Long
    Select Case Notification
        Case SPFILENOTIFY_NEEDNEWCABINET
            CabinetCallback = NO_ERROR
            
        Case SPFILENOTIFY_FILEINCABINET
            Select Case Context
                Case sicCount
                    mlngCount = mlngCount + 1
                    CabinetCallback = FILEOP_SKIP
                    
               Case sicList
                    ' Добавить позицию в массив UDT
                    ReDim Preserve arrListFilesCab(mlngcnt)
                    arrListFilesCab(mlngcnt).cabFileName = fStringFromPointer(Param1.NameInCabinet)
                    arrListFilesCab(mlngcnt).cabFileSize = Param1.FileSize
                    mlngcnt = mlngcnt + 1
                    
                    CabinetCallback = FILEOP_SKIP ' Перебирать список файлов дальше
            End Select
    End Select
End Function
 
Private Function fStringFromPointer(ByVal ptr As Long) As String
    Dim lngLen   As Long
    Dim strBuffer As String
    '
    ' Given a string pointer, copy the value
    ' of the string into a new, safe location.
    '
    lngLen = lstrlen(ptr)
    strBuffer = Space$(lngLen)
    
    CopyMemory ByVal strBuffer, ptr, lngLen
    fStringFromPointer = strBuffer
End Function
 
' Получить список файлов внутри архива CAB
Public Function GetFilesListInCab(ByVal FileName As String, arrCabInfo() As CabInfo) As Long
    mlngcnt = 0
    
    If SetupIterateCabinet(FileName, 0, AddressOf CabinetCallback, sicList) Then
        arrCabInfo = arrListFilesCab
        GetFilesListInCab = mlngcnt
        
        Erase arrListFilesCab
    End If
End Function
 
' Узнать количество файлов внутри архива CAB
Public Function GetFilesCountInCab(ByVal FileName As String) As Long
    mlngCount = 0
    
    If SetupIterateCabinet(FileName, 0, AddressOf CabinetCallback, sicCount) Then
        GetFilesCountInCab = mlngCount
    End If
End Function

Option Explicit
Private Declare Function ExtractFiles Lib "advpack.dll" Alias "ExtractFilesA" (ByVal CabName As String, ByVal ExpandDir As String, ByVal Flags As Long, ByVal FileList As String, lpReserved As Any, ByVal Reserved As Long) As Long
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (arr() As Any) As Long
 
Private Sub Command1_Click()
    Dim arrListCab() As CabInfo
    Dim i As Long
    
    If GetFilesListInCab(Text1.Text, arrListCab) > 0 Then
        If SafeArrayGetDim(arrListCab) > 0 Then
            If List1.ListCount > 0 Then List1.Clear
            
            For i = 0 To UBound(arrListCab)
                List1.AddItem arrListCab(i).cabFileName & "    " & arrListCab(i).cabFileSize & " bytes"
            Next
            
            If List1.ListCount > 0 Then
                List1.Selected(0) = True
                List1.SetFocus
                
                Me.Caption = "UnCab 1.0 by HackerVlad    (" & List1.ListCount & " files)"
            End If
        End If
    Else
        Beep ' err
    End If
End Sub
 
Private Sub Command2_Click()
    Dim str As String
    
    str = Left$(List1.Text, InStr(1, List1.Text, "    ") - 1)
    
    If ExtractFiles(Text1.Text, Text2.Text, 0, str, 0, 0) = 0 Then
        Me.Cls
        Print "Файл из архива успешно извлечён"
    Else
        Me.Cls
        Print "Ошибка"
    End If
End Sub
 
Private Sub Command3_Click()
    If ExtractFiles(Text1.Text, Text2.Text, 0, vbNullString, 0, 0) = 0 Then
        Me.Cls
        Print "Архив полностью успешно извлечён"
    Else
        Me.Cls
        Print "Ошибка"
    End If
End Sub
 
Private Sub Form_DblClick()
    MsgBox GetFilesCountInCab(Text1.Text), vbInformation
End Sub
 
Private Sub Form_Load()
    Text1.Text = App.Path & "\CabFile.cab"
    Text2.Text = App.Path & "\TestUnpacked"
    
    On Error Resume Next
    MkDir App.Path & "\TestUnpacked"
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Command1_Click
    End If
End Sub

Option Explicit
'/////////////////////////////////////////////
'// Модуль упаковки CAB-архивов             //
'// Copyright (c) 20.11.2024 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 1.0                              //
'/////////////////////////////////////////////
 
' Декларации API ...
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 Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, 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 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 tcompTYPE_MSZIP = &H1
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 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
 
' Переменные для временного хранения данных ...
Dim fh As Long
Dim fh_cab As Long
Dim cabFileName As String
 
' Енумы ...
Private Enum BOOL
    cFalse
    cTrue
End Enum
 
Private Enum Stream_Seek
    STREAM_SEEK_SET
    STREAM_SEEK_CUR
    STREAM_SEEK_END
End Enum
 
' Для совместимости с TwinBasic и 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. Выделение памяти
' Описание макроса: 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. Создание временного файла (потока)
' 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
    ' Специальный хак:
    ' Обманываем операционную систему, которая будет "думать", что работает с TMP-файлами на диске
    ' Вместо временного файла на диске, мы будем создавать поток IStream в оперативной памяти своего процесса
    Dim hStream As Long
    
    hStream = SHCreateMemStream(0, 0) ' Создать новый поток IStream для временного файла
    pszTempName = hStream ' Здесь мы будем использовать хак: засовываем в переменную String значение Long
    fnFciGTF = 1
End Function
 
' 3. Открытие файла (потока)
' Описание макроса: 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 ' Хак
        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. Чтение данных
' Описание макроса: 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 ReadFile(fh, hMemory, cbSize, dwBytesRead, ByVal 0&) = cFalse Then
            ErrNo = Err.LastDllError
            fnRead = -1
            Exit Function
        End If
    Else ' Если открывается на чтение временный поток IStream
        dwBytesRead = IStream_Read(hf, hMemory, cbSize)
    End If
    
    fnRead = dwBytesRead
End Function
 
' 5. Запись данных
' Описание макроса: 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 WriteFile(fh_cab, hMemory, cbSize, dwBytesWritten, ByVal 0&) = cFalse Then
            ErrNo = Err.LastDllError
            fnWrite = -1
            Exit Function
        End If
    Else ' Если открывается на запись временный поток IStream
        dwBytesWritten = IStream_Write(hf, hMemory, cbSize)
    End If
    
    fnWrite = dwBytesWritten
End Function
 
' 6. Освобождение памяти
' Описание макроса: 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. Позиционирование указателя
' Описание макроса: 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 ' Если открывается на позиционирование файл, который добавляется в архив, либо сам файл архива
        newPos = SetFilePointer(hf, dist, ByVal 0&, seektype)
        ErrNo = Err.LastDllError
    Else ' Позиционирование "временного файла" то есть потока
        newPos = IStream_Seek(hf, dist / 10000@, seektype)
    End If
    
    fnSeek = newPos
End Function
 
' 8. Закрытие файла (потока)
' Описание макроса: 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 ' Если закрывать нужно файл, который добавляется в архив, либо нужно закрывать сам файл архива
        CloseHandle hf
    End If
    
    fnClose = 0
End Function
 
' 9. Удаление временного файла (потока)
' 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. Вызывается каждый раз при добавлении нового файла в архив
' 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
    ' Здесь можно получить полезные данные:
    ' 1. FileSize
    ' 2. StrConv(ccab.szCabPath, vbUnicode)
    ' 3. StrConv(ccab.szCab, vbUnicode)
    
    fnFilePlaced = 0
End Function
 
' --- FCICreate CallBack's ---
 
' +++ FCIAddFile CallBack's +++
 
' 11. Устанавливаем атрибуты файла
' 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. Вызывается на нескольких этапах обработки файла: сжатие блока, добавление сжатого блока и запись архива
' 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. Вызывается перед созданием нового тома архива
' 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 ---
 
' Упаковать файл в архив CAB
Public Function CabinetAddFile(ByVal CabinetFullFileName As String, ByVal SourceFileName As String) 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
    
    ZeroMemory ccab, LenB(ccab)
    ZeroMemory erf, LenB(erf)
    
    ' Прежде всего нужно взять FullFileName будущего архива и извлечь из него путь к папке и имя файла
    CabinetName = StrConv(CabinetExtractFileName(CabinetFullFileName), vbFromUnicode) ' Преобразовать в ANSI
    CabinetPath = StrConv(CabinetExtractFilePath(CabinetFullFileName), vbFromUnicode) ' Преобразовать в ANSI
    
    ' Определить значения структуры
    ccab.cb = &H7FFFFFFF ' The maximum size, in bytes, of a cabinet created by FCI
    ccab.iDisk = 1
    
    CabinetDisk = StrConv("DISK1", vbFromUnicode) ' Я не знаю почему, но надо писать "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 ' Запомнить FileName будущего архива
    AnsiSourceFileName = StrConv(SourceFileName, vbFromUnicode) ' Преобразовать в ANSI
    AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFileName), vbFromUnicode) ' Преобразовать в ANSI
    
    If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
        ' Cabinet.dll не поддерживает юникодные имена файлов для упаковки
        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 FCIAddFile(fci, StrPtr(AnsiSourceFileName), StrPtr(AnsiExtractFileName), 0, AddressOf fnGetNextCabinet, AddressOf fnStatus, AddressOf fnOpenInfo, tcompTYPE_MSZIP) <> 0 Then
            If FCIFlushCabinet(fci, cFalse, AddressOf fnGetNextCabinet, AddressOf fnStatus) = cTrue Then
                CabinetAddFile = True
            End If
        End If
        
        FCIDestroy fci
    End If
    
    cabFileName = vbNullString
End Function
 
' Преобразовать полный путь кабинета в имя файла
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
 
' Преобразовать полный путь кабинета в путь к папке (всегда возвращает на конце "\")
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

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Sub Command1_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    Me.Cls
    Print CabinetAddFile(Text1.Text, Text2.Text)
    Print (GetTickCount - tick) & " ml"
End Sub
 
Private Sub Command2_Click()
    MsgBox Chr(34) & CabinetExtractFileName(Text1.Text) & Chr(34), vbInformation
End Sub
 
Private Sub Command3_Click()
    MsgBox Chr(34) & CabinetExtractFilePath(Text1.Text) & Chr(34), vbInformation
End Sub
 
Private Sub Form_Load()
    Text1.Text = App.Path & "\test.cab"
    Text2.Text = App.Path & "\test.txt"
End Sub