Option Explicit
'////////////////////////////////////////////////////////////////////////////////////
'// Модуль для упаковки и распаковки буфера с помощью технологии Delta Compression //
'// Copyright (c) 05.11.2024 by HackerVlad & testuser2                             //
'// E-mail: vladislavpeshkov@yandex.ru                                             //
'// Обсуждение темы: https://www.cyberforum.ru/visual-basic/thread3183774.html     //
'// Версия: 1.0                                                                    //
'////////////////////////////////////////////////////////////////////////////////////
 
Private Const DELTA_FILE_TYPE_RAW@ = 1 / 10000
Private Const DELTA_FLAG_IGNORE_FILE_SIZE_LIMIT@ = 131072 / 10000 ' &H20000 (0x00020000)
 
Private Declare Function CreateDeltaB Lib "msdelta" (Optional ByVal FileTypeSet As Currency = DELTA_FILE_TYPE_RAW, Optional ByVal SetFlags As Currency, Optional ByVal ResetFlags As Currency, Optional ByVal Src_lpcStart As LongPtr, Optional ByVal Src_uSize As LongPtr, Optional ByVal Src_Editable As Long, Optional ByRef Trg_lpcStart As Any, Optional ByVal Trg_uSize As LongPtr, Optional ByVal Trg_Editable As Long, Optional ByVal SrcOpt_lpcStart As LongPtr, Optional ByVal SrcOpt_uSize As LongPtr, Optional ByVal SrcOpt_Editable As Long, Optional ByVal TrgOpt_lpcStart As LongPtr, Optional ByVal TrgOpt_uSize As LongPtr, Optional ByVal TrgOpt_Editable As Long, Optional ByVal GlbOpt_lpcStart As LongPtr, Optional ByVal GlbOpt_uSize As LongPtr, Optional ByVal GlbOpt_Editable As Long, Optional ByVal lpTargetFileTime As LongPtr, Optional ByVal HashAlgId As Long, Optional ByRef lpDelta As Any) As Long
Private Declare Function ApplyDeltaB Lib "msdelta" (ByVal ApplyFlags As Currency, ByVal Src_lpcStart As LongPtr, ByVal Src_uSize As LongPtr, ByVal Src_Editable As Long, ByRef Dlt_lpcStart As Any, ByVal Dlt_uSize As LongPtr, ByVal Dlt_Editable As Long, ByRef lpTarget As DELTA_OUTPUT) As Long
Private Declare Function DeltaFree Lib "msdelta" (ByVal lpMemory As LongPtr) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
'## Раскомментировать в VB6 ##
Private Enum LongPtr
    [_]
End Enum
'#############################
 
Private Type DELTA_OUTPUT
    lpStart As LongPtr
    uSize As LongPtr
End Type
 
' Упаковать (сжать) данные байтового массива
Public Function CompressDeltaB(byteArray() As Byte) As Boolean
    On Error GoTo Quit
    
    Dim DO_Res As DELTA_OUTPUT
    Dim ret As Long
    
    ret = CreateDeltaB(SetFlags:=DELTA_FLAG_IGNORE_FILE_SIZE_LIMIT, Trg_lpcStart:=byteArray(0), Trg_uSize:=UBound(byteArray) + 1, lpDelta:=DO_Res)
    
    If ret Then
        With DO_Res
            ReDim byteArray(.uSize - 1)
            CopyMemory byteArray(0), ByVal .lpStart, .uSize
            DeltaFree (.lpStart)
        End With
        
        CompressDeltaB = True
    End If
Quit:
End Function
 
' Распаковать (извлечь) данные байтового массива
Public Function DeCompressDeltaB(byteArray() As Byte) As Boolean
    On Error GoTo Quit
    
    Dim DO_Res As DELTA_OUTPUT
    Dim ret As Long
    
    ret = ApplyDeltaB(0, 0, 0, 0, byteArray(0), UBound(byteArray) + 1, 0, DO_Res)
    
    If ret Then
        With DO_Res
            If .lpStart Then
                ReDim byteArray(.uSize - 1)
                CopyMemory byteArray(0), ByVal .lpStart, .uSize
                DeltaFree (.lpStart)
            End If
        End With
        
        DeCompressDeltaB = True
    End If
Quit:
End Function

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" (ByVal dwInitial As Long, ByVal pData As Long, ByVal iLen As Long) As Long
Dim buf() As Byte
 
