Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) As Long
 
Private Sub Command1_Click()
    Text1.Text = GetCurrentProcessId
    
    ' Загрузить процессор на 100%
    Do
        DoEvents
    Loop
End Sub
 
Private Sub Command2_Click()
    Dim hwnd As Long
    Dim pid As Long
    
    hwnd = FindWindow(vbNullString, "Program Manager")
    GetWindowThreadProcessId hwnd, pid ' Определить PID процесса Explorer
    
    Text1.Text = pid
End Sub
 
Private Sub Command3_Click()
    Dim i As Long
    
    Do
        For i = 0 To 30000
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command4_Click()
    Dim i As Long
    
    Do
        For i = 0 To 15000
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command5_Click()
    Text1.Text = GetCurrentProcessId
End Sub
 
Private Sub Command6_Click()
    Dim i As Long
    
    Do
        For i = 0 To 7500
            DoEvents
        Next
        
        Sleep 50
    Loop
End Sub
 
Private Sub Command7_Click()
    Dim hThread As Long
    
    flag = 1
    
    hThread = CreateThread(ByVal 0&, 0, AddressOf thread, ByVal 0&, 0, 0)
    CloseHandle hThread
End Sub
 
Private Sub Form_Load()
    Text1.Text = GetCurrentProcessId
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    flag = 0
    End
End Sub
 
Private Sub Timer1_Timer()
    If Text1.Text = "" Then Exit Sub
    
    If Text1.Text = GetCurrentProcessId Then
        Label1.Caption = "My PID: "
        Label2.Caption = "My PID: "
    Else
        Label1.Caption = "Another PID: "
        Label2.Caption = "Another PID: "
    End If
    
    Label1.Caption = Label1.Caption & GetProcessUsage(Text1.Text) & "%    это показание менее точное как в обычном диспетчере задач" ' Это точно правильно работает
    Label2.Caption = Label2.Caption & GetProcessUsageByCycleTime(Text1.Text) & "%    это показание более точное, как в программе ProcessHacker" ' А вот тут я не очень уверен
End Sub

Option Explicit
'/////////////////////////////////////////////////////////////
'// Модуль определения загрузки ЦП для конкретного процесса //
'// Copyright (c) 07.04.2023 by HackerVlad                  //
'// e-mail: vladislavpeshkov@yandex.ru                      //
'// Версия 2.0                                              //
'/////////////////////////////////////////////////////////////
 
' Декларации API
Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, ByRef dstValue As Long) As Long
Private Declare Function GetMem8 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function QueryProcessCycleTime Lib "kernel32" (ByVal ProcessHandle As Long, CycleTime As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (ByRef lpPerformanceCount As Currency) 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 Const SystemProcessInformation As Long = &H5
Private Const STATUS_INFO_LENGTH_MISMATCH As Long = &HC0000004
Private Const STATUS_SUCCESS As Long = 0
Private Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
 
' Типы
Private Type SYSTEM_INFO
    dwOemID                     As Long
    dwPageSize                  As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask       As Long
    dwNumberOfProcessors        As Long
    dwProcessorType             As Long
    dwAllocationGranularity     As Long
    wProcessorLevel             As Integer
    wProcessorRevision          As Integer
End Type
 
' Вычислить загрузку ЦП конкретного запущенного процесса
Public Function GetProcessUsage(Optional pid As Long) As Single
    Dim buf() As Byte
    Dim ret As Long
    Dim getpid As Long
    Dim Offset As Long
    Dim deltaOffset As Long
    Dim UserTime As Currency
    Dim KernelTime As Currency
    Dim UserTimeRet As Currency
    Dim KernelTimeRet As Currency
    Dim GetProcessUsageRet As Currency
    Static OldUserTime As Currency
    Static OldKernelTime As Currency
    Static FirstRun As Boolean
    Dim SInfo As SYSTEM_INFO
    
    If pid = 0 Then pid = GetCurrentProcessId
    
    If NtQuerySystemInformation(SystemProcessInformation, ByVal 0&, 0&, ret) = STATUS_INFO_LENGTH_MISMATCH Then
        ReDim buf(ret - 1)
        
        If NtQuerySystemInformation(SystemProcessInformation, buf(0), ret, ret) = STATUS_SUCCESS Then
            Do
                GetMem4 buf(Offset + &H44), getpid
                If getpid = pid Then ' Эти значения ни чем не отличаются от полученных с помощью GetProcessTimes
                    GetMem8 buf(Offset + &H28), UserTime
                    GetMem8 buf(Offset + &H30), KernelTime
                    Exit Do
                End If
                
                GetMem4 buf(Offset), deltaOffset
                Offset = Offset + deltaOffset
            Loop While deltaOffset
        End If
    End If
    
    If UserTime > 0 And KernelTime > 0 Then
        If FirstRun = False Then
            FirstRun = True
            
            OldUserTime = UserTime
            OldKernelTime = KernelTime
            GetProcessUsage = "0"
            Exit Function
        Else
            GetSystemInfo SInfo
            
            UserTimeRet = (UserTime - OldUserTime)
            KernelTimeRet = (KernelTime - OldKernelTime)
            
            GetProcessUsageRet = (UserTimeRet + KernelTimeRet) / 10 / SInfo.dwNumberOfProcessors
            If GetProcessUsageRet > 100 Then GetProcessUsageRet = 100
            
            GetProcessUsage = Round(GetProcessUsageRet, 2)
            
            OldUserTime = UserTime
            OldKernelTime = KernelTime
        End If
    Else
        GetProcessUsage = "0" ' Иногда UserTime или KernelTime почему-то может быть сразу нулём
    End If
End Function
 
' Вычислить загрузку ЦП конкретного запущенного процесса для Windows Vista и выше
Public Function GetProcessUsageByCycleTime(Optional pid As Long) As Single
    Dim hProc As Long
    Dim CycleTime As Currency
    Dim CyclesDelta As Currency
    Dim ProcessCycles As Currency
    Dim ProcessCycleDelta As Currency
    Dim SInfo As SYSTEM_INFO
    Dim ProcessUsagePercent As Single
    Static OldProcessCycles As Currency
    Static OldCycleTime As Currency
    Static FirstRun As Boolean
    
    If pid = 0 Then
        hProc = GetCurrentProcess()
    Else
        hProc = OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, 0, pid)
    End If
    
    If hProc <> 0 Then
        QueryProcessCycleTime hProc, ProcessCycles
        
        If ProcessCycles > 0 Then
            GetSystemInfo SInfo
            
            If FirstRun = False Then
                FirstRun = True
                
                OldProcessCycles = ProcessCycles
                QueryPerformanceCounter OldCycleTime ' Здесь оказывается важно ещё запоминать QueryPerformanceCounter
                
                GetProcessUsageByCycleTime = 0
                Exit Function
            Else
                QueryPerformanceCounter CycleTime
                CyclesDelta = CycleTime - OldCycleTime
                
                ProcessCycleDelta = ProcessCycles - OldProcessCycles
                ProcessUsagePercent = ProcessCycleDelta / CyclesDelta / SInfo.dwNumberOfProcessors / 10
                
                If ProcessUsagePercent > 100 Then ProcessUsagePercent = 100
                
                GetProcessUsageByCycleTime = Round(ProcessUsagePercent, 2)
                
                OldProcessCycles = ProcessCycles
                OldCycleTime = CycleTime
            End If
        End If
        
        If pid <> 0 Then CloseHandle hProc
    End If
