Пример использования DirectInput для опроса клавиатуры

{******************************************************************************
 * *
 * Придумал и написал Кода Виктор, Март 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
Category:Графика
Category:DirectX