Public Function Crc32Api(tBuff() As Byte) As Long
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function
 
Private Sub Command1_Click()
    Dim FileNo As Integer
    Dim fLen As Long
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    ' Открыть файл
    Open App.Path + "\" + Text1.Text For Binary As FileNo
        fLen = LOF(FileNo)
        ReDim buf(fLen - 1)
        Get #FileNo, , buf
    Close FileNo
    
    Print "ubound: " & UBound(buf)
    Print "Контрольная сумма: " & Hex(Crc32Api(buf))
    
    'On Error Resume Next
    'Clipboard.SetText Crc32Api(buf)
End Sub
 
Private Sub Command10_Click()
    Dim tick As Long
    Dim result As Boolean
    
    tick = GetTickCount
    
    result = DeCompressDeltaB(buf)
    Print result
    
    Print (GetTickCount - tick)
    If result = True Then Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command2_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    Compress_Huffman_Dynamic buf
    
    Print (GetTickCount - tick)
    Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command3_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    DeCompress_Huffman_Dynamic buf
    
    Print (GetTickCount - tick)
    Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command4_Click()
    Dim tick As Long
    Dim result As Boolean
    
    tick = GetTickCount
    
    result = Compress_NT(buf)
    Print result
    
    Print (GetTickCount - tick)
    If result = True Then Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command5_Click()
    Dim tick As Long
    Dim result As Boolean
    
    tick = GetTickCount
    
    result = DeCompress_NT(buf)
    Print result
    
    Print (GetTickCount - tick)
    If result = True Then Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command6_Click()
    Dim FileNo As Integer
    
    ' Инициализировать счётчик
    FileNo = FreeFile
    
    If IsFileAPI(App.Path + "\" + Text2.Text) <> 0 Then Kill App.Path + "\" + Text2.Text
    
    ' Открыть файл
    Open App.Path + "\" + Text2.Text For Binary As FileNo
        Put #FileNo, , buf
    Close FileNo
End Sub
 
Private Sub Command7_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    Compress_HuffManShortDictRC4 buf, "123BB"
    
    Print (GetTickCount - tick)
    Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command8_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    Decompress_HuffmanShortDictRC4 buf, "123BB"
    
    Print (GetTickCount - tick)
    Print "ubound: " & UBound(buf)
End Sub
 
Private Sub Command9_Click()
    Dim tick As Long
    Dim result As Boolean
    
    tick = GetTickCount
    
    result = CompressDeltaB(buf)
    Print result
    
    Print (GetTickCount - tick)
    If result = True Then Print "ubound: " & UBound(buf)
End Sub

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
' Список файлов в каталоге с помощью VB6
Public Function ListFiles(Directory As String, StrArray() As String, Optional HiddenFiles As Boolean = True, Optional Mask As String = "*.*") As Long
    Dim FileName As String
    Dim cnt As Long
    
    If Right(Directory, 1) <> "\" Then
        Directory = Directory + "\"
    Else
        If Mid(Directory, Len(Directory) - 1, 1) = "\" Then Exit Function
    End If
    
    If HiddenFiles = True Then
        FileName = Dir(Directory + Mask, 7)
    Else
        FileName = Dir(Directory + Mask, vbNormal)
    End If
    
    Do While FileName <> vbNullString
        ReDim Preserve StrArray(cnt)
        StrArray(cnt) = FileName
        cnt = cnt + 1
        
        FileName = Dir$ ' Переход к следующей интерации
    Loop
    
    If cnt > 0 Then ListFiles = cnt
End Function
 
Private Sub Command1_Click()
    Dim tick As Long
    
    tick = GetTickCount
    
    Me.Cls
    Print CabinetAddFiles(Text1.Text, Text2.Text)
    Print (GetTickCount - tick) & " ml"
End Sub
 
Private Sub Command2_Click()
    MsgBox Chr(34) & CabinetExtractFileName(Text1.Text) & Chr(34), vbInformation
End Sub
 
Private Sub Command3_Click()
    MsgBox Chr(34) & CabinetExtractFilePath(Text1.Text) & Chr(34), vbInformation
End Sub
 
Private Sub Command4_Click()
    Dim i As Long
    Dim arrFullFileName() As String
    Dim arrDestinationFileName() As String
    Dim tick As Long
    
    Screen.MousePointer = 11
    
    If List1.ListCount > 0 Then
        For i = 0 To List1.ListCount - 1
            If List1.Selected(i) = True Then
                CabinetInsertArrayString arrFullFileName, App.Path & "\Test\" & List1.List(i)
                CabinetInsertArrayString arrDestinationFileName, "Test\" & List1.List(i)
            End If
        Next
        
        If CabinetIsArrayInitialized(arrFullFileName) = True Then
            ' Добавим в этот список ещё так же файл App.Path & "\test.txt" для примера того что можно добавлять файлы из разных папок
            CabinetInsertArrayString arrFullFileName, App.Path & "\test.txt"
            CabinetInsertArrayString arrDestinationFileName, "Test\SubDir2\test.txt"
            
            Me.Cls
            tick = GetTickCount
            
            ' Упаковать файлы
            Print CabinetAddFiles(Text3.Text, arrFullFileName, arrDestinationFileName)
            Print (GetTickCount - tick) & " ml"
        Else
            Beep
        End If
    End If
    
    Screen.MousePointer = 0
End Sub
 
Private Sub Form_Load()
    Dim arrFiles() As String
    Dim i As Long
    Dim cnt As Long
    
    Text1.Text = App.Path & "\test.cab"
    Text2.Text = App.Path & "\test.txt"
    Text3.Text = App.Path & "\Test\test.cab"
    
    cnt = ListFiles(App.Path & "\Test", arrFiles)
    
    If cnt > 0 Then
        For i = 0 To UBound(arrFiles)
            If arrFiles(i) <> "test.cab" Then
                List1.AddItem arrFiles(i)
            Else
                cnt = cnt - 1
            End If
        Next
        
        Label4.Caption = "Файлов: " & cnt
    End If
End Sub

Option Explicit
Private Declare Function GetFileAttributesEx Lib "kernel32" Alias "GetFileAttributesExW" (ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByRef lpFileInformation As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (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 WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SHCreateDirectory Lib "shell32" (ByVal hwnd As Long, ByVal pszPath As Long) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileW" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long, ByVal bFailIfExists As BOOL) As Long
 
Private Const GetFileExInfoStandard As Long = 0
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const CREATE_ALWAYS = 2
 
Private Type WIN32_FILE_ATTRIBUTE_DATA
    dwFileAttributes    As Long
    ftCreationTime      As Currency
    ftLastAccessTime    As Currency
    ftLastWriteTime     As Currency
    nFileSizeHigh       As Long
    nFileSizeLow        As Long
End Type
 
Private Enum BOOL
    cFalse
    cTrue
End Enum
 
Dim Steps As Byte
Dim DirPath1 As String
Dim DirPath2 As String
Dim INIPath As String
Dim IsProcessed As Boolean
 
Private Function IsDir(ByVal path As String) As Boolean
    Dim tAttr As WIN32_FILE_ATTRIBUTE_DATA
    
    If GetFileAttributesEx(StrPtr(path), GetFileExInfoStandard, tAttr) <> 0 Then
        If (tAttr.dwFileAttributes And vbDirectory) <> 0 Then ' Если это каталог
            IsDir = True
        End If
    End If
End Function
 
Private Sub Command1_Click()
    Dim str As String
    Dim InitDir As String
    
    If IsDir(DirPath1) = True Then
        InitDir = DirPath1
    Else
        InitDir = AppPath
    End If
    
    str = BrowseForFolder(hwnd, "Выберите каталог," & vbNewLine & _
    "из которого, нужно копировать файлы:", _
    InitDir, True, 1.3, 1.5, True, True, True, True, SetFocusTreeView:=True)
    
    If Len(str) > 0 Then
        DirPath1 = str
        Text1.Text = DirPath1
    End If
End Sub
 
Private Sub Command2_Click()
    Dim str1 As String
    Dim str2 As String
    
    str1 = Text1.Text
    str2 = Text2.Text
    
    If str1 <> vbNullString And str2 <> vbNullString Then
        Text1.Text = str2
        Text2.Text = str1
    End If
End Sub
 
Private Sub Command3_Click()
    Dim str As String
    Dim InitDir As String
    
    If IsDir(DirPath2) = True Then
        InitDir = DirPath2
    Else
        InitDir = AppPath
    End If
    
    str = BrowseForFolder(hwnd, "Выберите каталог," & vbNewLine & _
    "куда, нужно копировать файлы:", _
    InitDir, True, 1.3, 1.5, True, True, True, True, SetFocusTreeView:=True)
    
    If Len(str) > 0 Then
        DirPath2 = str
        Text2.Text = DirPath2
    End If
End Sub
 
Private Sub Command4_Click()
    Dim i As Long
    Dim MyArray() As String
    Dim cnt As Long
    Dim Procent As Long
    Dim FileSource As String
    Dim FileDestination As String
    
    If IsProcessed = False Then
        If Right$(DirPath1, 1) = "\" Then
            DirPath1 = Mid(DirPath1, 1, Len(DirPath1) - 1)
        End If
        If Right$(DirPath2, 1) = "\" Then
            DirPath2 = Mid(DirPath2, 1, Len(DirPath2) - 1)
        End If
        
        If IsDir(Text1.Text) = True Then DirPath1 = Text1.Text
        DirPath2 = Text2.Text
        
        If Len(DirPath1) > 0 Then
            If Len(DirPath2) > 0 Then
                IsProcessed = True
                
                If IsDir(DirPath1) = False Then
                    Beep
                    Text1.SetFocus
                    IsProcessed = False
                    Exit Sub
                End If
                
                If IsDir(DirPath2) = False Then
                    If SHCreateDirectory(0, StrPtr(DirPath2)) <> 0 Then
                        MsgBox "Каталог назначения не найден и не может быть создан!", vbExclamation
                        Text2.SetFocus
                        IsProcessed = False
                        Exit Sub
                    End If
                End If
                
                Screen.MousePointer = 13
                Command4.Enabled = False
                Text1.Locked = True
                Text2.Locked = True
                
                If ListFilesOrDirsAPI(DirPath1, MyArray, True) > 0 Then
                    If Steps <> 1 Then
                        For i = 0 To UBound(MyArray) Step Steps
                            cnt = cnt + 1
                            
                            If cnt <= CLng(UBound(MyArray) / Steps) Then
                                Procent = cnt * (100 / CLng(UBound(MyArray) / Steps))
                                If Procent > 100 Then Procent = 100
                                Me.Caption = Procent & "% завершено (" & cnt & " из " & CLng(UBound(MyArray) / Steps) & ")"
                            End If
                            
                            DoEvents
                            
                            FileSource = DirPath1 & "\" & MyArray(i)
                            FileDestination = DirPath2 & "\" & MyArray(i)
                            
                            CopyFile StrPtr(FileSource), StrPtr(FileDestination), cTrue
                        Next
                    Else
                        For i = 0 To UBound(MyArray)
                            cnt = cnt + 1
                            
                            If cnt <= UBound(MyArray) Then
                                Procent = cnt * (100 / UBound(MyArray))
                                If Procent > 100 Then Procent = 100
                                Me.Caption = Procent & "% завершено (" & cnt & " из " & (UBound(MyArray) + 1) & ")"
                            End If
                            
                            DoEvents
                            
                            FileSource = DirPath1 & "\" & MyArray(i)
                            FileDestination = DirPath2 & "\" & MyArray(i)
                            
                            CopyFile StrPtr(FileSource), StrPtr(FileDestination), cTrue
                        Next
                    End If
                Else
                    'Beep
                End If
                
                Text1.Locked = False
                Text2.Locked = False
                IsProcessed = False
                Command4.Enabled = True
                
                Screen.MousePointer = 0
                Me.Caption = "Step Copyer v. 1.0 by HackerVlad"
                Beep
            Else
                MsgBox "Каталог не задан!", vbInformation
            End If
        Else
            MsgBox "Каталог не задан!", vbInformation
        End If
    Else
        Beep
    End If
End Sub
 
Private Sub Form_Load()
    Dim pIn As String
    Dim pOut As String
    Dim StepsStr As String
    
    INIPath = AppPath & "\" & AppEXENameWithoutExtension & ".ini"
    
    pIn = GetPrivateINIString("Paths", "In", INIPath)
    If pIn <> vbNullString Then
        DirPath1 = pIn
        Text1.Text = pIn
    Else
        DirPath1 = Text1.Text
    End If
    
    pOut = GetPrivateINIString("Paths", "Out", INIPath)
    If pOut <> vbNullString Then
        DirPath2 = pOut
        Text2.Text = pOut
    Else
        DirPath2 = Text2.Text
    End If
    
    StepsStr = GetPrivateINIString("CopyMode", "Step", INIPath)
    If StepsStr <> vbNullString Then Steps = StepsStr
    
    If Steps = 3 Then Option1.Value = True
    If Steps = 2 Then Option2.Value = True
    If Steps = 1 Then Option3.Value = True
    If Steps = 0 Then Steps = 2
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Dim stringbuffer As String
    Dim hFile As Long
    
    hFile = CreateFile(StrPtr(INIPath), GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_ARCHIVE, 0)
    
    If hFile <> INVALID_HANDLE_VALUE Then
        stringbuffer = ChrW(&HFEFF) & "; Step Copyer v. 1.0" & vbNewLine & "; Copyright © 2024 by HackerVlad" & vbNewLine & "; e-mail: vladislavpeshkov@yandex.ru" & vbNewLine & vbNewLine & _
        "[Paths]" & vbNewLine & _
        "In = " & DirPath1 & vbNewLine & _
        "Out = " & DirPath2 & vbNewLine & vbNewLine & _
        "[CopyMode]" & vbNewLine & _
        "Step = " & Steps
        
        WriteFile hFile, StrPtr(stringbuffer), LenB(stringbuffer), 0, ByVal 0&
        CloseHandle hFile
    End If
    
    End
End Sub
 
Private Sub Option1_Click()
    Steps = 3
End Sub
 
Private Sub Option2_Click()
    Steps = 2
End Sub
 
Private Sub Option3_Click()
    Steps = 1
End Sub
 
Private Sub Text1_Change()
    Dim strW As String
    
    If IsProcessed = False Then
        strW = Text1.Text
        
        If DirPath1 <> strW Then
            If IsDir(strW) = True Then
                If InStr(1, strW, Chr(&H3F)) = 0 Then
                    DirPath1 = strW
                End If
            End If
        End If
    End If
End Sub
 
Private Sub Text2_Change()
    Dim strW As String
    
    If IsProcessed = False Then
        strW = Text2.Text
        
        If DirPath2 <> strW Then
            If InStr(1, strW, Chr(&H3F)) = 0 Then
                DirPath2 = strW
            End If
        End If
    End If
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Command4_Click
    End If
End Sub
 
Private Sub Text2_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Command4_Click
    End If
End Sub

Private Sub testStrCompLogicalVB()
    Dim s1$, s2$
    s1 = "sa2dfs10f"
    s2 = "sa2dfs9f"
    Debug.Print StrCompLogicalVB(s2, s1) '1 (больше)
End Sub
 
Function StrCompLogicalVB(Str1 As String, Str2 As String) As Long
    Static iStr1%(), iStr2%()
    Dim i1&, i2&, Ln1&, Ln2&, Num1&, Num2&, Char1%, Char2%
    
'    If StrPtr(Str1) = StrPtr(Str2) Then Exit Function
    Ln1 = Len(Str1): Ln2 = Len(Str2)
    If Ln1 <> Ln2 Then
        If Ln1 = 0 Then StrCompLogicalVB = -1: Exit Function
        If Ln2 = 0 Then StrCompLogicalVB = 1: Exit Function
    End If
    ReDim Preserve iStr1(Ln1), iStr2(Ln2)
    CopyMemory iStr1(1), ByVal StrPtr(Str1), LenB(Str1)
    CopyMemory iStr2(1), ByVal StrPtr(Str2), LenB(Str2)
    
    For i1 = 1 To Ln1
        i2 = i2 + 1
        If i2 > Ln2 Then StrCompLogicalVB = 1: Exit Function
        Char1 = iStr1(i1)
        Char2 = iStr2(i2)
        Select Case Char1
        Case Is = Char2
        Case 48 To 57
            Select Case Char2
            Case 48 To 57
                GetNumberFromString Str2, iStr2, Num2, i2
            Case Else: StrCompLogicalVB = -1: Exit Function
            End Select
            GetNumberFromString Str1, iStr1, Num1, i1
            Select Case Num1
            Case Is < Num2: StrCompLogicalVB = -1: Exit Function
            Case Is > Num2: StrCompLogicalVB = 1: Exit Function
            End Select
        Case Is < Char2: StrCompLogicalVB = -1: Exit Function
        Case Is > Char2: StrCompLogicalVB = 1: Exit Function
        End Select
    Next
    If Ln2 > Ln1 Then StrCompLogicalVB = -1: Exit Function
End Function
'Получение числового значения номера из строки sBuf с заданой позиции Ind. Возвращаемое значение - индекс, идущий после строкового значения номера
Private Function GetNumberFromString(sBuf$, iBuf%(), NumOut&, Optional ByVal Ind& = 1) As Long
    Dim Bgn&, NumLen&
    Bgn = Ind: NumLen = 1
    For Ind = Ind + 1 To Len(sBuf) 'Ubound(iStr)
        Select Case iBuf(Ind)
        Case 48 To 57: NumLen = NumLen + 1
        Case Else: Exit For
        End Select
    Next
    NumOut = Mid$(sBuf, Bgn, NumLen)
    GetNumberFromString = Ind
End Function

Option Explicit
'/////////////////////////////////////////////////////////////////////////////////
'// Module for correctly get the full path processes in all versions of Windows //
'// Copyright (c) 19.12.2024 by HackerVlad                                      //
'// E-mail: vladislavpeshkov@ya.ru                                              //
'// Version 3.5                                                                 //
'/////////////////////////////////////////////////////////////////////////////////
 
' API declarations ...
Private Declare Function NtQuerySystemInformation Lib "ntdll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal src As Long, dst As Any) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long)
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal uSize As Long) As Long
Private Declare Function GetModuleFileNameExW Lib "psapi" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As Long, ByVal nSize As Long) As Long
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal olestr As Long, ByVal Length As Long) As Long
Private Declare Function CommandLineToArgv Lib "shell32" Alias "CommandLineToArgvW" (ByVal lpCmdLine As Long, pNumArgs As Integer) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal bstr As Long)
Private Declare Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProc As Long, bWow64Process As Long) As Long
 
