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

Previous  Top  Next

    
 

 

 

Code:

{******************************************************************************

*                                                                            *

*  Придумал и написал Кода Виктор, Март 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;

 

 

 

 

//------------------------------------------------------------------------------

// Имя:      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.

 

 

 

Форма:

Code:

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

 

 

 

 

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

по материалам fido7.ru.delphi.*

©Drkb::03914