End Function

Option Explicit
 
Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, _
                                                     ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, _
                                                     lpThreadId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Public flag As Long
 
Public Sub thread(ByVal unUse As Long)
 
    Do
    Loop While GetFlag()
    
End Sub
 
Private Function GetFlag() As Long
    GetFlag = flag
End Function

Option Explicit
' *--------------------------------------------*
' | Программа RegJumpHack                      |
' | Версия 1.0                                 |
' | Copyright (c) 09.05.2023 by HackerVlad     |
' | e-mail: vladislavpeshkov@ya.ru             |
' *--------------------------------------------*
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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 WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpAddress As Long, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function SendMessageW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Const INFINITE = -1
Private Const MEM_COMMIT = &H1000&
Private Const PAGE_READWRITE = 4&
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = 16
Private Const PROCESS_VM_WRITE = &H20
Private Const MEM_RELEASE = &H8000&
Private Const TVIS_EXPANDED = &H20
 
Private Type TVITEM   ' was TV_ITEM
  mask As Long
  hItem As Long
  State As Long
  stateMask As Long
  pszText As Long   ' pointer
  cchTextMax As Long
  iImage As Long
  iSelectedImage As Long
  cChildren As Long
  lParam As Long
End Type
 
Sub CollapseVBIDETree()
    Dim hwndVBIDE As Long, hwndVBAProj As Long, hwndTV As Long
    Dim hwndCurrent As Long, hwndChildCurrent As Long
    Dim bSuccessModule As Boolean, bSuccessElse As Boolean, sNodeName As String
 
    'Find the handle of the VBEIDE window, down to the treeview in the project window
    hwndVBIDE = FindWindow("wndclass_desked_gsk", vbNullString)             'VBIDE Window
    hwndVBAProj = FindWindowEx(hwndVBIDE, 0&, "PROJECT", vbNullString)      'The Project - VBAProject Window
    hwndTV = FindWindowEx(hwndVBAProj, 0&, "SysTreeView32", vbNullString)   'The Treeview in the VBAProject Window
 
    'Get the handle of the Root of the Treeview
    hwndCurrent = TreeView_GetRoot(hwndTV)
 
    'Loop through all the children of the treeview.  This is all the current VBA Projects.
    'We can loop through until there are none left and a handle of zero is return
    Do While hwndCurrent <> 0
        sNodeName = GetTVItemText(hwndTV, hwndCurrent)
        Print sNodeName
        
        'Get the first child in the current project which is the 'Microsoft Excel Objects'
        hwndChildCurrent = TreeView_GetChild(hwndTV, hwndCurrent)
        'Set up a boolean to check if there is a 'Modules' child.  If not, we'll collapse the whole project
        bSuccessModule = False
 
        'Loop through all the child nodes to find the 'Modules' node
        Do While hwndChildCurrent <> 0
            'Get the name of the node
            sNodeName = GetTVItemText(hwndTV, hwndChildCurrent)
            
            Debug.Print sNodeName
            
            'If we find the Modules node then Expand it and flag it
            If sNodeName = "Modules" Then
                bSuccessModule = TreeView_Expand(hwndTV, hwndChildCurrent, TVE_EXPAND)
            Else
            'Otherwise collapse it
                bSuccessElse = TreeView_Expand(hwndTV, hwndChildCurrent, TVE_COLLAPSE)
            End If
            hwndChildCurrent = TreeView_GetNextSibling(hwndTV, hwndChildCurrent)
        Loop
 
        'If we don't find a Modules child then collapse the entire branch for that project
        If Not bSuccessModule Then
            Call TreeView_Expand(hwndTV, hwndCurrent, TVE_COLLAPSE)
        Else
        'Some workbooks if collapsed would stay collapsed so make sure they are expanded
            Call TreeView_Expand(hwndTV, hwndCurrent, TVE_EXPAND)
        End If
 
        'Move onto the next project
        hwndCurrent = TreeView_GetNextSibling(hwndTV, hwndCurrent)
    Loop
End Sub
 