' Undocumented APIs ...
Private Declare Function NtWow64QueryInformationProcess64 Lib "ntdll" (ByVal ProcessHandle As Long, ByVal InformationClass As Long, ByRef ProcessInformation As Any, ByVal ProcessInformationLength As Long, ByRef ReturnLength As Long) As Long
Private Declare Function NtWow64ReadVirtualMemory64 Lib "ntdll" (ByVal hProcess As Long, ByVal BaseAddress As Currency, ByRef Buffer As Any, ByVal BufferLengthL As Long, ByVal BufferLengthH As Long, ByRef ReturnLength As Currency) As Long
 
' Constants ...
Private Const SystemProcessIdInformation = 88
Private Const ProcessBasicInformation = 0
Private Const STATUS_SUCCESS As Long = 0
Private Const MAX_PATH = 260
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Const PROCESSOR_ARCHITECTURE_AMD64 As Integer = 9
Private Const PROCESSOR_ARCHITECTURE_IA64 As Integer = 6
 
' Types ...
Private Type UNICODE_STRING
    Length As Integer
    MaxLength As Integer
    lpBuffer As Long
End Type
 
Private Type SYSTEM_PROCESS_ID_INFORMATION
    ProcessId As Long
    ImageName As UNICODE_STRING
End Type
 
