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

{******************************************************************************
 * *
 * Придумал и написал Кода Виктор, Март 2002 *
 * *
 * Файл: main.pas *
 * Содержание:  *
 * *
 ******************************************************************************}

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;


//------------------------------------------------------------------------------
// Имя: InitDirectInput()
// Описание: Производит инициализацию объектов 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;


//------------------------------------------------------------------------------
// Имя: ReleaseDirectInput()
// Описание: Производит удаление объектов 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;


//------------------------------------------------------------------------------
// Имя: UpdateKeyboardState()
// Описание: Обрабатывает клавиатурный ввод методом 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
  if bKeyBuffer[ i ] = $080 then
  if i <= 9 then Caption := Caption + Format( '0%d ', [ i ] )
  else Caption := Caption + Format( '%d ', [ i ] );
 end;
 Result := TRUE;
end;


//------------------------------------------------------------------------------
// Имя: TForm1.Hook()
// Описание: Обрабатывает клавиатурный ввод подобно главной функции окна
//------------------------------------------------------------------------------
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;


//------------------------------------------------------------------------------
// Имя: TForm1.Idle()
// Описание: Вызывает функцию опроса состояния клавиатуры
//------------------------------------------------------------------------------
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;


//------------------------------------------------------------------------------
// Имя: TForm1.FormCreate()
// Описание: Производит инициализацию 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;


//------------------------------------------------------------------------------
// Имя: TForm1.btnCloseClick()
// Описание: Закрывает программу
//------------------------------------------------------------------------------
procedure TForm1.btnCloseClick(Sender: TObject);
begin
 Form1.Close();
end;


//------------------------------------------------------------------------------
// Имя: TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
 ReleaseDirectInput();
end;
end.

Форма:

object Form1: TForm1

 Left = 192

  = 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

   = 8

  Width = 338

  Height = 13

  Caption = 'Используйте num-клавиши клавиатуры для перемещения курсора'

 end

 object btnClose: TButton

  Left = 294

   = 288

  Width = 75

  Height = 23

  Cancel = True

  Caption = 'Закрыть'

  TabOrder = 0

  OnClick = btnCloseClick

 end

 object gb1: TGroupBox

  Left = 8

   = 32

  Width = 177

  Height = 177

  Caption = 'Визуальная проверка'

  TabOrder = 1

  object imView: TImage

  Left = 19

   = 24

  Width = 140

  Height = 140

  end

 end

 object gb3: TGroupBox

  Left = 8

   = 216

  Width = 361

  Height = 65

  Caption = 'Клавиши'

  TabOrder = 2

  object lbKeys: TLabel

  Left = 64

   = 24

  Width = 289

  Height = 17

  AutoSize = False

  Caption = 'lbKeys'

  end

  object lbIndex: TLabel

  Left = 8

   = 24

  Width = 49

  Height = 13

  Caption = 'Индексы:'

  end

 end

 object gb2: TGroupBox

  Left = 200

   = 32

  Width = 169

  Height = 177

  Caption = 'Способ опроса'

  TabOrder = 3

  object rbWM: TRadioButton

  Left = 24

   = 56

  Width = 129

  Height = 17

  Caption = 'Windows Messaging'

  Checked = True

  TabOrder = 0

  TabStop = True

  end

  object rgDI8: TRadioButton

  Left = 24

   = 104

  Width = 129

  Height = 17

  Caption = 'DirectInput 8'

  TabOrder = 1

  end

 end

end

Взято с сайта Анатолия Подгорецкого http://podgoretsky.com
по материалам fido7.ru.delphi.*

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...