Private Sub Command1_Click()
    Dim hRegEdit As Long
    Dim hSysTreeView32 As Long
    Dim hwndCurrent As Long
    Dim hwndChildCurrent As Long
    Dim RegEditIsRun As Boolean
    Dim pid As Long
    Dim hProcess As Long
    Dim tVI As TVITEM
    Dim tVI_new As TVITEM
    Dim pMem As Long
    Dim pMemStr As Long
    Dim lpWritten As Long
    Dim pszText As String * 256
    Dim sNodeName As String
    Dim cls(255) As Byte
    Dim hwndChildCurrent2 As Long
    Dim Paths() As String
    Dim i As Integer
    
    If InStr(1, Text1.Text, "\") = 0 Then
        Beep
        Exit Sub
    End If
    Paths = Split(Text1.Text, "\")
    
    ' Найти окно редактора реестра
    hRegEdit = FindWindow("RegEdit_RegEdit", vbNullString)
    
    If hRegEdit = 0 Then ' Если редактор реестра не запущен, то запустить его
        ' Функция ShellExecute, в отличии от CreateProcess, позволяет запускать программы которые
        ' находятся в пропатченых каталогах (из всех каталогов переменной окружения среды PATH),
        ' таким образом, нам даже не надо вычислять каталог Windows и где лежит этот regedit.exe
        ShellExecute 0, "Open", "regedit.exe", vbNullString, vbNullString, vbNormalFocus
        
        Do ' Ожидаем появления окна
            hRegEdit = FindWindow("RegEdit_RegEdit", vbNullString)
        Loop While hRegEdit = 0 ' Выполнять цикл до тех пор пока не будет найдено искомое окно
        
        GetWindowThreadProcessId hRegEdit, pid ' Вычисляем PID процесса regedit
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0, pid)  ' Открываем процесс на полный доступ
        WaitForInputIdle hProcess, INFINITE ' Ожидаем окончательной загрузки программы regedit
    Else ' RegEdit уже был запущен
        RegEditIsRun = True
        GetWindowThreadProcessId hRegEdit, pid ' Вычисляем PID процесса regedit
        hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0, pid)  ' Открываем процесс на полный доступ
    End If
    
    ' Найти дерево SysTreeView32 в окне реестра
    hSysTreeView32 = FindWindowEx(hRegEdit, ByVal 0&, "SysTreeView32", vbNullString)
    
    hwndCurrent = TreeView_GetRoot(hSysTreeView32) ' Получить дескриптор корня дерева
    
    Do While hwndCurrent <> 0 ' Получить доступ к TVM_GETITEM другого процесса
        ' Создать две страницы памяти: одну для структуры, другую для строки
        pMem = VirtualAllocEx(hProcess, ByVal 0&, 0, MEM_COMMIT, PAGE_READWRITE)
        pMemStr = VirtualAllocEx(hProcess, ByVal 0&, 0, MEM_COMMIT, PAGE_READWRITE)
        
        tVI.mask = TVIF_TEXT
        tVI.hItem = hwndCurrent
        tVI.pszText = pMemStr
        tVI.cchTextMax = MAX_ITEM
        
        WriteProcessMemory hProcess, pMem, tVI, Len(tVI), lpWritten ' Записать в память процесса структуру tVI
        SendMessageW hSysTreeView32, TVM_GETITEM, 0, pMem ' Послать запрос на определение текса ветки дерева
        ReadProcessMemory hProcess, pMemStr, ByVal pszText, MAX_ITEM, 0&
        sNodeName = GetStrFromBufferA(pszText)
        
        hwndChildCurrent = TreeView_GetChild(hSysTreeView32, hwndCurrent) ' Открыть корень дерева "Компьютер"
        
        Do While hwndChildCurrent <> 0 ' Начать перебор первичных кустов главного корневого узла "Компьютер"
            tVI.hItem = hwndChildCurrent
            WriteProcessMemory hProcess, pMem, tVI, Len(tVI), lpWritten ' Записать в память процесса структуру tVI
            WriteProcessMemory hProcess, pMemStr, ByVal VarPtr(cls(0)), MAX_ITEM, lpWritten ' Стереть старые данные
            
            SendMessageW hSysTreeView32, TVM_GETITEM, 0, pMem ' Послать запрос на определение текса ветки дерева
            ReadProcessMemory hProcess, pMemStr, ByVal pszText, MAX_ITEM, 0&
            ReadProcessMemory hProcess, pMem, tVI_new, Len(tVI_new), 0& ' Получить новое состояние
            sNodeName = GetStrFromBufferA(pszText)
            
            If StrComp(sNodeName, Paths(0), vbTextCompare) = 0 Then ' Если это первичный ключ
                TreeView_Expand hSysTreeView32, hwndChildCurrent, TVE_EXPAND ' Открыть первичный ключ
                
                If UBound(Paths) > 0 Then
                    For i = 1 To UBound(Paths)
                        hwndChildCurrent2 = TreeView_GetChild(hSysTreeView32, IIf(i = 1, hwndChildCurrent, hwndChildCurrent2))
                        
                        Do While hwndChildCurrent2 <> 0
                            tVI.hItem = hwndChildCurrent2
                            WriteProcessMemory hProcess, pMem, tVI, Len(tVI), lpWritten ' Записать в память процесса структуру tVI
                            WriteProcessMemory hProcess, pMemStr, ByVal VarPtr(cls(0)), MAX_ITEM, lpWritten ' Стереть старые данные
                            
                            SendMessageW hSysTreeView32, TVM_GETITEM, 0, pMem ' Послать запрос на определение текса ветки дерева
                            ReadProcessMemory hProcess, pMemStr, ByVal pszText, MAX_ITEM, 0&
                            sNodeName = GetStrFromBufferA(pszText)
                            
                            If StrComp(sNodeName, Paths(i), vbTextCompare) = 0 Then ' Если это глубинный ключ
                                TreeView_Expand hSysTreeView32, hwndChildCurrent2, TVE_EXPAND ' Открыть глубинный ключ
                                If i = UBound(Paths) Then
                                    ' В самом конце выделить нужный элемент дерева
                                    WaitForInputIdle hProcess, INFINITE
                                    SendMessageW hSysTreeView32, TVM_SELECTITEM, TVGN_CARET, hwndChildCurrent2
                                    SendMessageW hSysTreeView32, TVM_SELECTITEM, TVGN_FIRSTVISIBLE, hwndChildCurrent2
                                End If
                                
                                Exit Do ' Для ускорения процедуры, мы не будем перебирать дальше список уже неинтересуемых нами параметров
                            End If
                            
                            hwndChildCurrent2 = TreeView_GetNextSibling(hSysTreeView32, hwndChildCurrent2)
                        Loop
                    Next
                End If
            Else
                If (tVI_new.State And TVIS_EXPANDED) <> 0 Then ' Если главный куст дерева открыт
                    TreeView_Expand hSysTreeView32, hwndChildCurrent, TVE_COLLAPSE ' Послать запрос на закрытие главноего куста
                End If
            End If
            
            hwndChildCurrent = TreeView_GetNextSibling(hSysTreeView32, hwndChildCurrent)
        Loop
        
        hwndCurrent = TreeView_GetNextSibling(hSysTreeView32, hwndCurrent)
    Loop
    
    ' Освободить память
    VirtualFreeEx hProcess, pMem, ByVal 0&, MEM_RELEASE
    VirtualFreeEx hProcess, pMemStr, ByVal 0&, MEM_RELEASE
    CloseHandle hProcess
End Sub
 
Private Sub Command2_Click()
    ' А эта процедурка сворачивает дерево в VB IDE с проектами и формами и модулями
    CollapseVBIDETree
End Sub
 
Private Sub Form_Load()
    Top = 600
    Left = Screen.Width / 2 - Me.Width / 2
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Command1_Click
    End If
End Sub

