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

Заплачу за каждый исходник по 2 DGM.

1. Исходник на VB6.0 монитора файловой системы. <- Вопрос решен
2. Исходник на VB6.0 класса для работы с библиотекой CABINET.DLL

Сообщение отредактировано: SCINER - 29.11.04, 10:07

а что за библа такая!? CABINET.DLL?

maxim84_, Cab'ы юзает

Добавлено 28.11.04, 04:45
SCINER, Смотри здесь

Есть такая программка FileMon... Круче неё ничего не сделать на эту тему
>filemon<
Так вот, там есть пункт "How FileMon Works". Я из него можно понять, что в проге используется специальный vxd который перехватывает соответствующие вызовы и т.д. На VB пока ещё дрова писать нельзя, так что средствами VB тут не ограничишься...
Но, в принципе, можно глобально перехватывать вызовы файловых API, хотя это естественно менее эффективно, и таким образом будут отслеживаться не все изменения, т.к. не все проги используют API для работы с файлами.

По второму пункту - вообще темный лес.
В принципе декларации функций из библиотеки выглядят так:

Declare Function FCIAddFile Lib "cabinet.dll" ( _
                 ByRef hfci As hfci, _
                 ByVal pszSourceFile As String, _
                 ByVal pszFileName As String, _
                 ByVal fExecute As Long, _
                 ByRef pfnfcignc As PFNFCIGETNEXTCABINET, _
                 ByRef pfnfcis As PFNFCISTATUS, _
                 ByRef pfnfcigoi As PFNFCIGETOPENINFO, _
                 ByRef ltypeCompress As TCOMP) As Long
Declare Sub FCICreate Lib "cabinet.dll" ( _
            ByRef perf As perf, _
            ByRef pfnfcifp As PFNFCIFILEPLACED, _
            ByRef pfna As PFNFCIALLOC, _
            ByRef pfnf As PFNFCIFREE, _
            ByRef pfnopen As PFNFCIOPEN, _
            ByRef pfnread As PFNFCIREAD, _
            ByRef pfnwrite As PFNFCIWRITE, _
            ByRef pfnclose As PFNFCICLOSE, _
            ByRef pfnseek As PFNFCISEEK, _
            ByRef pfndelete As PFNFCIDELETE, _
            ByRef pfnfcigtf As PFNFCIGETTEMPFILE, _
            ByRef pccab As pccab, _
            pv As Any)
Declare Function FCIDestroy Lib "cabinet.dll" ( _
                 ByRef hfci As hfci) As Long
Declare Function FCIFlushCabinet Lib "cabinet.dll" ( _
                 ByRef hfci As hfci, _
                 ByVal fGetNextCab As Long, _
                 ByRef pfnfcignc As PFNFCIGETNEXTCABINET, _
                 ByRef pfnfcis As PFNFCISTATUS) As Long
Declare Function FCIFlushFolder Lib "cabinet.dll" ( _
                 ByRef hfci As hfci, _
                 ByRef pfnfcignc As PFNFCIGETNEXTCABINET, _
                 ByRef pfnfcis As PFNFCISTATUS) As Long
Declare Function FDICopy Lib "cabinet.dll" ( _
                 ByRef hfdi As hfdi, _
                 ByVal pszCabinet As String, _
                 ByVal pszCabPath As String, _
                 ByVal flags As Long, _
                 ByRef pfnfdin As PFNFDINOTIFY, _
                 ByRef pfnfdid As PFNFDIDECRYPT, _
                 pvUser As Any) As Long
Declare Sub FDICreate Lib "cabinet.dll" ( _
            ByRef pfnalloc As pfnalloc, _
            ByRef pfnfree As pfnfree, _
            ByRef pfnopen As pfnopen, _
            ByRef pfnread As pfnread, _
            ByRef pfnwrite As pfnwrite, _
            ByRef pfnclose As pfnclose, _
            ByRef pfnseek As pfnseek, _
            ByVal cpuType As Long, _
            ByRef perf As perf)
Declare Function FDIDestroy Lib "cabinet.dll" ( _
                 ByRef hfdi As hfdi) As Long
Declare Function FDIIsCabinet Lib "cabinet.dll" ( _
                 ByRef hfdi As hfdi, _
                 ByRef hf As INT_PTR, _
                 ByRef pfdici As PFDICABINETINFO) As Long
 
Declare Function FDITruncateCabinet Lib "cabinet.dll" ( _
                 ByRef hfdi As hfdi, _
                 ByVal pszCabinetName As String, _
                 ByVal iFolderToDelete As Integer) As Long

но вот такие вещи как TCOMP, PFNFCIGETNEXTCABINET и т.п. - даже и не знаю с какой стороны подойти к их декларированию.

Мне нужен именно код запаковки файлов в один архив.
Все функции отвечающие именно за запаковку начинаются на FCI,
те же которые начинаются на FDI отвечают за распаковку.

Насчет деклараций. Это еще не полное решение. Вот если бы еще эту структурку узнать

