Option Explicit
'********************************************************************
'*              Написано в 2003 году (Team HomeWork)                *
'*                      e-mail: sne_pro@mail.ru                     *
'********************************************************************
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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 Any) As Long
Private Declare Sub InitCommonControls Lib "comctl32" ()

Private Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fItalic As Long, ByVal fUnderline As Long, ByVal fStrikeOut As Long, ByVal fCharSet As Long, ByVal fOutPrecision As Long, ByVal fClipPrecision As Long, ByVal fQuality As Long, ByVal fPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Private Const WS_CHILD              As Long = &H40000000
Private Const WS_VISIBLE            As Long = &H10000000
Private Const WM_SETFONT            As Long = &H30
Private Const HKM_GETHOTKEY         As Long = &H402
Private Const HKM_SETHOTKEY         As Long = &H401

Private lOldWndProc As Long

Public Function CreateHotKeyC(hOwner As Long, ByVal xPos As Long, ByVal yPos As Long, ByVal lWidth As Long, ByVal lHeight As Long, Optional ByVal fntSize As Integer, Optional ByVal fntName As String) As Long
    Dim hFnt As Long
    Call InitCommonControls
    CreateHotKeyC = CreateWindowEx(0&, "msctls_hotkey32", vbNullString, WS_CHILD Or WS_VISIBLE, xPos, yPos, lWidth, lHeight, hOwner, 0&, App.hInstance, 0&
    
    hFnt = CreateFont(IIf(fntSize, fntSize, 12) / 72 * GetDeviceCaps(GetDC(hOwner), 90&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, 0&, IIf(Len(fntName), fntName, "Arial")
    Call SendMessageByNum(CreateHotKeyC, WM_SETFONT, hFnt, 0&
End Function

Public Function GetHotKey(lhWndHK As Long, Optional ByVal outVK As Boolean) As Integer
    Dim lOutData As Long

    lOutData = SendMessageByNum(lhWndHK, HKM_GETHOTKEY, &H0, &H0)
    GetHotKey = IIf(outVK, LoByte(ByVal lOutData), HiByte(ByVal lOutData))
End Function

Public Sub SetHotKey(lhWndHK As Long, ByVal VK As Byte, ByVal Shift As Byte)
    Call SendMessageByNum(lhWndHK, HKM_SETHOTKEY, MakeWord(VK, Shift), 0&
End Sub

Public Function ReModif(ByVal inModif As Long) As Integer
    On Error Resume Next
    If inModif Then ReModif = Choose(inModif, &H4, &H2, &H6, &H1, &H5, &H3, &H7, &H8, &HC, &HA, &HE, &H9, &HD, &HB, &HF)
End Function

Private Function LoByte(ByVal InValue As Integer) As Byte
    LoByte = (InValue And &HFF&
End Function

Private Function HiByte(ByVal InValue As Integer) As Byte
    HiByte = (InValue And &HFF00& \ &H100&
End Function

Private Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
    MakeWord = (HiByte * &H100) Or (LoByte And &HFF&
End Function

Private Sub Form_Load()
    l = CreateHotKeyC(Me.hWnd, 5, 5, 150, 20, 10, "MS Sans Serif"
End Sub

'********************************************************************
'*              Написано в 2003 году (Team HomeWork)                *
'*                      e-mail: sne_pro@mail.ru                     *
'********************************************************************
Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal ID As Long, ByVal fsModifiers As Long, ByVal VK As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal ID As Long) As Long

Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = -4

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Enum gbHotKeyModifiers
    MOD_ALT = &H1
    MOD_CONTROL = &H2
    MOD_SHIFT = &H4
    MOD_WIN = &H8
End Enum

Private Const WM_HOTKEY = &H312
Private Const WM_CHAR As Long = &H102
Private Const WM_GETHOTKEY As Long = &H33

Private OldWndProc As Long

Private Function HotKeyWindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case Is = WM_GETHOTKEY
            wParam = 0&: lParam = 0&
        Case Is = WM_HOTKEY
            'LoWord(wParam) - ID
            'HiWord(lParam) - VK
            'LoWord(lParam) - SHIFT
            Call frmMain.List1.AddItem("ID = " & LoWord(wParam) & " VK = " & HiWord(lParam) & " SIFT = " & LoWord(lParam) _
            & "  ||  " & Choose(LoWord(lParam), "Alt", "Ctrl", "Alt + Ctrl", "Shift", "Alt + Shift", "Ctrl + Shift", "Alt + Ctrl + Shift" & " + " & Chr(HiWord(lParam)))
    End Select
    HotKeyWindowProc = CallWindowProc(OldWndProc, hWnd, uMsg, wParam, lParam)
End Function
'Регистрация горячей клавиши
Public Function RegHotKey(hWnd As Long, ByVal Modifiers As gbHotKeyModifiers, ByVal VirtKey As Integer) As Long
    RegHotKey = GlobalAddAtom(CStr(Rnd))            'Берем ID, совершенно от фонарика
    If RegisterHotKey(hWnd, RegHotKey, Modifiers, VirtKey) = 0 Then _
        RegHotKey = 0: MsgBox VBGetLastError(GetLastError): Exit Function               'Это если мы не смогли зарегиться
    If OldWndProc = 0 Then _
        OldWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf HotKeyWindowProc)
End Function
'Удаление горячей клавиши
Public Function UnRegHotKey(hWnd As Long, ByVal ID As Integer, Optional UnSubCass As Boolean = False) As Boolean
    If UnregisterHotKey(hWnd, ID) = 0 Then Exit Function    'Анрегим
    Call GlobalDeleteAtom(ID)                               'Освобождаем
    UnRegHotKey = True                                      'Говорим
    If UnSubCass Then Call SetWindowLong(hWnd, GWL_WNDPROC, OldWndProc)
End Function
'Вспомогательные функции
Private Function LoWord(DWord As Long) As Integer
    LoWord = IIf(DWord And &H8000&, DWord Or &HFFFF0000, DWord And &HFFFF&
End Function
Private Function HiWord(DWord As Long) As Integer
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Public Function VBGetLastError(ByVal ID As Long) As String
    Dim lStr As Long
    VBGetLastError = Space(512)
    lStr = FormatMessage(&H1000, 0&, ID, 0&, VBGetLastError, Len(VBGetLastError), 0&
    VBGetLastError = Left(VBGetLastError, lStr)
End Function

Public Function GetHotKeyText(ByVal VK As Integer, Shift As Integer) As String
    Dim KeyName As String * 256
    
    If Shift Then GetHotKeyText = Choose(Shift, "Shift", "Ctrl", "Shift + Ctrl", "Alt", "Shift + Alt", "Ctrl + Alt", "Shift + Ctrl + Alt" & " + "
    If VK = 17 Or VK = 16 Or VK = 18 Then Exit Function
    
    GetHotKeyText = GetHotKeyText & Left(KeyName, GetKeyNameText(ByVal MapVirtualKey(VK, 0) * &H10000, KeyName, 255))
End Function

Private Function LoByte(ByVal InValue As Integer) As Byte
    LoByte = (InValue And &HFF&
End Function

Private Function HiByte(ByVal InValue As Integer) As Byte
    HiByte = (InValue And &HFF00& \ &H100&
End Function

Private Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
    MakeWord = (HiByte * &H100) Or (LoByte And &HFF&
End Function

Private Function LoWord(DWord As Long) As Integer
    LoWord = IIf(DWord And &H8000&, DWord Or &HFFFF0000, DWord And &HFFFF&
End Function

Private Function HiWord(DWord As Long) As Integer
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Private Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&
End Function

VERSION 5.00
Begin VB.Form frmMain
   Caption = "Form1"
   ClientHeight = 3195
   ClientLeft = 60
   ClientTop = 345
   ClientWidth = 7275
   KeyPreview = -1 'True
   LinkTopic = "Form1"
   ScaleHeight = 3195
   ScaleWidth = 7275
   StartUpPosition = 3 'Windows Default
   Begin VB.ListBox List1
      Height = 2010
      Left = 2940
      TabIndex = 2
      Top = 990
      Width = 4245
   End
   Begin VB.TextBox Text1
      Height = 285
      Index = 0
      Left = 120
      Locked = -1 'True
      TabIndex = 0
      Text = "Text1"
      Top = 75
      Width = 2730
   End
   Begin VB.Label Label1
      Caption = "Пример демонстрирует работу с горячими клавишами. По умолчанию: Ctrl + n, где n - цифра."
      Height = 735
      Left = 3000
      TabIndex = 1
      Top = 135
      Width = 4200
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ID() As Integer

Private Sub Form_Load()
    im n As Integer
    n = Val(InputBox("Сколько горячих клавишь хотите создать (1 - 10)", , "3") - 1
    
    ReDim ID(n)
    
    For n = 0 To n
        ID(n) = RegHotKey(Me.hWnd, MOD_CONTROL, Asc(CStr(n)))
        If Not n = 0 Then
            Call Load(Text1(n))
            Text1(n).Top = Text1(n - 1).Top + Text1(n - 1).Height
            Text1(n).Visible = True
        End If
        Text1(n).Text = "Ctrl + " & n
        oEvents
    Next
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    im i As Integer
    For i = 0 To UBound(ID)
        Call UnRegHotKey(Me.hWnd, ID(i), IIf(i = UBound(ID), True, False))
    Next
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    'If Shift = 0 Then Exit Sub
    'Call UnRegHotKey(Me.hWnd, ID(Index)) 'Удаляем горячую главишу
    'Показываем сочетание клавишь в TextBox'e
    'Text1(Index).Text = Choose(Shift, "Shift", "Ctrl", "Shift + Ctrl", "Alt", "Shift + Alt", "Ctrl + Alt", "Shift + Ctrl + Alt" & " + " & Chr(KeyCode)
    'Т.к. Сочетания Shift & Alt клавишь не совпадает в VB и API, то ...
    'Shift = Choose(Shift, 4, 2, 6, 1, 5, 3, 7)
    'Регим новую горячую клавишу
    'ID(Index) = RegHotKey(Me.hWnd, Shift, KeyCode)
    
    Text1(Index).Text = GetHotKeyText(KeyCode, Shift)
End Sub