Option Explicit
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                            ByVal lpClassName As String, _
                            ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
                            ByVal hWndParent As Long, _
                            ByVal hWndChildAfter As Long, _
                            ByVal lpszClassName As String, _
                            ByVal lpszWindowName As String) As Long
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                            (ByVal hwnd As Long, _
                            ByVal wMsg As Long, _
                            wParam As Any, _
                            lParam As Any) As Long
 
' ===========================================================================
' treeview definitions defined in Commctrl.h at:
' http://premium.microsoft.com/msdn/library/sdkdoc/c67_4c8m.htm
 
Private Type TVITEM   ' was TV_ITEM
  mask As Long
  hItem As Long
  State As Long
  stateMask As Long
  pszText As String   ' Long   ' pointer
  cchTextMax As Long
  iImage As Long
  iSelectedImage As Long
  cChildren As Long
  lParam As Long
End Type
'
Public Enum TVITEM_mask
    TVIF_TEXT = &H1
    TVIF_IMAGE = &H2
    TVIF_PARAM = &H4
    TVIF_STATE = &H8
    TVIF_HANDLE = &H10
    TVIF_SELECTEDIMAGE = &H20
    TVIF_CHILDREN = &H40
#If (Win32_IE >= &H400) Then   ' WIN32_IE = 1024 (>= Comctl32.dll v4.71)
    TVIF_INTEGRAL = &H80
#End If
    TVIF_DI_SETITEM = &H1000   ' Notification
End Enum
 
' User-defined as the maximum treeview item text length.
' If an items text exceeds this value when calling GetTVItemText
' there could be problems...
Public Const MAX_ITEM = 256
 
' TVM_GETNEXTITEM wParam values
Public Enum TVGN_Flags
    TVGN_ROOT = &H0
    TVGN_NEXT = &H1
    TVGN_PREVIOUS = &H2
    TVGN_PARENT = &H3
    TVGN_CHILD = &H4
    TVGN_FIRSTVISIBLE = &H5
    TVGN_NEXTVISIBLE = &H6
    TVGN_PREVIOUSVISIBLE = &H7
    TVGN_DROPHILITE = &H8
    TVGN_CARET = &H9
#If (Win32_IE >= &H400) Then   ' >= Comctl32.dll v4.71
    TVGN_LASTVISIBLE = &HA
#End If
End Enum
 
Public Enum TVMessages
    TV_FIRST = &H1100
 
    #If UNICODE Then
      TVM_INSERTITEM = (TV_FIRST + 50)
    #Else
      TVM_INSERTITEM = (TV_FIRST + 0)
    #End If
 
    TVM_DELETEITEM = (TV_FIRST + 1)
    TVM_EXPAND = (TV_FIRST + 2)
    TVM_GETITEMRECT = (TV_FIRST + 4)
    TVM_GETCOUNT = (TV_FIRST + 5)
    TVM_GETINDENT = (TV_FIRST + 6)
    TVM_SETINDENT = (TV_FIRST + 7)
    TVM_GETIMAGELIST = (TV_FIRST + 8)
    TVM_SETIMAGELIST = (TV_FIRST + 9)
    TVM_GETNEXTITEM = (TV_FIRST + 10)
    TVM_SELECTITEM = (TV_FIRST + 11)
 
    #If UNICODE Then
      TVM_GETITEM = (TV_FIRST + 62)
      TVM_SETITEM = (TV_FIRST + 63)
      TVM_EDITLABEL = (TV_FIRST + 65)
    #Else
      TVM_GETITEM = (TV_FIRST + 12)
      TVM_SETITEM = (TV_FIRST + 13)
      TVM_EDITLABEL = (TV_FIRST + 14)
    #End If
 
    TVM_GETEDITCONTROL = (TV_FIRST + 15)
    TVM_GETVISIBLECOUNT = (TV_FIRST + 16)
    TVM_HITTEST = (TV_FIRST + 17)
    TVM_CREATEDRAGIMAGE = (TV_FIRST + 18)
    TVM_SORTCHILDREN = (TV_FIRST + 19)
    TVM_ENSUREVISIBLE = (TV_FIRST + 20)
    TVM_SORTCHILDRENCB = (TV_FIRST + 21)
    TVM_ENDEDITLABELNOW = (TV_FIRST + 22)
 
    #If UNICODE Then
      TVM_GETISEARCHSTRING = (TV_FIRST + 64)
    #Else
      TVM_GETISEARCHSTRING = (TV_FIRST + 23)
    #End If
 
#If (Win32_IE >= &H300) Then
    TVM_SETTOOLTIPS = (TV_FIRST + 24)
    TVM_GETTOOLTIPS = (TV_FIRST + 25)
#End If    ' 0x0300
 
#If (Win32_IE >= &H400) Then
    TVM_SETINSERTMARK = (TV_FIRST + 26)
    TVM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT
    TVM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT
    TVM_SETITEMHEIGHT = (TV_FIRST + 27)
    TVM_GETITEMHEIGHT = (TV_FIRST + 28)
    TVM_SETBKCOLOR = (TV_FIRST + 29)
    TVM_SETTEXTCOLOR = (TV_FIRST + 30)
    TVM_GETBKCOLOR = (TV_FIRST + 31)
    TVM_GETTEXTCOLOR = (TV_FIRST + 32)
    TVM_SETSCROLLTIME = (TV_FIRST + 33)
    TVM_GETSCROLLTIME = (TV_FIRST + 34)
    TVM_SETINSERTMARKCOLOR = (TV_FIRST + 37)
    TVM_GETINSERTMARKCOLOR = (TV_FIRST + 38)
#End If   ' 0x0400
 
End Enum   ' TVMessages
 
Public Enum TVM_EXPAND_wParam
    TVE_COLLAPSE = &H1
    TVE_EXPAND = &H2
    TVE_TOGGLE = &H3
#If (Win32_IE >= &H300) Then
    TVE_EXPANDPARTIAL = &H4000
#End If
    TVE_COLLAPSERESET = &H8000
End Enum
 
' Returns the text of the specified treeview item if successful,
' returns an empty string otherwise.
'   hwndTV      - treeview's window handle
'   hItem          - item's handle whose text is to be to returned
'   cbItem        - length of the specified item's text.
Public Function GetTVItemText(hwndTV As Long, hItem As Long, Optional cbItem As Long = MAX_ITEM) As String
  Dim tVI As TVITEM
 
  ' Initialize the struct to retrieve the item's text.
  tVI.mask = TVIF_TEXT
  tVI.hItem = hItem
  tVI.pszText = String$(cbItem, 0)
  tVI.cchTextMax = cbItem
 
  If TreeView_GetItem(hwndTV, tVI) Then
    GetTVItemText = GetStrFromBufferA(tVI.pszText)
  End If
 