а что насчёт мониторинга?

Цитата Andrey_Kun @ 28.11.04, 04:35

maxim84_, Cab'ы юзает

Добавлено 28.11.04, 04:45
SCINER, Смотри здесь

Там все на С
Я в нем 0
и структуру PFNFCIGETNEXTCABINET я тоже не нашел

Вот, что откопал в инете:

Option Explicit
 
Private Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long
Private Declare Function llseek Lib "kernel32" Alias "_llseek" (ByVal hFile As Long, ByVal lOffset As Long, ByVal iOrigin As Long) As Long
Private Declare Function lread Lib "kernel32" Alias "_lread" (ByVal hFile As Long, lpBuffer As Any, ByVal wBytes As Long) As Long
Private Declare Function lwrite Lib "kernel32" Alias "_lwrite" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal wBytes As Long) As Long
Private Declare Function hread Lib "kernel32" Alias "_hread" (ByVal hFile As Long, lpBuffer As Any, ByVal lBytes As Long) As Long
Private Declare Function hwrite Lib "kernel32" Alias "_hwrite" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal lBytes As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
 
Public Const O_RDONLY = &H0     ' open for reading only */
Public Const O_WRONLY = &H1     ' open for writing only */
Public Const O_RDWR = &H2       ' open for reading and writing */
Public Const O_APPEND = &H8     ' writes done at eof */
Public Const O_CREAT = &H100    ' create and open file */
Public Const O_TRUNC = &H200    ' open and truncate */
Public Const O_EXCL = &H400     ' open only if file doesn't already exist */
 
Public Const OF_CREATE = &H1000
Public Const OF_READ = &H0
Public Const OF_READWRITE = &H2
Public Const OF_WRITE = &H1
 
Public Const OF_SHARE_EXCLUSIVE = &H10
Public Const MEDIA_SIZE = 300000
Public Const FOLDER_THRESHOLD = 900000
Public Const COMPRESSION_TYPE = &H1
 
Public Type ClientState
  total_compressed_size As Long   ' total compressed size so far */
  total_uncompressed_size As Long ' total uncompressed size so far */
End Type
 
'public const HFILE_ERROR ((HFILE)-1)
 
Public Const CB_MAX_CHUNK = 32768
Public Const CB_MAX_DISK = &H7FFFFFFF
Public Const CB_MAX_FILENAME = 256
Public Const CB_MAX_CABINET_NAME = 256
Public Const CB_MAX_CAB_PATH = 256
Public Const CB_MAX_DISK_NAME = 256
 
Public Type Ccab
  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
  setID As Integer                  ' Cabinet set ID
  szDisk As String * 256            ' current disk name
  szCab As String * 256             ' current cabinet name
  szCabPath As String * 256         ' path for creating cabinet
End Type
 
Public Type ErrorRF
  erfOper As Integer
  erfType As Integer
  fError As Boolean
End Type
 
Public Const OFS_MAXPATHNAME = 128
Public Type OFSTRUCT
  cBytes As Byte
  fFixedDisk As Byte
  nErrCode As Integer
  Reserved1 As Integer
  Reserved2 As Integer
  szPathName(OFS_MAXPATHNAME) As Byte
End Type
 
Public Const GMEM_FIXED = &H0
 
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function FCICreate Lib "CABINET.DLL" (perf As ErrorRF, pfnfiledest As Long, pfnalloc As Long, pfnfree As Long, pfnopen As Long, pfnread As Long, pfnwrite As Long, pfnclose As Long, pfnseek As Long, pfndelete As Long, pfnfcigtf As Long, pccab As Ccab, pv As Long) As Long
Public Declare Function FCIAddFile Lib "CABINET.DLL" (hfci As Long, ByVal pszSourceFile As Long, ByVal pszFileName As Long, ByVal fExecute As Boolean, ByVal pfnGetNextCabinet As Long, ByVal pfnProgress As Long, ByVal pfnOpenInfo As Long, ByVal typeCompress As Long) As Long
Public Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
 
Public Function FCIMalloc(ByVal lngSize As Long) As Long
  Dim hMem As Long
  hMem = GlobalAlloc(GMEM_FIXED, lngSize)
  If hMem = 0 Then
    MsgBox "error to malloc"
    FCIMalloc = 0
    Exit Function
  End If
  FCIMalloc = hMem
  End Function
 
Public Function FCIMemFree(ByVal lngMemory As Long) As Long
  If lngMemory Then
  FCIMemFree = GlobalFree(lngMemory)
  End If
  End Function
 
Public Function FCIRead(ByVal hf As Integer, ByVal hMemory As Long, ByVal lngSize As Long, ByVal ErrNo As Integer, ByVal pv As Long) As Long
  Dim result As Long
  result = lread(hf, hMemory, lngSize)
  If result <> lngSize Then
    MsgBox "error to _read"
    Exit Function
  End If
  FCIRead = result
  End Function
 