Private Type PROCESS_BASIC_INFORMATION_WOW64
    ExitStatus As Long
    Reserved0 As Long
    PebBaseAddress As Currency
    AffinityMask As Currency
    BasePriority As Long
    Reserved1 As Long
    UniqueProcessId As Currency
    InheritedFromUniqueProcessId As Currency
End Type
 
Private Type UNICODE_STRING64
    Length As Integer
    MaxLength As Integer
    Fill As Long
    lpBuffer As Currency
End Type
 
Private Type SYSTEM_INFO
    wProcessorArchitecture As Integer
    wReserved As Integer
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    wProcessorLevel As Integer
    wProcessorRevision As Integer
End Type
 
' Variables for caching ...
Dim MajorWinVer As Long
Dim ArrDosDevice() As String
Dim IsInitArrDosDevice As Boolean, IsInitMyOSIs64bit As Boolean, MyOSIs64bit As Boolean
 
' Its my function that caches data and replaces the QueryDosDevice call API
Private Function MyQueryDosDeviceCache(ByVal lpDeviceName As String) As String
    Dim countChars As Long, i As Long, cnt As Long
    Dim DosDeviceName As String
    
    If IsInitArrDosDevice = True Then
        For i = 0 To UBound(ArrDosDevice, 2)
            If ArrDosDevice(0, i) = lpDeviceName Then
                MyQueryDosDeviceCache = ArrDosDevice(1, i)
                Exit Function
            End If
        Next
        
        cnt = UBound(ArrDosDevice, 2) + 1 ' Since the position we need has not been found, we need to add a new position
    End If
    
    DosDeviceName = Space$(2048)
    countChars = QueryDosDevice(StrPtr(lpDeviceName), StrPtr(DosDeviceName), 2048)
    
    If countChars > 0 Then
        DosDeviceName = Left$(DosDeviceName, countChars)
        DosDeviceName = Replace$(DosDeviceName, vbNullChar, "")
    End If
    
    ReDim Preserve ArrDosDevice(1, cnt) As String
    ArrDosDevice(0, cnt) = lpDeviceName
    ArrDosDevice(1, cnt) = DosDeviceName
    
    IsInitArrDosDevice = True
    MyQueryDosDeviceCache = DosDeviceName
