Пример использования DirectInput для опроса клавиатуры
Материал из DRKB
{******************************************************************************
* *
* Придумал и написал Кода Виктор, Март 2002 *
* *
* Файл: main.pas *
* Содержание: Пример использования DirectInput для опроса клавиатуры *
* *
******************************************************************************}
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ComCtrls,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
gb1: TGroupBox;
gb2: TGroupBox;
gb3: TGroupBox;
lbRemark: TLabel;
imView: TImage;
rbWM: TRadioButton;
rgDI8: TRadioButton;
lbKeys: TLabel;
lbIndex: TLabel;
btnClose: TButton;
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Hook( var Msg: TMsg; var Handled: Boolean );
procedure Idle( Sender: TObject; var Done: Boolean );
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
DirectInput8;
// Константы и глобальные переменные
var
lpDI8: IDirectInput8 = nil;
lpDIKeyboard: IDirectInputDevice8 = nil;
nXPos, nYPos: Integer;
// Производит инициализацию объектов DirectInput в программе
function InitDirectInput(hWnd: HWND): Boolean;
begin
Result := False;
// Создаём главный объект DirectInput
if FAILED(DirectInput8Create(GetModuleHandle(0), DIRECTINPUT_VERSION, IID_IDirectInput8, lpDI8, nil)) then
Exit;
lpDI8._AddRef();
// Создаём объект для работы с клавиатурой
if FAILED(lpDI8.CreateDevice(GUID_SysKeyboard, lpDIKeyboard, nil)) then
Exit;
lpDIKeyboard._AddRef();
// Устанавливаем предопределённый формат для "простой клавиатуры". В большинстве
// случаев можно удовлетвориться и установками, заданными в структуре
// c_dfDIKeyboard по умолчанию, но в особых случаях нужно заполнить её самому
if FAILED(lpDIKeyboard.SetDataFormat(@c_dfDIKeyboard)) then
Exit;
// Устанавливаем уровень кооперации. Подробности о флагах смотри в DirectX SDK
if FAILED(lpDIKeyboard.SetCooperativeLevel(hWnd, DISCL_BACKGROUND or DISCL_NONEXCLUSIVE)) then
Exit;
// Захватываем клавиатуру
lpDIKeyboard.Acquire();
Result := True;
end;
// Производит удаление объектов DirectInput
procedure ReleaseDirectInput();
begin
// Удаляем объект для работы с клавиатурой
if lpDIKeyboard <> nil then // Можно проверить if Assigned(DIKeyboard)
begin
lpDIKeyboard.Unacquire(); // Освобождаем устройство
lpDIKeyboard._Release();
lpDIKeyboard := nil;
end;
// Последним удаляем главный объект DirectInput
if lpDI8 <> nil then
begin
lpDI8._Release();
lpDI8 := nil;
end;
end;
// Обрабатывает клавиатурный ввод методом DirectInput
function UpdateKeyboardState(): Boolean;
var
bKeyBuffer: array [0..255] of Byte;
i: Integer;
hr: HResult;
begin
Result := False;
// Производим опрос состояния клавиш, данные записываются в буфер-массив
if lpDIKeyboard.GetDeviceState(SizeOf(bKeyBuffer), @bKeyBuffer) = DIERR_INPUTLOST then
begin
// Захватываем снова
lpDIKeyboard.Acquire();
// Производим повторный опрос
if FAILED(lpDIKeyboard.GetDeviceState(SizeOf(bKeyBuffer), @bKeyBuffer)) then
Exit;
end;
// Изменяем координаты курсора
if bKeyBuffer[DIK_NUMPAD4] = $080 then Dec(nXPos);
if bKeyBuffer[DIK_NUMPAD6] = $080 then Inc(nXPos);
if bKeyBuffer[DIK_NUMPAD8] = $080 then Dec(nYPos);
if bKeyBuffer[DIK_NUMPAD2] = $080 then Inc(nYPos);
// Выводим список кодов нажатых клавиш
with Form1.lbKeys do
begin
Caption := '';
for i := 0 to 255 do
begin
if bKeyBuffer[i] = $080 then
if i <= 9 then
Caption := Caption + Format('0%d ', [i])
else
Caption := Caption + Format('%d ', [i]);
end;
end;
Result := True;
end;
// Обрабатывает клавиатурный ввод подобно главной функции окна
procedure TForm1.Hook(var Msg: TMsg; var Handled: Boolean);
var
i: Integer;
begin
if Msg.message <> WM_KEYDOWN then
Exit;
// Изменяем координаты курсора
case Msg.wParam of
VK_NUMPAD4: Dec(nXPos);
VK_NUMPAD6: Inc(nXPos);
VK_NUMPAD8: Dec(nYPos);
VK_NUMPAD2: Inc(nYPos);
end;
// Выводим код нажатой клавиши
with Form1.lbKeys do
begin
Caption := '';
// Бессмысленно писать for i := 0 to 255 do ... При обработке сообщения
// WM_KEYDOWN мы можем узнать состояние только одной клавиши - ведь массив
// не используется. Справедливости ради надо сказать, что в Windows есть
// функция GetKeyboardState(), работающая с массивом и очень быстро
if Msg.wParam <= 9 then
Caption := Caption + Format('0%d ', [Msg.wParam])
else
Caption := Caption + Format('%d ', [Msg.wParam]);
end;
// Блокируем дальнейшую обработку события
Handled := True;
end;
// Вызывает функцию опроса состояния клавиатуры
procedure TForm1.Idle(Sender: TObject; var Done: Boolean);
var
i: Integer;
begin
if rbWM.Checked then
Application.OnMessage := Hook
else
begin
Application.OnMessage := nil;
// Если данные от клавиатуры не получены
if not UpdateKeyboardState() then
begin
MessageBox(Form1.Handle, 'Потеряно устройство управления!', 'Ошибка!', MB_ICONHAND);
Form1.Close();
end;
end;
// Проверяем выход курсора за пределы диапазона
if nXPos < 0 then
nXPos := 0;
if (nXPos + 10) > 140 then
nXPos := 130;
if nYPos < 0 then
nYPos := 0;
if (nYPos + 10) > 140 then
nYPos := 130;
// Рисуем курсор
with imView.Canvas do
begin
FillRect(Canvas.ClipRect);
Brush.Color := clRed;
Rectangle(nXPos, nYPos, nXPos + 10, nYPos + 10);
Brush.Color := clWhite;
end;
Done := False;
end;
// Производит инициализацию DirectInput при старте программы
procedure TForm1.FormCreate(Sender: TObject);
begin
if not InitDirectInput(Form1.Handle) then
begin
MessageBox(Form1.Handle, 'Ошибка при инициализации DirectInput!', 'Ошибка!', MB_ICONHAND);
ReleaseDirectInput();
Halt;
end;
// Приводим UI в соответствующий вид
lbKeys.Caption := '';
// Назначаем обработчик Idle-события. Компонент TTimer не позволит раскрыть
// всех преимуществ использования DirectInput
Application.OnIdle := Idle;
end;
// Закрывает программу
procedure TForm1.btnCloseClick(Sender: TObject);
begin
Form1.Close();
end;
// Вызывается при удалении программы из памяти
procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseDirectInput();
end;
end.
Форма:
object Form1: TForm1
Left = 192
Top = 106
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'DirectInput 8: Клавиатура'
ClientHeight = 318
ClientWidth = 377
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lbRemark: TLabel
Left = 8
Top = 8
Width = 338
Height = 13
Caption = 'Используйте num-клавиши клавиатуры для перемещения курсора'
end
object btnClose: TButton
Left = 294
Top = 288
Width = 75
Height = 23
Cancel = True
Caption = 'Закрыть'
TabOrder = 0
OnClick = btnCloseClick
end
object gb1: TGroupBox
Left = 8
Top = 32
Width = 177
Height = 177
Caption = 'Визуальная проверка'
TabOrder = 1
object imView: TImage
Left = 19
Top = 24
Width = 140
Height = 140
end
end
object gb3: TGroupBox
Left = 8
Top = 216
Width = 361
Height = 65
Caption = 'Клавиши'
TabOrder = 2
object lbKeys: TLabel
Left = 64
Top = 24
Width = 289
Height = 17
AutoSize = False
Caption = 'lbKeys'
end
object lbIndex: TLabel
Left = 8
Top = 24
Width = 49
Height = 13
Caption = 'Индексы:'
end
end
object gb2: TGroupBox
Left = 200
Top = 32
Width = 169
Height = 177
Caption = 'Способ опроса'
TabOrder = 3
object rbWM: TRadioButton
Left = 24
Top = 56
Width = 129
Height = 17
Caption = 'Windows Messaging'
Checked = True
TabOrder = 0
TabStop = True
end
object rgDI8: TRadioButton
Left = 24
Top = 104
Width = 129
Height = 17
Caption = 'DirectInput 8'
TabOrder = 1
end
end
end
по материалам fido7.ru.delphi.*
Source: Взято с сайта Анатолия Подгорецкого http://podgoretsky.com
ID: 03914