Public Function FCIWrite(ByVal hf As Integer, ByVal hMemory As Long, ByVal lngSize As Long, ByVal ErrNo As Integer, ByVal pv As Long) As Long
  Dim result As Long
  result = lwrite(hf, hMemory, lngSize)
  If result <> lngSize Then
    MsgBox "error to _write"
    Exit Function
  End If
  FCIWrite = result
  End Function
 
Public Function FCIClose(ByVal hf As Integer, ByVal ErrNo As Integer, ByVal pv As Long) As Long
  Dim result As Long
  result = lclose(hf)
  If result <> 0 Then
    MsgBox "error to _read"
    Exit Function
  End If
  FCIClose = result
  End Function
 
Public Function FCISeek(ByVal hf As Integer, ByVal dist As Long, ByVal seektype As Long, ByVal ErrNo As Integer, ByVal pv As Long) As Long
  Dim result As Long
  '''result = LSeek(hf, dist, seektype)
  If result = -1 Then
    MsgBox "error to _lseek"
    Exit Function
  End If
  FCISeek = result
  End Function
 
Public Function FCIDelete(ByVal pszfile As String, ByVal ErrNo As Integer, ByVal pv As Long) As Long
  Dim result As Long
  result = DeleteFile(pszfile)
  If result <> 0 Then
    MsgBox "error to remove"
    Exit Function
  End If
  FCIDelete = result
  End Function
 
Public Function FCIFilePlaced(pccab As Ccab, ByVal pszfile As String, ByVal FileSize As Long, fContinuation As Boolean, pv As Long) As Integer
  FCIFilePlaced = 0
  End Function
 
Public Function FCIGetTmpFile(ByVal pszTempName As Long, ByVal cbTempName As Long) As Boolean
  Dim result As Long
  Dim strTmp As String * 256
  strTmp = String$(256, Chr(0))
  'result = GetTempFileName("c:\", "xx", 0, strTmp)
  'strTmp = Left$(strTmp, InStr(strTmp, Chr(0)) - 1)
  'strTmp = Left$(strTmp, InStr(strTmp, Chr(32)) - 1)
  FCIGetTmpFile = (GetTempPath(Len(strTmp), strTmp) <> 0) And (GetTempFileName(strTmp, "cab", 0, pszTempName) <> 0)
  End Function
 
Public Function FCIOpen(ByVal pszfile As String, ByVal oFlag As Long, ByVal pMode As Long, ByVal ErrNo As Integer, ByVal pv As Long) As Integer
  Dim Style                          As Long
  Dim os                             As OFSTRUCT
  If (oFlag And O_CREAT) <> 0 Then
    Style = OF_CREATE
  Else
    Select Case (oFlag And 3)
    Case 0: Style = OF_READ
    Case 1: Style = OF_WRITE
    Case Else: Style = OF_READWRITE
    End Select
  End If
  If (oFlag And O_EXCL) <> 0 Then Style = Style Or OF_SHARE_EXCLUSIVE
  FCIOpen = OpenFile(pszfile, os, Style)
 
  End Function
 
Public Function FCIGetOpenInfo(ByVal pszName As String, pdate As Long, ptime As Long, pAttribs As Long, ByVal ErrNo As Integer, pv As Long) As Long
  Dim os                             As OFSTRUCT
  FCIGetOpenInfo = OpenFile(pszName, os, OF_READ)
  End Function
 
Public Function FCIStatus(ByVal typeStatus As Integer, ByVal cb1 As Long, ByVal cb2 As Long, ByVal pv As Long) As Boolean
  End Function
 
Public Function FCIGetNextCabinet(pccab As Ccab, cbPrevCab As Long, pv As Long) As Boolean
  End Function
 
Public Function CabinetAddFiles(strCabinet As String)
 
  Dim i                              As Integer
  Dim fci                            As Long
  Dim erf                            As ErrorRF
  Dim cab                            As Ccab
  Dim hMem                           As Long
  Dim LibHandle                      As Long
 
  Dim pfnFCICreate                   As Long
  Dim pfnFCIAddFile                  As Long
  Dim pfnFCIFlushCabinet             As Long
  Dim pfnFCIFlushFolder              As Long
  Dim pfnFCIDestroy                  As Long
 
  LibHandle = LoadLibrary("CABINET.DLL")
  If LibHandle = 0 Then
    MsgBox "Error load CABINET.DLL"
    Exit Function
  End If
 
  pfnFCICreate = GetProcAddress(LibHandle, "FCICreate")
  pfnFCIAddFile = GetProcAddress(LibHandle, "FCIAddFile")
  pfnFCIFlushCabinet = GetProcAddress(LibHandle, "FCIFlushCabinet")
  pfnFCIFlushFolder = GetProcAddress(LibHandle, "FCIFlushFolder")
  pfnFCIDestroy = GetProcAddress(LibHandle, "FCIDestroy")
  
  If pfnFCICreate = 0 Or _
     pfnFCIAddFile = 0 Or _
     pfnFCIFlushCabinet = 0 Or _
     pfnFCIFlushFolder = 0 Or _
     pfnFCIDestroy = 0 Then
    MsgBox "Error load CABINET.DLL"
    Exit Function
  End If
 
  'hMem = GlobalAlloc(GMEM_FIXED, Len(cab))
  With cab
    .cbReserveCFHeader = 0
    .cbReserveCFFolder = 0
    .cbReserveCFData = 0
    .cb = &H1000000
    .cbFolderThresh = 900000
    .cbReserveCFHeader = 0
    .cbReserveCFFolder = 0
    .cbReserveCFData = 0
    .iCab = 1
    .iDisk = 0
    .setID = 12345
    lstrcpy .szDisk, "MyDisk"
    lstrcpy .szCabPath, "c:\"
    lstrcpy .szCab, "my.cab"
  End With
  
  'CopyMemory hMem, cab, Len(cab)
  
  fci = FCICreate(erf, AddressOf FCIFilePlaced, AddressOf FCIMalloc, AddressOf FCIMemFree, AddressOf FCIOpen, AddressOf FCIRead, AddressOf FCIWrite, AddressOf FCIClose, AddressOf FCISeek, AddressOf FCIDelete, AddressOf FCIGetTmpFile, cab, 0&)
  
  If fci = -1 Then
    MsgBox "error to FCICREATE"
    Exit Function
  End If
  
  End Function

Мда. Уже допер как надо делать, уже половину деклараций накатал и несколько CallBack функций реализовал (FCIFilePlaced, FCIALLOC, FСIFreeMem), а тут вон что . БОльше помощь по этому пункту не нужна?

По первому пункту цепляю рабочий код. Есть у него недостатки, к примеру в ФАРе я создал папку - пример это не словил, а вот удаление из фара поймал... С эксплорером никаких проблем, ловит создание удаление. Принтеры ловит.
Прикреплённый файлNotifycation.zip (18.69 Кбайт, скачиваний: 157)

Цитата Vasya2000 @ 29.11.04, 02:19

Мда. Уже допер как надо делать, уже половину деклараций накатал и несколько CallBack функций реализовал (FCIFilePlaced, FCIALLOC, FСIFreeMem), а тут вон что . БОльше помощь по этому пункту не нужна?

Нужна.
Этот не рабочий код.
Если вызвать допустим AddCabinetFile то рушится вся среда разом.
И вроде ничего не помогает

AddCabinetFile ? в Твоем примере этой функции нет. Если ты имеешь в виду FCIAddFile, то для нее нужны каллбэк-функции: PFNFCIGETNEXTCABINET, PFNFCISTATUS, PFNFCIGETOPENINFO и структура TCOMP, которая хрен победишь как должна выглядеть.

Добавлено 29.11.04, 09:32
Или эта структура может выглядеть просто как

tcompTYPE_MSZIP         = $0001;

??

Кстати, SCINER, я это делаю не из-за дгм!

Гм... а как "решён" вопрос с мониторингом?

Cм сообщение №11 и качай аттачмент.

SCINER, держи вот эту бодягу, надеюсь поможет:

 
   tcompMASK_TYPE =          $000F;  // Mask for compression type
   tcompTYPE_NONE =          $0000;  // No compression
   tcompTYPE_MSZIP =         $0001;  // MSZIP
   tcompTYPE_QUANTUM =       $0002;  // Quantum
   tcompTYPE_LZX =           $0003;  // LZX
   tcompBAD =                $000F;  // Unspecified compression type
 
   tcompMASK_LZX_WINDOW =    $1F00;  // Mask for LZX Compression Memory
   tcompLZX_WINDOW_LO =      $0F00;  // Lowest LZX Memory (15)
   tcompLZX_WINDOW_HI =      $1500;  // Highest LZX Memory (21)
   tcompSHIFT_LZX_WINDOW =       8;  // Amount to shift over to get int
 
   tcompMASK_QUANTUM_LEVEL = $00F0;  // Mask for Quantum Compression Level
   tcompQUANTUM_LEVEL_LO =   $0010;  // Lowest Quantum Level (1)
   tcompQUANTUM_LEVEL_HI =   $0070;  // Highest Quantum Level (7)
   tcompSHIFT_QUANTUM_LEVEL =    4;  // Amount to shift over to get int
 
   tcompMASK_QUANTUM_MEM =   $1F00;  // Mask for Quantum Compression Memory
   tcompQUANTUM_MEM_LO =     $0A00;  // Lowest Quantum Memory (10)
   tcompQUANTUM_MEM_HI =     $1500;  // Highest Quantum Memory (21)
   tcompSHIFT_QUANTUM_MEM =      8;  // Amount to shift over to get int
 
   tcompMASK_RESERVED =      $E000;  // Reserved bits (high 3 bits)
 
   CB_MAX_FILENAME =            256;
   CB_MAX_CABINET_NAME =        256;
   CB_MAX_CAB_PATH =            256;
   CB_MAX_DISK_NAME =           256;
 
 
Public Type TCCAB
      cb: ULONG;                  // size available for cabinet on this media
      cbFolderThresh: ULONG;      // Thresshold for forcing a new Folder
      cbReserveCFHeader: UINT;    // Space to reserve in CFHEADER
      cbReserveCFFolder: UINT;    // Space to reserve in CFFOLDER
      cbReserveCFData: UINT;      // Space to reserve in CFDATA
      iCab: Integer;              // sequential numbers for cabinets
      iDisk: Integer;             // Disk number
      fFailOnIncompressible: Integer;  // TRUE => Fail if a block is incompressible
      setID: USHORT;               // Cabinet set ID
      szDisk: array[0..CB_MAX_DISK_NAME - 1] of AnsiChar;    // current disk name
      szCab: array[0..CB_MAX_CABINET_NAME - 1] of AnsiChar;  // current cabinet name
      szCabPath: array[0..CB_MAX_CAB_PATH - 1] of AnsiChar;  // path for creating cabinet
End Type
 
PCCAB = ^TCCAB; ' Это означает что структуры одинаковы но в VB придется объявить обе
 
Public Type PFNFCIGETNEXTCABINET
    pccab: PCCAB;
    cbPrevCab: ULONG;
    pv: void FAR;
End Type    
    
Public Type TFDICABINETINFO
      cbCabinet: Longint;  // Total length of cabinet file
      cFolders: USHORT;    // Count of folders in cabinet
      cFiles: USHORT;      // Count of files in cabinet
      setID: USHORT;       // Cabinet set ID
      iCabinet: USHORT;    // Cabinet number in set (0 based)
      fReserve: WIN_BOOL;  // TRUE => RESERVE present in cabinet
      hasprev: WIN_BOOL;   // TRUE => Cabinet is chained prev
      hasnext: WIN_BOOL;   // TRUE => Cabinet is chained next
End Type
 
PFDICABINETINFO = ^TFDICABINETINFO; 'Тоже что и выше
 
Public Type TFDINOTIFICATION
      cb: Longint;
      psz1: PAnsiChar;
      psz2: PAnsiChar;
      psz3: PAnsiChar;       // Points to a 256 character buffer
      pv: PVoid;             // Value for client
      hf: Integer;
      date: USHORT;
      time: USHORT;
      attribs: USHORT;
 
      setID: USHORT;         // Cabinet set ID
      iCabinet: USHORT;      // Cabinet number (0-based)
      iFolder: USHORT;       // Folder number (0-based)
 
      fdie: TFDIERROR;
End Type
 
   PFDINOTIFICATION = ^TFDINOTIFICATION;'Тоже что и выше

Бодяга-то совершенно практически бесполезна! А вот нужно перевести следующие строчки с делфи:

if ((oflag and O_CREAT) <> 0) then
  begin
    if ((oflag and O_EXCL) <> 0) then
      FileCreate := CREATE_NEW
    else if ((oflag and O_TRUNC) <> 0) then
      FileCreate := CREATE_ALWAYS
    else
      FileCreate := OPEN_ALWAYS
  end
  else if ((oflag and O_TRUNC) <> 0) then
    FileCreate := TRUNCATE_EXISTING
  else if ((oflag and O_EXCL) <> 0) then
    FileCreate := OPEN_EXISTING
  else begin
    FileCreate := OPEN_EXISTING;
  end;

с этими else if совсем запутался. тупейшая кострукция. аналогов в ВБ вроде нету?

Vasya2000, Да нет, в VB тоже самое только слитно пишется If Then ... Elseif Then ... Else ... End If
А вот на счет бодяги, тут именно оно. Структуры которые нужно перевести в VB формат данных, тогда можно будет АПИ-шки юзать кабинетные.

Ага! Ясно, спасибо.

2Vasya2000: не могу качнуть, я ж не зареген, я уже писал об этом... вкратце, чё там за код? там используется FindFirstChangeNotification и иже с ним? Если да, то это вобщем-то и не мониторинг, т.к. таким образом можно только за одной папкой следить...

FindFirstChangeNotification - умеет следить за всеми дисками сразу.
В примере FindFirstChangeNotification неиспользуется.
Там что-то типа подписки через shell32.dll на уведомлении об активности файловой системы через обработчик оконной процедуры.

Хм.. FindFirstChangeNotification принимает как параметр имя папки, поэтому он с ней и работает.. или можно как-то задать, чтоб она глобально отслеживала?
Плииз закинь себе этот архивчик с мониторингом на сайт, а то я ж не могу качнуть-то..

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

tmp, http://vbnet.mvps.org/index.html?code/shel...hangenotify.htm

SCINER, с cаb-ами разобрался? Расскажи как.

C cab-ами без пол-литры , да еще и за пару часов - не разберешся. У меня сейчас упорно вылетает на калбэк функции FCIOpen, причем судя по отладочной информации первый раз она срабатывает а во второй раз обрушивается. Очевидно глубоко в коде сидит баг. Или в днк. Я так полагаю, что если больше никто не примет участие в этом деле, то на исходники можно не рассчитывать.

мне тоже нужно с Cab'ами работать... А cabinet.dll с виндой поставляется?

Цитата miksayer @ 30.11.04, 12:41

мне тоже нужно с Cab'ами работать... А cabinet.dll с виндой поставляется?

Да! Помоему начиная с 98. А может даже и с 95.

2Sciner: ну мне в полнейший лом переставлять... потом как-нить
2Vasya2000: пасиб... и отдельно большое спасибо за ссылку на такой замечательный сайт =) не знал о нём..

Vasya2000, а expand.exe (для XP) и extract (win98) не подходит?

Сообщение отредактировано: Dr._S - 01.12.04, 05:19

Нужны исходники на ВБ, работа с cabinet.dll напрямую, а не через посредников.

Vasya2000,

Цитата

Нужны исходники на ВБ, работа с cabinet.dll напрямую, а не через посредников.

, а почему именно с CAB, а не ZIP или RAR например?

Наверное потому что zip и rar тоже сторонние архиваторы, их в винде может и не быть, а cab предустановлен в винде, так же как kernel или user32.

Vasya2000,

Цитата

Наверное потому что zip и rar тоже сторонние архиваторы, их в винде может и не быть, а cab предустановлен в винде, так же как kernel или user32.

, так нет, как раз таки, не используя сами это архиваторы, а реальный код. Вот например посмотри это, там есть и CAB, но вот только он его может просматривать и все. Работает реально только с зипом, вроде, не разбирался сильно, смотри сам:
Прикреплённый файлArchive_Explorer.rar (33.9 Кбайт, скачиваний: 82)

Ну не знаю как там с зипом или раром, это вообще-то SCINER'у надо было. А по поводу cab'а - задача сама по себе интересная.

zip or rar неподходят, в чистой винде нет ничего для работы с ними.
а cabinet.dll есть везде!

Да в принципе мне подойдет любой алгоритм сжатия.
Лишь бы его поддерживал WinZip и WinRar.
А то как мне людям слать архивы, которые потом никак не распаковать ?

Короче CAB здесь подходит всех больше.
Если бы еще знать как им корректно пользоваться

Пол инета перерыл, ничего готового не нашел.
Кроме как на C++ да на Delphi.

Vasya2000,

Цитата

Наверное потому что zip и rar тоже сторонние архиваторы, их в винде может и не быть, а cab предустановлен в винде, так же как kernel или user32.

, Вася в примере используются только kernel32 и shell32

SCINER,

Цитата

zip or rar неподходят, в чистой винде нет ничего для работы с ними.
а cabinet.dll есть везде!

, если ты смотрел пример, то наверное заметил, что в нем используются только kernel32 и shell32. Никаких сторонних библиотек, тем более самих экзешников этих архиваторов и в помине нет.

Так там же только распаковка и просмотр. Вроде .
Там нет запаковки в архив!

Цитата

Пол инета перерыл, ничего готового не нашел.
Кроме как на C++ да на Delphi.

Если ты нашёл то, что тебе нужно, но есть проблемы с переводом на вб, выложи кусок кода (лучше на дельфях), может смогу помочь?

SCINER, нашел пример по CAB'у архивировать/разархивировать, но не могу на форум выложить, хрень какая-то, не получается! Качать могу, все и сколько хочешь, а вот когда начинаю выкладывать - проблема. Если на сайт не получится выложить, то до понедельника.

1 часть

2 часть

Сообщение отредактировано: Dr._S - 04.12.04, 15:25

Кхм. Собственно самих исходников библиотеки нету. Да и библиотека не на ВБ сделана. Жаль.

Блин. Жаль что ниче нового.
На данный момент в SCINSpy я как раз эту библу и юзаю. Я только перебил ее немного(удалил инфу о версии, переименовал в ssreport.dll и сжал UPX'ом)
К сожалению это не на VB.

Проблема до сих пор актуальна!

Sciner см пост #40. Могу чем-нить помочь хоть в этом?

Блин, а я и не видел этого поста.
Вот, что-то на дельфи:
Прикреплённый файлcabd.zip (83.1 Кбайт, скачиваний: 78)

Блин Sciner )) Ты забыл что я не зареген? ) Кинь к себе на сайт плиз
а вообще, сорри, конечно... я вот щас попытаюсь осла переставить, может быть всё исправится..

если я его кину на сайт у меня деньги на счету кончаться.
у меня выделенка с платным трафиком.

Остаток на счете: -0.94 у.е., порог отключения: -1 у.е.

а заплатить деньги немогу т.к. завтра воскресенье.
еще максимум килобайт 500 протяну.
а аттач весит 83кб!

Уф... Я долго долбился с експлорером, забил и поставил оперу... наконец-то зарегился
Так вот, в аттаче лежат исходники компонентов, которые работают с cab'ами - что конкретно тебе надо перевести?

Кусок кода который с которым можно запаковать файлы в архив.

Вот исходники на Делфи, перевести надо всё!
Прикреплённый файлcabcomp.rar (41.53 Кбайт, скачиваний: 81)

Исходники большие, а сколько заплатите

А сколько вы хотите?

Вообще-то здесь все помогают безвозмездно,
но если на то пошло, могу 2 DGM отдать (не больше)!
Об этом в 1-ом посте этого топика сказано.

Сообщение отредактировано: SCINER - 05.12.04, 22:12

Хм... трудновато.. Выложите плиз всё, что у вас пока получилось на эту тему, так будет проще.
з.ы. а на сях желательно под билдер нету исходников?

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

Я такими вещами не занимался... и поподробней плиз что за баг
И ещё раз: выложи тут, что у тя в конечном варианте получилось по кабам

Вот, но здесь стопудово ниче неправильно.
А еще доку отсюда брал: http://cvs.winehq.com/patch.py?id=6331

Сообщение отредактировано: SCINER - 06.12.04, 01:12

Прикреплённый файлmFCIFDI.zip (7.74 Кбайт, скачиваний: 74)

Чем это ты переводил? имхо оочень криво переводит.
Вообще-то я имел ввиду пост#9: это конечный код или есть исправления?
кстати навскидку tcomp это не структура это typedef, который вроде-бы используется как набор констант

Цитата f33l,6.12.04, 01:53 @ 07.01.70, 04:17

Чем это ты переводил? имхо оочень криво переводит.
Вообще-то я имел ввиду пост#9: это конечный код или есть исправления?
кстати навскидку tcomp это не структура это typedef, который вроде-бы используется как набор констант

Переводил я сам
Я не силен в Delphi.
А насчет поста №9, я в нем ниче не понял, неработает он и все!

SCINER, Очень много ошибок. В делфи тип Integer = 4 байтам

SCINER, я нашёл кое-что насчёт cab'ов в очень извратном виде, но это сильно поможет с переводом.
Так вот, скажи подробно, что ты хочешь делать со всем этим, т.е. опиши подробнее задачу и т.д.. Я могу узко заточить под конкретную задачу, а могу и сделать общий класс (хотя его всё равно придётся делать потом).

Мне надо типа:

Dim Cab As New Cabinet
For i=0 To File1.ListCount -1
 Cab.AddFile File1.List(i)
Next
Cab.Path = "C:\MyCabinet.Cab"
Call Cab.Compress
Msgbox "Archive create sucessfull!",32

То есть всё-таки общий класс делать...
А распаковвывать тебе надо?

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

распаковка не нужна.

Нашел распаковку.
Но она какая-то непонятная.
Причем тут вообще XML ?
Да и cabinet.dll че-то нигде не светится ???
Прикреплённый файлCabFilesExtract.zip (22.94 Кбайт, скачиваний: 96)

Распаковка - это фигня.. Я тоже находил такой сурс, он не юзает cabinet.dll, там другой принцип. А про XML в комментах вроде написано, я уж не помню. Типа в таком формате там сохраняются сведения о cab-файлах (только, спрашивается, нафиг это нужно?)

Я вообще тут в напряге... У меня куча материалов по cab'ам на разных языках, но они пользы почти не приносят. Мне приходится почти с нуля переводить код из MS CAB SDK, там всё на Сях, а с Сей на ВБ переводить местами очень трудно.. Работа идёт, но медленно..

Сообщение отредактировано: f33l - 19.12.04, 01:04

SCINER, а тебе обязательно именно cab? Ведь можно просто архивировать по какому-нибудь другому алгоритму и все. Хотя я не думаю, что ты бы создавал эту тему, если бы ты мог обойтись без cab

Добавлено 19.12.04, 08:36
Кстати, я как-то находил прмер с 150 алгоритмами сжатия, но с моего винчестера он бесследно пропал. Теперь не могу его найти. Может у кого-то есть?

Можно ZIP
но для него придется писать сам алгоритм сжатия. Потом его потимизировать под VB.
А для каба есть готовая библа, надо только функции заюзать.
Вот так.
Если есть зип, можно и зип, я не против.

SCINER, а как насчет утилиты MAKECAB.EXE(смотри аттач)?
Прикреплённый файлmake_cab.rar (59.33 Кбайт, скачиваний: 73)

Это не подходит, Sciner вроде говорил уже. Ему нужно без сторонних контролов и прог.

В данный момент в моей проге юзается cablib.dll от Microsoft'a
Мне срочно(потому что уже достала) надо от нее избавится(любым способом).

Требуется запаковать кучку файлов из кода программы(без библиотек и прог) в такой архив, который потом смогли бы распаковать WinZip и WinRAR.

Цитата SCINER @ 20.12.04, 01:54

срочно

Блин, ну почему рочно? =) Моему переводу до рабочего варианта ещё очень далеко...

Блин.
кстати а что уже достигнуто на сегодняшний день ?

Переведён fci.h и бОльшая часть tesfci.c. В принципе это хорошо, но тестировать я пока ни разу не запустил, т.к. нужно перевести полностью. И не думаю, что когда я запущу, всё запашет с первого раза, т.к. там куча спорных мест, и это всё надо будет шлифовать долго...

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

f33l, Там (в fci.h) основной момент как перевести указатели на функции обратного вызова (PFNFCIGETNEXTCABINET, PCCAB) и прочие. Если ты это уже сделал, то выкладывай, дальше всем аулом добъем очень быстро.

Неа, я сам =))) Если серьёзно, я выложу где-то на выходных наверно...

Цитата f33l @ 20.12.04, 15:15

Неа, я сам =))) Если серьёзно, я выложу где-то на выходных наверно...

и где же? уже 2 месяца ждем

Цитата SCINER @ 19.12.04, 11:20

Можно ZIP
но для него придется писать сам алгоритм сжатия. Потом его потимизировать под VB.
А для каба есть готовая библа, надо только функции заюзать.
Вот так.
Если есть зип, можно и зип, я не против.

а если не zip?
вот нашел:
http://algolist.manual.ru/compress/standard/index.php

Блин, зачем ты поднял это позорное

Цитата f33l @ 20.12.04, 15:15

где-то на выходных

=)) А если серьёзно, уже почти готово, осталось буквально переписать функцию да привести это всё в человеческий вид. Большое сорри за такую задержку, мне действительно несколько стыдно =)

Сообщение отредактировано: f33l - 05.02.05, 19:59

1. нет ничего на VB
2. там только алгоритмы сжатия, без формата архивов
3. алгоритмы ни капли не оптимизированные

мне нужно сжать кучку файлов в архив, который смогут распаковать WinZip и WinRAR

Цитата SCINER @ 05.02.05, 20:00

мне нужно сжать кучку файлов в архив, который смогут распаковать WinZip и WinRAR

мне тоже

Цитата SCINER @ 05.02.05, 20:00

1. нет ничего на VB

раньше там к каждому алгоритму прилагался пример на VB, Pascal и C, а теперь почему-то нет

ну как это нет ничего на VB!!!
77 методов компресии
ооочень хорошие исходники!! а тебе уважаемый SCINER подойдет метод сжатия Huffman'а на называется он "Short 16 Chars"
WinRar 3.11 читает!! сам проверял!!

Цитата maxim84_ @ 05.02.05, 21:04

ну как это нет ничего на VB!!!
77 методов компресии
ооочень хорошие исходники!! а тебе уважаемый SCINER подойдет метод сжатия Huffman'а на называется он "Short 16 Chars"
WinRar 3.11 читает!! сам проверял!!

1. Short 16 Chars - там нет такого метода
2. WinRAR 3.42 пишет неверный формат на файлы сжатые всеми видами алгоритма Huffman

ооочень хорошие исходники!!

1. почти в каждом алгоритме ошибка
2. они не очень хорошо оптимизированы

хммм! интиресно!!
вот попробуй

Сообщение отредактировано: maxim84_ - 06.02.05, 10:54

Прикреплённый файл132.zip (2.84 Кбайт, скачиваний: 137)

че-то я непонял откуда в хафманском файле вот такая штука:

Цитата

HE4 


2876
Rar!

помоему этот архив создан при помощи совсем другой программы

Распокавал?

Всё переведено и подкорректировано, теперь отлавливаются и давятся злостные подлые баги...

Извиняюсь, если не до конца въехал в тему, но
Project->References->CabLib интерфейс ля работы с архивами Cabinet
Это разве не то ?

cablib.dll не входит в стандартную поставку windows и является надстройкой для cabinet.d

Цитата f33l @ 06.02.05, 23:38

Всё переведено и подкорректировано, теперь отлавливаются и давятся злостные подлые баги...

может выложишь? вместе баги будет устранять

Всё, выкладываю, блин.. Мы по-тихому =) договорились со Скинером устранить ошибочку, чтоб можно было сразу выложить полностью работоспособный модуль, однако он опять куда-то пропал..
Итак, в аттаче модуль на VB и несколько файлов из CAB SDK на C, которые, собственно, переводились..

Ошибка возникает при создании временных файлов, а конкретнее, происходит переполнение при передаче имени файла в callback-функцию. Некоторые симптомы наблюдаются ещё до того, вобщем, подебажте и поэкспериментируйте, думаю кто-нить сможет исправить ошибку на свежую голову..
Прикреплённый файлCAB_FCI_API.rar (22.12 Кбайт, скачиваний: 85)

Блин,f33l, тебе делать нечего, как перегонять код из Сей в VB ? Нет, чтобы на сях сделать юзабельную длл и юзать в VB.
Посмотрел исходник. Там все ф-ии CDECL ! И callback-и и FCICreate
ИМХО без ассемблерных вставок вряд ли обойтись. А это такой гемор.
Предлагаю все же рассмотреть вариант с длл на сях

Цитата 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, чтобы это ни значило бы) надеюсь это что-то хорошее)))