End Function
 
' Get the full path to the process using the NtQuerySystemInformation function
' Before Windows 10, sometimes it may incorrect to get the path to the process
Public Function GetProcessFullPathNt(ByVal pid As Long, Optional SaveSystemPath As Boolean, Optional Caching As Boolean = True) As String
    Dim ProcName As String, sDrives As String, strBuff As String, DosDeviceName As String
    Dim cbRet As Long, cbMax As Long, cnt As Long, i As Long
    Dim spii As SYSTEM_PROCESS_ID_INFORMATION
    Dim aDrive() As String
    
    If pid = 0 Then
        GetProcessFullPathNt = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathNt = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    cbMax = MAX_PATH * 2
    PutMem4 VarPtr(ProcName), SysAllocStringLen(0&, cbMax)
    
    spii.ProcessId = pid ' Fafalone wrote this line of code
    spii.ImageName.MaxLength = cbMax ' Fafalone wrote this line of code
    spii.ImageName.lpBuffer = StrPtr(ProcName) ' HackerVlad wrote this line of code
    
    If NtQuerySystemInformation(SystemProcessIdInformation, spii, LenB(spii), cbRet) >= 0 Then ' Technology from fafalone
        ProcName = Left$(ProcName, spii.ImageName.Length / 2)
        GetProcessFullPathNt = ProcName
        
        If SaveSystemPath = False Then
            PutMem4 VarPtr(sDrives), SysAllocStringLen(0&, 2048)
            cnt = GetLogicalDriveStrings(2048, StrPtr(sDrives)) ' HackerVlad's technology of getting all the letters of the drives
            
            If Err.LastDllError = 0 Then
                aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
                
                For i = 0 To UBound(aDrive)
                    If Caching = True Then
                        DosDeviceName = MyQueryDosDeviceCache(Left$(aDrive(i), 2)) & "\" ' HackerVlad's caching technology
                    Else
                        PutMem4 VarPtr(strBuff), SysAllocStringLen(0&, 2048)
                        
                        If QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(strBuff), 2048) Then
                            DosDeviceName = Left$(strBuff, lstrlen(StrPtr(strBuff))) & "\"
                        End If
                        
                        SysFreeString StrPtr(strBuff)
                    End If
                    
                    If Left$(ProcName, Len(DosDeviceName)) = DosDeviceName Then
                        GetProcessFullPathNt = Left$(aDrive(i), 2) & Mid$(ProcName, Len(DosDeviceName))
                        Exit Function
                    Else
                        If InStr(1, ProcName, DosDeviceName, vbTextCompare) > 0 Then ' Retrying
                            GetProcessFullPathNt = Replace$(ProcName, DosDeviceName, Left$(aDrive(i), 2) & "\", 1, 1, vbTextCompare)
                            Exit Function
                        End If
                    End If
                Next
            End If
        End If
    End If
End Function
 
' This function should get the correct paths, unlike another functions which can sometimes cheat
Public Function GetProcessFullPathCorrect(ByVal pid As Long) As String
    Dim hProc As Long, lpwstr As Long, CmdStringPtr As Long, lengthPathWinDir As Long, IsProcRunWOW64 As Long
    Dim strProcName As String, strProcName2 As String, PathWinDir As String
    Dim pbi64 As PROCESS_BASIC_INFORMATION_WOW64
    Dim cmd64 As UNICODE_STRING64
    Dim pParam64 As Currency
    Dim cnt As Integer
    
    If pid = 0 Then
        GetProcessFullPathCorrect = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathCorrect = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, pid)
    
    If hProc > 0 Then
        ' First of all, you need to find out if the OS is 32-bit or 64-bit?
        If IsInitMyOSIs64bit = False Then
            Dim si As SYSTEM_INFO
            
            GetNativeSystemInfo si
            MyOSIs64bit = (si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Or si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64)
            
            IsInitMyOSIs64bit = True
        End If
        If MyOSIs64bit = True Then IsWow64Process hProc, IsProcRunWOW64
        
        If IsProcRunWOW64 = 1 Or MyOSIs64bit = False Then ' 32-bit process
            strProcName = Space$(MAX_PATH)
            If GetModuleFileNameExW(hProc, 0, StrPtr(strProcName), MAX_PATH) Then
                strProcName = Left$(strProcName, lstrlen(StrPtr(strProcName)))
            End If
        Else ' 64-bit process
            #If Win32 Then
                If NtWow64QueryInformationProcess64(hProc, ProcessBasicInformation, pbi64, Len(pbi64), 0) = STATUS_SUCCESS Then
                    If NtWow64ReadVirtualMemory64(hProc, pbi64.PebBaseAddress + 0.0032@, pParam64, Len(pParam64), 0, 0) = STATUS_SUCCESS Then
                        If NtWow64ReadVirtualMemory64(hProc, pParam64 + 0.0112@, cmd64, Len(cmd64), 0, 0) = STATUS_SUCCESS Then
                            If cmd64.Length > 0 Then
                                strProcName = Space$(cmd64.Length / 2) ' We allocate a buffer of sufficient length
                                NtWow64ReadVirtualMemory64 hProc, cmd64.lpBuffer, ByVal StrPtr(strProcName), cmd64.Length, 0, 0
                                
                                If Len(strProcName) > 0 Then
                                    strProcName2 = strProcName
                                    strProcName = vbNullString
                                    lpwstr = CommandLineToArgv(StrPtr(strProcName2), cnt)
                                    
                                    If lpwstr Then
                                        GetMem4 lpwstr, CmdStringPtr
                                        PutMem4 VarPtr(strProcName), SysAllocStringLen(CmdStringPtr, lstrlen(CmdStringPtr))
                                        LocalFree lpwstr
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            #End If
        End If
        
        CloseHandle hProc
        
        If Left$(strProcName, 12) = "\SystemRoot\" And strProcName <> "\SystemRoot\" Then
            PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
            lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
            PathWinDir = Left$(PathWinDir, lengthPathWinDir)
            
            strProcName = PathWinDir & Mid$(strProcName, 12)
        End If
        If Left$(strProcName, 13) = "%SystemRoot%\" And strProcName <> "%SystemRoot%\" Then
            If Len(PathWinDir) = 0 Then
                PutMem4 VarPtr(PathWinDir), SysAllocStringLen(0&, MAX_PATH)
                lengthPathWinDir = GetWindowsDirectory(StrPtr(PathWinDir), MAX_PATH)
                PathWinDir = Left$(PathWinDir, lengthPathWinDir)
            End If
            
            strProcName = PathWinDir & Mid$(strProcName, 13)
        End If
        If Left$(strProcName, 4) = "\??\" And strProcName <> "\??\" Then
            strProcName = Mid$(strProcName, 5)
        End If
        
        GetProcessFullPathCorrect = strProcName
    End If
End Function
 
' Universal function
Public Function GetProcessFullPathUniversal(ByVal pid As Long, Optional Caching As Boolean = True) As String
    Dim MajorWindowsVersion As Long
    Dim ProcName As String
    
    If pid = 0 Then
        GetProcessFullPathUniversal = "[System idle process]"
    ElseIf pid = 4 Then
        GetProcessFullPathUniversal = "[System]"
    End If
    If pid = 0 Or pid = 4 Then Exit Function
    
    If MajorWinVer = 0 Then
        GetMem4 &H7FFE026C, MajorWindowsVersion ' Get the Windows version
        MajorWinVer = MajorWindowsVersion ' Save
    End If
    
    If MajorWinVer < 10 Then ' Old versions Windows
        ProcName = GetProcessFullPathCorrect(pid) ' Technology from HackerVlad
    Else ' Windows 10 and latter
        GetProcessFullPathUniversal = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
        Exit Function
    End If
    
    If InStr(1, ProcName, "\") = 0 Then ' Retrying
        ProcName = GetProcessFullPathNt(pid, , Caching) ' Technology from fafalone
    End If
    
    GetProcessFullPathUniversal = ProcName
End Function