End Function
 
' Returns the string before first null char encountered (if any) from an ANSII string.
Public Function GetStrFromBufferA(sz As String) As String
  If InStr(sz, vbNullChar) Then
    GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
  Else
    ' If sz had no null char, the Left$ function
    ' above would return a zero length string ("").
    GetStrFromBufferA = sz
  End If
End Function
 
' Expands or collapses the list of child items, if any, associated with the specified parent item.
' Returns TRUE if successful or FALSE otherwise.
' (docs say TVM_EXPAND does not send the TVN_ITEMEXPANDING and
' TVN_ITEMEXPANDED notification messages to the parent window...?)
Public Function TreeView_Expand(hwnd As Long, hItem As Long, flag As TVM_EXPAND_wParam) As Boolean
  TreeView_Expand = SendMessage(hwnd, TVM_EXPAND, ByVal flag, ByVal hItem)
End Function
 
' Retrieves some or all of a tree-view item's attributes.
' Returns TRUE if successful or FALSE otherwise.
Public Function TreeView_GetItem(hwnd As Long, pitem As TVITEM) As Boolean
  TreeView_GetItem = SendMessage(hwnd, TVM_GETITEM, 0, pitem)
End Function
 
' Retrieves the tree-view item that bears the specified relationship to a specified item.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetNextItem(hwnd As Long, hItem As Long, flag As Long) As Long
  TreeView_GetNextItem = SendMessage(hwnd, TVM_GETNEXTITEM, ByVal flag, ByVal hItem)
End Function
 
' Retrieves the first child item. The hitem parameter must be NULL.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetChild(hwnd As Long, hItem As Long) As Long
  TreeView_GetChild = TreeView_GetNextItem(hwnd, hItem, TVGN_CHILD)
End Function
 
' Retrieves the next sibling item.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetNextSibling(hwnd As Long, hItem As Long) As Long
  TreeView_GetNextSibling = TreeView_GetNextItem(hwnd, hItem, TVGN_NEXT)
End Function
 
' Retrieves the previous sibling item.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetPrevSibling(hwnd As Long, hItem As Long) As Long
  TreeView_GetPrevSibling = TreeView_GetNextItem(hwnd, hItem, TVGN_PREVIOUS)
End Function
 
' Retrieves the parent of the specified item.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetParent(hwnd As Long, hItem As Long) As Long
  TreeView_GetParent = TreeView_GetNextItem(hwnd, hItem, TVGN_PARENT)
End Function
 
' Retrieves the first visible item.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetFirstVisible(hwnd As Long) As Long
  TreeView_GetFirstVisible = TreeView_GetNextItem(hwnd, 0, TVGN_FIRSTVISIBLE)
End Function
 
' Retrieves the topmost or very first item of the tree-view control.
' Returns the handle to the item if successful or 0 otherwise.
Public Function TreeView_GetRoot(hwnd As Long) As Long
  TreeView_GetRoot = TreeView_GetNextItem(hwnd, 0, TVGN_ROOT)
End Function

Private Sub Form_Load()
    Dim col As New clsCollectionEx
    'Добавляем значения (параметры Before, After не поддерживаются: используйте col.AddBefore и col.AddAfter)
    col.Add 11, "a"
    col.Add 22, "key"
    col.Add 33, "badkey"
    col.Add 44
    col.Add 55
    col.Add 77
    ' в AddBefore, AddAfter можно указывать не-существующие индексы, это не будет ошибкой
    col.AddBefore 66, , 6
    col.AddAfter 88, "LastKey", 9999
    
    'Удаление первого элемента по значению
    col.RemoveByItem 66
    
    'Удаление всех элементов, соответствующих значению
    col.RemoveByItemAll 66
    
    'Удаление элемента по ключу
    col.Remove "badkey"
    
    'Удаление элемента по индексу
    col.Remove 1
    
    ' кол-во элементов
    Debug.Print "Count: " & col.Count
    
    ' Замена значения (используя индекс)
    col(2) = 100
    
    ' Замена значения (используя ключ)
    col("key") = 99
    ' тоже самое, но через обычное свойство, а не доступ по умолчанию
    col.Item("key") = 99
    
    ' запрос значения через доступ по умолчанию (по индексу)
    Debug.Print "First item value: " & col(1)
    ' тоже самое
    Debug.Print "First item value: " & col.Item(1)
    
    ' получение ключа по значению
    Debug.Print "Key of item value 88: " & col.GetKeyByItem(88)
    
    ' получение значения по ключу
    Debug.Print "Item value of key 'LastKey': " & col.GetItemByKey("LastKey")
    ' тоже самое
    Debug.Print "Item value of key 'LastKey': " & col("LastKey")
    
    ' проверка, существует ли ключ
    Debug.Print "Key 'key' exists: " & col.KeyExists("key")
    
    ' проверка, существует ли значение
    Debug.Print "Value '88' exists: " & col.ItemExists(88)
    
    ' Перечисление всех Item
    Debug.Print "Enum..."
    Dim v
    For Each v In col
        Debug.Print "Item: " & v
    Next
    
    ' Не знаю зачем, но - работа с объектом Collection напрямую:
    Debug.Print "Inner count: " & col.InnerObject.Count
    ' переназначение объекта
    Dim otherCol As New Collection
    Set col.InnerObject = otherCol
    
End Sub

Option Explicit
' *------------------------------------------------------*
' | Программа RegEditJumpHacking                         |
' | Версия 2.0                                           |
' | Автор идеи: testuser2                                |
' | Copyright (c) 07.07.2023 by HackerVlad and The Trick |
' | e-mail: vladislavpeshkov@ya.ru                       |
' *------------------------------------------------------*
 
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId 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 WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutW" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function CreateCaret Lib "user32" (ByVal hWnd As Long, ByVal hBitmap As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function ShowCaret Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Long) As Long
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal IsEnable As Boolean) As Boolean
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProc As Long, bWow64Process As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function DestroyCaret Lib "user32" () As Long
 
