Кому надо DGM ? , за исходники 2-х алгоритмов

Цитата SmK @ 14.02.05, 14:59

Нет, чтобы на сях сделать юзабельную длл и юзать в VB

Ну, во-первых, изначально это было нужно Скинеру для его спая, почитай посты выше. Во-вторых, конечно хорошо, когда есть возможность не юзать сторонние библиотеки/контролы (для этого, кстати, Скинер и поднял вопрос). А, в-третьих, это просто интересно как опыт, в том числе и перевода.

Цитата SmK @ 14.02.05, 14:59

Там все ф-ии CDECL ! И callback-и и FCICreate. ИМХО без ассемблерных вставок вряд ли обойтись

Гм, и что, что cdecl? И причём тут асмовые вставки?

Сообщение отредактировано: f33l - 14.02.05, 15:23

Цитата

Гм, и что, что cdecl?

А VB их вызывает как stdcall. У VB все stdcall.
Менять нельзя. Нуу... разве вроде импортируемы ф-ии можно, но там тоже косяки идут
(Bad DLL calling convercation)

Private Declare Function FCICreate CDecl& Lib "cabinet.dll"

А обычные ф-ии типа fci_open вообще нельзя.

Сообщение отредактировано: SmK - 15.02.05, 05:12

Всё, я понял =) Блин, никогда не сталкивался на VB с cdecl-функциями..
Что ж придётся разбираться =)
Хотя, есть, в принципе, альтернатива, но геморная..
Попробую покувыркаться с этим cdecl, вроде что-то нашёл уже..

Сообщение отредактировано: f33l - 15.02.05, 17:15

Насколько я понял из найденных примеров (там вставки, но вроде всё более-менее понятно..), вызов cdecl-функций отличается только тем, что нужно чистить стек.. правильно я понял?
И это:

Цитата SmK @ 15.02.05, 05:09

А обычные ф-ии типа fci_open вообще нельзя

Почему? Это никак не обойти (по аналогии с cdecl-API)?

ОДНАКО хочу заметить, ведь мой код всё-таки работает.. если подебажить, можно увидеть, что структуры и правда заполняются, даже вроде правильно, но криво (имя файла например вписывается правильно, но с каким-то смещением..) Т.е. я хочу сказать, что оно как-никак, но работает. Может быть баг просто только в коде?..

Подключайтесь, блин, а то трудновато в этом во всём разобраться..


И вот ещё, тот другой способ, про который я говорил. В CAB SDK подробно описывается формат CAB, т.е. его можно конструировать вручную. Там есть пример cab-архива (не код, просто структура бинарика), он прокомментирован, и разобраться легко. НО там очень мало и запутанно написано про сжатие.. И в том примере файлы не сжаты. Т.е. я могу реализовать ручную сборку, но только без сжатия файлов (т.к. фиг там разберёшься)
Если у кого есть примеры/ссылки реализации полностью совместимого со стандартом сжатия MSZIP (или LZX), выложите, плиз.
Вообще, конечно, это менее желательный вариант, но если нифига с этим [censored] cdecl не получится, то останется только это..

Сообщение отредактировано: f33l - 16.02.05, 22:50

Цитата

вызов cdecl-функций отличается только тем, что нужно чистить стек.. правильно я понял?

Цитата

; F(A,B,C,D)

_cdecl: ; прямой порядок расположения данных на стеке
; обратный по времени способ запихивания
; допускает переменное число параметров
; поскольку стек очищает тот, кто вызвал функцию
push D
push C
push B
push A
call F
; ret
inc esp, 16 ; очистка стека здесь

_stdcall: ; порядок данных - тот же самый
; но стек очищает функция
; поэтому число параметров фиксировано
push D
push C
push B
push A
call F
; ret 16 ; очистка стека - в функции

_fastcall: ; аналогично stdcall, но два первых параметра передаются через регистры
push D
push C
mov edx, B
mov eax, A
call F
; ret 8 ; очистка стека - в функции

_pascal: ; обратный порядок данных на стеке, прямой порядок запихивания
; поэтому число параметров фиксировано, и следовательно, стек очищает функция
push A
push B
push C
push D
call F
; ret 16

Цитата

ОДНАКО хочу заметить, ведь мой код всё-таки работает.. если подебажить, можно увидеть, что структуры и правда заполняются, даже вроде правильно, но криво (имя файла например вписывается правильно, но с каким-то смещением..) Т.е. я хочу сказать, что оно как-никак, но работает. Может быть баг просто только в коде?..

Хм... а у меня не заполняются. Вылетает ошибка Rumtime Error 0

Прикреплённая картинка

да там половина функций неправильно задекларирована.

SmK, т.е. я был прав насчёт чистки стека..

Цитата SmK @ 19.02.05, 07:47

