Код первого модуля
- Код: Выделить всё
'Регистрация клавиш на приложение
Public Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Public Const MOD_WIN = &H8
'Описание класса окна
Public Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As String) As Long
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Public Const CS_HREDRAW = &H2
Public Const CS_VREDRAW = &H1
Public Const IDI_APPLICATION = 32512&
Public Const IDC_ARROW = 32512&
Public Const WHITE_BRUSH = 0
'Регистрация класса
Public Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long
Public Type WNDCLASS
style As Long
lpfnwndproc As Long
cbClsextra As Long
cbWndExtra2 As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
End Type
'Создание окна
Public 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
Public Const WS_POPUP = &H80000000
'Обработка сообщений окна
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
'Обработка сообщений окна по умолчанию
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Удаление зарегистированного класса
Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
'Сообщение
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Const MB_OK = &H0&
Public Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public hWndSpecChar As Long
Public Const CLSNAME = "ClsSpecChar"
Public Const APPNAME = "SpecChar"
Sub Main()
Dim WndCl As WNDCLASS
Dim wMsg As MSG
Dim adr As Long
'Описываю класс
With WndCl
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnwndproc = GetAddress(AddressOf SpecCharWndProc)
.cbClsextra = 0&
.cbWndExtra2 = 0&
.hInstance = App.hInstance
.hIcon = LoadIcon(0&, IDI_APPLICATION)
.hCursor = LoadCursor(0, IDC_ARROW)
.hbrBackground = GetStockObject(WHITE_BRUSH)
.lpszMenuName = vbNullString
.lpszClassName = CLSNAME
End With
'Регистрирую его
If RegisterClass(WndCl) = 0 Then _
MessageBox 0&, "Не удается зарегистировать класс " & CLSNAME & "!", APPNAME & " Ошибка", MB_OK: _
Exit Sub
'Создаю окно
hWndSpecChar = CreateWindowEx(0&, CLSNAME, "", WS_POPUP, 0, 0, 0, 0, 0, 0, WndCl.hInstance, vbNullString)
'Регистрирую на себя сочетания клавиш
RegisterHotKey hWndSpecChar, &HBFFF, MOD_WIN, vbKeyT 'Win+T
RegisterHotKey hWndSpecChar, &HC000, MOD_WIN, vbKeyG 'Win+G
RegisterHotKey hWndSpecChar, &HC001, MOD_WIN, vbKeyJ 'Win+J
'Обрабатываю сообщения, пока не получу сообщение о выходе
Do While GetMessage(wMsg, 0&, 0&, 0&)
DispatchMessage wMsg
Loop
'Удаляю зарегистрированные клавиши
UnregisterHotKey hWndSpecChar, &HBFFF
UnregisterHotKey hWndSpecChar, &HC000
UnregisterHotKey hWndSpecChar, &HC001
'Удаляю класс
UnregisterClass CLSNAME, App.hInstance
End Sub
Public Function GetAddress(ByVal lngAddr As Long) As Long
GetAddress = lngAddr
End Function
Обрабатываю сообщения окна:
Код второго модуля
- Код: Выделить всё
Option Explicit
'Сообщения в окно
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_HOTKEY = &H312
Public Const WM_CLOSE = &H10
Public Const WM_QUIT = &H12
Public Const WM_COMMAND = &H111
'Работа с курсором
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetFocus Lib "user32" () As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public CursorPos As POINTAPI
Public CaretPos As POINTAPI
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
'Работа с меню
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long
Public Const MF_ENABLED = &H0&
Public Const MF_GRAYED = &H1&
Public Const TPM_RIGHTALIGN = &H8&
Public hPopMenu As Long
'-------------
Dim hFcsWnd As Long, rectFrgWnd As RECT, rectWinPoint As POINTAPI
Dim hWndBk As Long, sWndBkName As String * 50
Dim hDC As Long
Public Function SpecCharWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static i As Long
Select Case uMsg
Case WM_HOTKEY 'Если нажали горячую клавишу
Select Case wParam 'Какую горячую клавишу нажали
Case &HBFFF 'Win+T
Dim j As Integer
hPopMenu = CreatePopupMenu
'Заполняем меню. Четные неактивны, нечетные активны.
For j = 1 To 10
AppendMenu hPopMenu, IIf(j Mod 2 <> 0, MF_ENABLED, MF_GRAYED), CLng(j), CStr(j)
Next j
Call GetCaretPos(CaretPos) 'Позиция курсора ввода текста
hFcsWnd = GetFocus 'Окно, в котором работает пользователь
GetClientRect hFcsWnd, rectFrgWnd 'Координаты активного окна
rectWinPoint.y = rectFrgWnd.Top
rectWinPoint.x = rectFrgWnd.Left
ClientToScreen hFcsWnd, rectWinPoint 'Координаты активного окна в экранных координатах
i = i + 1
Debug.Print i & " Win+T" & vbTab & "X:" & CaretPos.x & " Y:" & CaretPos.y
'Показываем меню
TrackPopupMenu hPopMenu, &H0, rectWinPoint.x + CaretPos.x, rectWinPoint.y + CaretPos.y, 0, hWndSpecChar, 0
DestroyMenu hPopMenu
Case &HC000 'Win+G
i = i + 1
Call GetCursorPos(CursorPos) 'Позиция курсора мыши
hWndBk = WindowFromPoint(CursorPos.x, CursorPos.y)
Call GetWindowText(hWndBk, sWndBkName, 50)
Debug.Print i & " Курсор мыши находится в точке X=" & CursorPos.x & "; Y=" & CursorPos.y & ". Над окном " & sWndBkName & vbCr & _
"Курсор ввода находится в точке X = " & CaretPos.x & "; Y = " & CaretPos.y
Case &HC001 'Win+J
Debug.Print "Выход из программы…"
Call SendMessage(hWndSpecChar, WM_CLOSE, 0, 0)
End Select
Case WM_COMMAND
If wParam >= &H1 And wParam <= &H10 Then
Debug.Print "wParam = &H" & Hex(wParam) & "; lParam = &H" & Hex(lParam)
End If
End Select
SpecCharWndProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Function