' Для прозрачности
Private Declare Function MapWindowPoints Lib "user32" (ByVal hWndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
 
Private Const INFINITE = -1
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_OPERATION = &H8
Private Const WS_CHILD          As Long = &H40000000
Private Const WS_VISIBLE        As Long = &H10000000
Private Const WS_EX_CLIENTEDGE  As Long = &H200&
Private Const ES_AUTOHSCROLL As Long = &H80&
Private Const ES_MULTILINE As Long = &H4&
Private Const SMTO_ABORTIFHUNG = &H2
Private Const WM_SETTEXT = &HC
Private Const WM_GETTEXT = &HD
Private Const WM_CHAR = &H102
Private Const WM_KILLFOCUS = &H8
Private Const WM_SETFOCUS = &H7
Private Const EM_SETSEL = &HB1
 
' Для прозрачности
Private Const WM_CTLCOLORBTN As Long = &H135
Private Const WM_CTLCOLORSTATIC As Long = &H138
Dim hBackBrush  As Long ' Фоновая кисть
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Dim MyProcRunIs64 As Long
Dim hwndText1 As Long
 
Private WithEvents m_cFormHook As CTrickSubclass
Private WithEvents m_cTextHook As CTrickSubclass
Private WithEvents m_cTextBoxInRegEditHook As CTrickSubclass
 
Public Sub ChangeWindowsRegEdit(Optional CreateTextBox As Boolean, Optional SetDefault As Boolean)
    Dim rctSysTreeView32 As RECT
    Dim rctSysListView32 As RECT
    Dim rctRegEdit As RECT
    Dim ScreenXYCoordinates As POINTAPI
    Dim WidthCaption As Long
    Dim HeightCaption As Long
    Dim newWidth1 As Long
    Dim newHeight1 As Long
    Dim newWidth2 As Long
    Dim newHeight2 As Long
    Dim LeftSysListView32 As Long
    Dim WidthTextBox As Long
    
    GetWindowRect hSysTreeView32, rctSysTreeView32
    GetWindowRect hSysListView32, rctSysListView32
    
    GetWindowRect hRegEdit, rctRegEdit
    ClientToScreen hRegEdit, ScreenXYCoordinates
    
    WidthCaption = ScreenXYCoordinates.x - rctRegEdit.Left ' Высота заголовка окна regedit'а + меню (если есть)
    HeightCaption = ScreenXYCoordinates.y - rctRegEdit.Top ' Ширина границы рамки окна regedit'а
    
    newWidth1 = rctSysTreeView32.Right - rctRegEdit.Left - WidthCaption
    newHeight1 = rctSysTreeView32.Bottom - rctRegEdit.Top - HeightCaption
    
    LeftSysListView32 = rctSysListView32.Left - rctRegEdit.Left - WidthCaption
    
    newWidth2 = rctSysListView32.Right - rctRegEdit.Left - WidthCaption - LeftSysListView32
    newHeight2 = rctSysListView32.Bottom - rctRegEdit.Top - HeightCaption
    
    If SetDefault = False Then
        MoveWindow hSysTreeView32, 0, 25, newWidth1, newHeight1 - 25, True
        MoveWindow hSysListView32, LeftSysListView32, 25, newWidth2, newHeight2 - 25, True
        
        WidthTextBox = rctRegEdit.Right - rctRegEdit.Left - (WidthCaption * 2)
        
        If CreateTextBox = True Then
            If IsWindow(hwndTextBox) = 0 Then
                hwndTextBox = CreateWindowEx(WS_EX_CLIENTEDGE, StrPtr("Edit"), ByVal 0&, WS_CHILD Or WS_VISIBLE Or ES_MULTILINE Or _
                ES_AUTOHSCROLL, 0, 0, WidthTextBox, 25, hRegEdit, 0&, 0&, ByVal 0&)
                SetDefaultFontWindow hwndTextBox
            End If
        Else
            MoveWindow hwndTextBox, 0, 0, WidthTextBox, 25, True
        End If
        
        UpdateWindow hRegEdit
    Else
        MoveWindow hSysTreeView32, 0, 0, newWidth1, newHeight1, True
        MoveWindow hSysListView32, LeftSysListView32, 0, newWidth2, newHeight2, True
    End If
End Sub
 
Private Sub SetDefaultWindowsRegEdit()
    ChangeWindowsRegEdit False, True
End Sub
 
Private Sub Check1_Click()
    If Check1.Value = 1 Then
        ChangeWindowsRegEdit True
        
        If hEvent > 0 Then Unhook
        Hook
    Else
        DestroyWindow hwndTextBox
        Unhook
        
        SetDefaultWindowsRegEdit
    End If
End Sub
 
Private Sub Command1_Click()
    Dim TextBoxText As String
    
    If hRegEdit > 0 Then
        TextBoxText = String$(2048, vbNullChar)
        SendMessageTimeout hwndText1, WM_GETTEXT, 2048, StrPtr(TextBoxText), SMTO_ABORTIFHUNG, 5000, 0
        TextBoxText = Replace(TextBoxText, vbNullChar, vbNullString)
        
        If IsProcess64bit(hRegEdit) = True Then
            RegJump64 TextBoxText
        Else
            RegJump32 TextBoxText
        End If
    End If
End Sub
 
Private Sub Command2_Click()
    Dim pid As Long
    Dim hProcess As Long
    
    If IsSubclassed = True Then
        Command1_Click
        Exit Sub
    End If
    
    ' Найти окно редактора реестра
    hRegEdit = FindWindow("RegEdit_RegEdit", vbNullString)
    
    If hRegEdit = 0 Then
        If MyProcRunIs64 = 1 Then
            If Option1.Value = True Then
                Wow64EnableWow64FsRedirection False ' Выключить перенаправление с System32 на SYSWOW64
                Shell Environ("windir") & "\regedit.exe", vbNormalFocus
                Wow64EnableWow64FsRedirection True ' Включить перенаправление обратно (установить по умолчанию)
            Else
                Shell Environ("windir") & "\regedit.exe", vbNormalFocus
            End If
        Else
            Shell Environ("windir") & "\regedit.exe", vbNormalFocus
        End If
        
        Do ' Ожидаем появления окна
            hRegEdit = FindWindow("RegEdit_RegEdit", vbNullString)
        Loop While hRegEdit = 0 ' Выполнять цикл до тех пор пока не будет найдено искомое окно
    End If
    
    If hRegEdit > 0 Then
        ' Найти дерево SysTreeView32 в окне редактора реестра
        hSysTreeView32 = FindWindowEx(hRegEdit, ByVal 0&, "SysTreeView32", vbNullString)
        
        ' Найти листвиев hSysListView32 в окне редактора реестра
        hSysListView32 = FindWindowEx(hRegEdit, ByVal 0&, "SysListView32", vbNullString)
        
        If Check1.Value = 1 Then
            ChangeWindowsRegEdit True
            
            ' Подождать окончательной загрузки программы regedit и установить фокус на новое текстовое поле (адресную строку)
            GetWindowThreadProcessId hRegEdit, pid ' Вычисляем PID процесса regedit
            hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_OPERATION, 0, pid) ' Открываем процесс
            WaitForInputIdle hProcess, INFINITE ' Ожидаем окончательной загрузки программы regedit
            CloseHandle hProcess
            MyWait 10 ' В отличии от Sleep не сбивает фокус и не замораживает поток
            SetFocusAPI hwndTextBox
            
            If IsSubclassed = False Then
                ' Отсубклассировать текстовое поле внутри редактора реестра
                Set m_cTextBoxInRegEditHook = New CTrickSubclass
                m_cTextBoxInRegEditHook.Hook hwndTextBox
                IsSubclassed = True
            End If
            
            If hEvent > 0 Then Unhook
            Hook
        End If
    End If
