Пример использования 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