Вылетает ошибка Rumtime Error 0

Странно...

Цитата nash @ 19.02.05, 14:14

да там половина функций неправильно задекларирована

Хм? А по-подробней?

ну и как даела?

Пока никак =) Щас у мя вообще мало времени, как освобожусь, займусь вплотную. Мне что-то всё-таки влом колупаться с этими cdecl, т.к. это будет очень трудно отлаживать, поэтому я попробую разобраться в реализации MSZIP- или LZX-сжатия.

Можно сделать через COM (см. здесь), но, как я понял, будет работать только под Win2k и выше

Это только создание архива, да еще и не через cabinet.dll, короче это не то.

Вы просили код для упаковки CAB из Cabinet.dll (на VB6). Вот пожалуйста:

Option Explicit
'////////////////////////////////////////////
'// Модуль упаковки CAB-архивов            //
'// Copyright (c) 21.11.2024 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.2                             //
'////////////////////////////////////////////
 
' Декларации 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 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
 
' Константы ...
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
 
' Типы ...
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
 
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
 
' Для совместимости с 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
' Функция принимает в качестве параметров SourceFullFileNames, DestFileNames строку (если файл один) либо массив строк (список файлов)
' DestFileNames - это необязательный параметр, это путь и имя файла внутри архива CAB
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 CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' Если массив инициализирован
            For i = 0 To UBound(SourceFullFileNames)
                AnsiSourceFileName = StrConv(SourceFullFileNames(i), vbFromUnicode) ' Преобразовать в ANSI
                
                If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
                    ' Cabinet.dll не поддерживает юникодные имена файлов для упаковки
                    Exit Function
                End If
                
                ' Копируем массив, только в результатирующем массиве будут имена файлов в кодировке ANSI
                CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName
            Next
        Else
            Exit Function
        End If
    Else
        If VarType(SourceFullFileNames) = vbString Then
            If SourceFullFileNames <> vbNullString Then
                AnsiSourceFileName = StrConv(SourceFullFileNames, vbFromUnicode) ' Преобразовать в ANSI
                
                If InStrB(1, AnsiSourceFileName, ChrB(&H3F)) > 0 Then
                    ' Cabinet.dll не поддерживает юникодные имена файлов для упаковки
                    Exit Function
                End If
                
                CabinetInsertArrayString AnsiSourceFullFileNames, AnsiSourceFileName ' В массиве будет только одна строка
            Else ' Строка не должна быть пустой
                Exit Function
            End If
        Else ' Ошибка типа данных (не массив и не строка)
            Exit Function
        End If
    End If
    
    If IsArray(DestFileNames) Then
        If CabinetIsArrayInitialized(SourceFullFileNames) = True Then ' Если массив инициализирован
            If UBound(SourceFullFileNames) <> UBound(DestFileNames) Then Exit Function ' Не совпадают границы массивов
            
            For i = 0 To UBound(DestFileNames)
                AnsiDestinationFileName = StrConv(DestFileNames(i), vbFromUnicode) ' Преобразовать в ANSI
                
                If InStrB(1, AnsiDestinationFileName, ChrB(&H3F)) > 0 Then
                    ' Cabinet.dll не поддерживает юникодные имена файлов для упаковки
                    Exit Function
                End If
                
                ' Копируем массив, только в результатирующем массиве будут имена файлов в кодировке ANSI
                CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName
            Next
            
            DestFileNamesArrayInitialized = True
        End If
    Else
        If VarType(DestFileNames) = vbString Then
            If DestFileNames <> vbNullString Then
                AnsiDestinationFileName = StrConv(DestFileNames, vbFromUnicode) ' Преобразовать в ANSI
                
                If InStrB(1, AnsiDestinationFileName, ChrB(&H3F)) > 0 Then
                    ' Cabinet.dll не поддерживает юникодные имена файлов для упаковки
                    Exit Function
                End If
                
                CabinetInsertArrayString AnsiDestFileNames, AnsiDestinationFileName ' В массиве будет только одна строка
                DestFileNamesArrayInitialized = True
            End If
        End If
    End If
    
    ' Прежде всего нужно взять 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 будущего архива
    
    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 ' Если это массив
                    AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNames(i)), vbFromUnicode) ' Преобразовать в ANSI
                Else
                    AnsiExtractFileName = StrConv(CabinetExtractFileName(SourceFullFileNames), vbFromUnicode) ' Преобразовать в 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
 
' Преобразовать полный путь кабинета в имя файла
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
 
' Добавить строку в массив, в не зависимости от того, был ли он инициализирован
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
 
' Инициализирован ли массив
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

Добавлено 21.11.24, 17:27
Теперь давайте мне DGM, чтобы это ни значило бы) надеюсь это что-то хорошее)))