End Sub
 
Private Sub Form_Initialize()
    InitCommonControlsXP
End Sub
 
Private Sub Form_Load()
    Dim TextInTextBox As String
    
    IsWow64Process -1, MyProcRunIs64
    
    If MyProcRunIs64 = 0 Then
        Option1.Visible = False
        Option2.Visible = False
    End If
    
    SetDefaultFontWindow Command1.hWnd
    SetDefaultFontWindow Command2.hWnd
    
    Top = 300
    Left = Screen.Width / 2 - Me.Width / 2
    
    hwndText1 = CreateWindowEx(WS_EX_CLIENTEDGE, StrPtr("Edit"), ByVal 0&, WS_CHILD Or WS_VISIBLE Or ES_MULTILINE Or _
    ES_AUTOHSCROLL, 408, 32, 449, 33, Me.hWnd, 0&, 0&, ByVal 0&)
    SetDefaultFontWindow hwndText1
    TextInTextBox = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
    SendMessage hwndText1, WM_SETTEXT, 0, StrPtr(TextInTextBox)
    
    Set m_cFormHook = New CTrickSubclass
    Set m_cTextHook = New CTrickSubclass
    m_cFormHook.Hook Me.hWnd
    m_cTextHook.Hook hwndText1
    
    ' Для прозрачности
    hBackBrush = CreatePatternBrush(Me.Picture.handle)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    DestroyWindow hwndTextBox
    Unhook
    SetDefaultWindowsRegEdit
    modX64Call.Uninitialize
End Sub
 
' Отсубклассировать форму
Private Sub m_cFormHook_WndProc(ByVal hWnd As stdole.OLE_HANDLE, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long, lRet As Long, bDefCall As Boolean)
    Select Case lMsg
        ' Для прозрачности
        Case WM_CTLCOLORSTATIC, WM_CTLCOLORBTN
            Dim pts(1) As Long
            
            ' Получаем координаты элемента
            MapWindowPoints lParam, Me.hWnd, pts(0), 1
            
            ' Сдвигаем точку отсчета координат кисти, чтобы она совпадала с фоновом изображением под контролом
            SetBrushOrgEx wParam, -pts(0), -pts(1), ByVal 0&
            
            ' Возвращаем кисть
            lRet = hBackBrush
            
            bDefCall = False
    End Select
End Sub
 
' Отсубклассировать текстовое поле внутри редактора реестра
Private Sub m_cTextBoxInRegEditHook_WndProc(ByVal hWnd As stdole.OLE_HANDLE, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long, lRet As Long, bDefCall As Boolean)
    Select Case lMsg
        Case WM_CHAR
            CreateCaret hWnd, 0, 0, 15
            ShowCaret hWnd
            
            If wParam = 13 Then ' Если нажата клавиша Enter
                Dim TextBoxText As String
                
                DestroyCaret
                
                lRet = 0
                bDefCall = False
                
                TextBoxText = String$(2048, vbNullChar)
                
                SendMessageTimeout hwndTextBox, WM_GETTEXT, 2048, StrPtr(TextBoxText), SMTO_ABORTIFHUNG, 5000, 0
                TextBoxText = Replace(TextBoxText, vbNullChar, vbNullString)
                
                If IsProcess64bit(hRegEdit) = True Then
                    RegJump64 TextBoxText
                Else
                    RegJump32 TextBoxText
                End If
                
                SetFocusAPI hSysTreeView32
            End If
            
            If wParam = 1 And lParam = 1966081 Then ' Если нажаты клавишы Ctrl+A
                lRet = 0
                bDefCall = False
                SendMessage hWnd, EM_SETSEL, 0, -1 ' Выделить всё
            End If
            
        Case WM_SETFOCUS
            CreateCaret hWnd, 0, 0, 15
            ShowCaret hWnd
            
        Case WM_KILLFOCUS
            DestroyCaret
    End Select
End Sub
 
' Отсубклассировать текстовое поле
Private Sub m_cTextHook_WndProc(ByVal hWnd As stdole.OLE_HANDLE, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long, lRet As Long, bDefCall As Boolean)
    Select Case lMsg
        Case WM_CHAR
            If wParam = 13 Then ' Если нажата клавиша Enter
                lRet = 0
                bDefCall = False
                Command1_Click
            End If
            
            If wParam = 1 And lParam = 1966081 Then ' Если нажаты клавишы Ctrl+A
                lRet = 0
                bDefCall = False
                SendMessage hWnd, EM_SETSEL, 0, -1 ' Выделить всё
            End If
    End Select
End Sub

Option Explicit
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As OLE_HANDLE, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As OLE_HANDLE, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As OLE_HANDLE, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As OLE_HANDLE, ByVal lpBaseAddress As Long, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId 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 VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Const INFINITE = -1
Private Const MEM_COMMIT = &H1000&
Private Const PAGE_READWRITE = 4&
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = 16
Private Const PROCESS_VM_WRITE = &H20
Private Const MEM_RELEASE = &H8000&
Private Const TVIS_EXPANDED = &H20
 
Private Const TVIF_TEXT = &H1
Private Const TV_FIRST = &H1100
Private Const TVM_EXPAND = (TV_FIRST + 2)
Private Const TVM_GETNEXTITEM = (TV_FIRST + 10)
Private Const TVM_GETITEM = (TV_FIRST + 62) ' UNICODE
Private Const TVM_SELECTITEM = (TV_FIRST + 11)
Private Const TVGN_ROOT = &H0
Private Const TVGN_NEXT = &H1
Private Const TVGN_CARET = &H9
Private Const TVGN_FIRSTVISIBLE = &H5
Private Const TVGN_CHILD = &H4
 
Private Const TVE_COLLAPSE = &H1
Private Const TVE_EXPAND = &H2
 
Private Const MEM_RESERVE             As Long = &H2000&
Private Const MAX_PATH                As Long = 260
 
Private Type TVITEM64
    mask            As Long
    lPad            As Long
    hItem           As Currency
    State           As Long
    stateMask       As Long
    pszText         As Currency
    cchTextMax      As Long
    iImage          As Long
    iSelectedImage  As Long
    cChildren       As Long
    lParam          As Currency
End Type
 
Public Sub RegJump64(RegEditAddress As String)
    Dim h64Current As Currency
    Dim h64Child As Currency
    Dim h64Item As Currency
    Dim pid As Long
    Dim hProcess As Long
    Dim tItem As TVITEM64
    Dim tItem_new_state As TVITEM64
    Dim pMemory As Long
    Dim sBuf As String
    Dim sNodeName As String
    Dim Paths() As String
    Dim PathStr As String
    Dim lSize As Long
    Dim i As Long
    
    PathStr = Trim$(RegEditAddress)
    If Right$(PathStr, 1) = "\" Then PathStr = Mid$(PathStr, 1, Len(PathStr) - 1)
    
    If InStr(1, PathStr, "_") = 0 Then Exit Sub
    
    Paths = Split(PathStr, "\")
    
    If Not modX64Call.Initialize Then
        MsgBox "Unable to initialize modX64Call", vbCritical
        Exit Sub
    End If
    
    GetWindowThreadProcessId hRegEdit, pid ' Вычисляем PID процесса regedit
    hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, 0, pid) ' Открываем процесс на полный доступ
    
    ' По технологии The Trick создать только одну страницу памяти, которая будет как для структуры, так и для строки
    pMemory = VirtualAllocEx(hProcess, 0, 4096, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
    h64Current = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, 0, TVGN_ROOT / 10000) ' Получить дескриптор корня дерева
    
    sBuf = Space$(MAX_PATH)
    
    tItem.pszText = (pMemory + 1024) / 10000
    tItem.mask = TVIF_TEXT
    tItem.cchTextMax = Len(sBuf)
    
    Do While h64Current <> 0@ ' Получить доступ к TVM_GETITEM другого процесса
        tItem.hItem = h64Current
        
        WriteProcessMemory hProcess, pMemory, tItem, LenB(tItem), 0& ' Записать в память процесса структуру tItem
        SendMessage hSysTreeView32, TVM_GETITEM, 0, ByVal pMemory ' Послать запрос на определение текса ветки дерева
        ReadProcessMemory hProcess, pMemory + 1024, ByVal StrPtr(sBuf), LenB(sBuf), 0&
        
        lSize = InStr(1, sBuf, vbNullChar)
        sNodeName = Left$(sBuf, lSize - 1)
        
        h64Child = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, TVGN_CHILD / 10000, h64Current) ' Открыть корень дерева "Компьютер"
        
        Do While h64Child <> 0@ ' Начать перебор первичных кустов главного корневого узла "Компьютер"
            tItem.hItem = h64Child
            
            WriteProcessMemory hProcess, pMemory, tItem, LenB(tItem), 0& ' Записать в память процесса структуру tItem
            SendMessage hSysTreeView32, TVM_GETITEM, 0, ByVal pMemory ' Послать запрос на определение текса ветки дерева
            ReadProcessMemory hProcess, pMemory + 1024, ByVal StrPtr(sBuf), LenB(sBuf), 0&
            ReadProcessMemory hProcess, pMemory, tItem_new_state, Len(tItem_new_state), 0& ' Получить новое состояние
            
            lSize = InStr(1, sBuf, vbNullChar)
            sNodeName = Left$(sBuf, lSize - 1)
            
            If StrComp(sNodeName, Paths(0), vbTextCompare) = 0 Then ' Если это первичный ключ
                SendMessageW64 hSysTreeView32, TVM_EXPAND, TVE_EXPAND / 10000, h64Child ' Открыть первичный ключ
                
                If UBound(Paths) > 0 Then
                    For i = 1 To UBound(Paths)
                        h64Item = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, TVGN_CHILD / 10000, IIf(i = 1, h64Child, h64Item))
                        
                        Do While h64Item <> 0@
                            tItem.hItem = h64Item
                            WriteProcessMemory hProcess, pMemory, tItem, LenB(tItem), 0& ' Записать в память процесса структуру tItem
                            SendMessage hSysTreeView32, TVM_GETITEM, 0, ByVal pMemory ' Послать запрос на определение текса ветки дерева
                            ReadProcessMemory hProcess, pMemory + 1024, ByVal StrPtr(sBuf), LenB(sBuf), 0&
                            
                            lSize = InStr(1, sBuf, vbNullChar)
                            sNodeName = Left$(sBuf, lSize - 1)
                            
                            If StrComp(sNodeName, Paths(i), vbTextCompare) = 0 Then ' Если это глубинный ключ
                                SendMessageW64 hSysTreeView32, TVM_EXPAND, TVE_EXPAND / 10000, h64Item ' Открыть глубинный ключ
                                
                                If i = UBound(Paths) Then
                                    ' В самом конце выделить нужный элемент дерева
                                    WaitForInputIdle hProcess, INFINITE
                                    SendMessageW64 hSysTreeView32, TVM_SELECTITEM, TVGN_CARET / 10000, h64Item
                                    SendMessageW64 hSysTreeView32, TVM_SELECTITEM, TVGN_FIRSTVISIBLE / 10000, h64Item
                                End If
                                
                                Exit Do ' Для ускорения процедуры, мы не будем перебирать дальше список уже неинтересуемых нами параметров
                            End If
                            
                            h64Item = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, TVGN_NEXT / 10000, h64Item)
                        Loop
                    Next
                End If
            Else
                If (tItem_new_state.State And TVIS_EXPANDED) <> 0 Then ' Если главный куст дерева открыт
                    SendMessageW64 hSysTreeView32, TVM_EXPAND, TVE_COLLAPSE / 10000, h64Child ' Послать запрос на закрытие главноего куста
                End If
            End If
            
            h64Child = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, TVGN_NEXT / 10000, h64Child)
        Loop
        
        h64Current = SendMessageW64(hSysTreeView32, TVM_GETNEXTITEM, TVGN_NEXT / 10000, h64Current)
    Loop
    
    ' Освободить память
    VirtualFreeEx hProcess, pMemory, 0, MEM_RELEASE
    CloseHandle hProcess
End Sub