(******************************************************************************
 *                                                                            *
 *  Придумал и написал Кода Виктор, Март 2002                                 *
 *                                                                            *
 *  Файл:       main.pas                                                      *
 *  Содержание: Пример буферизированного опроса мыши методами DirectInput     *
 *                                                                            *
 ******************************************************************************)
unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ExtCtrls;

type
  TForm1 = class(TForm)
    gb1: TGroupBox;
    lbX0: TLabel;
    lbY0: TLabel;
    lbX: TLabel;
    lbY: TLabel;
    lb1: TLabel;
    lb2: TLabel;
    lb3: TLabel;
    lb4: TLabel;
    lbBtn1: TLabel;
    lbBtn2: TLabel;
    lbBtn3: TLabel;
    lbBtn4: TLabel;
    imCursor: TImage;
    procedure FormActivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Idle( Sender: TObject; var Done: Boolean );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DirectInput8;




//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
var
  lpDI8:     IDirectInput8       = nil;
  lpDIMouse: IDirectInputDevice8 = nil;

  mouseX:    LongInt = 0;
  mouseY:    LongInt = 0;



  
//------------------------------------------------------------------------------
// Имя:      InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
var
  dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши
begin
  Result := FALSE;

  // Создаём главный объект DirectInput
  if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
                                 IID_IDirectInput8, lpDI8, nil ) ) then
     Exit;
  lpDI8._AddRef();

  // Создаём объект для работы с мышью
  if FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then
     Exit;
  lpDIMouse._AddRef();

  // Устанавлаваем предопределённый формат данных
  if FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then
     Exit;

  // Устанавливаем уровень кооперации
  if FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or
                                                  DISCL_EXCLUSIVE ) ) then
     Exit;

  // Подготавливаем структуру TDIPROPDWORD, она поможет установить нам
  // буферизированный опрос мыши
  ZeroMemory( @dipropdw, SizeOf( TDIPROPDWORD ) );
  dipropdw.diph.dwSize := SizeOf( TDIPROPDWORD );
  dipropdw.diph.dwHeaderSize := SizeOf( TDIPROPHEADER );

  dipropdw.diph.dwObj := 0;
  dipropdw.diph.dwHow := DIPH_DEVICE; // Изменяем х-ки всего устройства
  dipropdw.dwData := 16;              // Размер буфера для данных (по умолчанию 0)

  // Устанавливаем размер буфера для мыши
  if FAILED( lpDIMouse.SetProperty( DIPROP_BUFFERSIZE, dipropdw.diph ) ) then
     Exit;

  // Захвытываем мышь
  lpDIMouse.Acquire();

  Result := TRUE;
end;




//------------------------------------------------------------------------------
// Имя:      ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
  // Удаляем объект для работы с мышью
  if lpDIMouse <> nil then
  begin
    lpDIMouse.Unacquire();
    lpDIMouse._Release();
    lpDIMouse := nil;
  end;

  // Удаляем главный объект DirectInput (всегда последним)
  if lpDI8 <> nil then
  begin
    lpDI8._Release();
    lpDI8 := nil;
  end;
end;




//------------------------------------------------------------------------------
// Имя:      GetMouseCaps()
// Описание: Получает характеристики мыши (определяет кол-во кнопок)
//------------------------------------------------------------------------------
procedure GetMouseCaps();
var
  lpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши
begin
  // Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши)
  ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) );
  lpCaps.dwSize := SizeOf( TDIDEVCAPS );

  // Получаем характеристики мыши, данные записывааются в структуру lpCaps
  lpDIMouse.GetCapabilities( lpCaps );

  // Приводим UI в соответствующий вид
  with Form1 do
  begin
    if lpCaps.dwButtons > 0 then
    begin
      lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 1 then
    begin
      lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 2 then
    begin
      lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 3 then
    begin
      lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE;
    end;
  end;
end;




//------------------------------------------------------------------------------
// Имя:      UpdateMouseState()
// Описание: Производит опрос мыши и выводит данные в окно
//------------------------------------------------------------------------------
function UpdateMouseState( var(*по параметру*)dwX, dwY: DWORD ): Boolean;
var
  od:         TDIDEVICEOBJECTDATA;
  dwElements: DWORD;
begin
  Result := FALSE;

  // Обазательно обнуляем!
  dwX := 0;
  dwY := 0;

  dwElements := 1;

  // Пока количество опрашиваемых элементов мыши (оси, кнопки, колёсики ) <> 0
  while dwElements <> 0 do
  begin
    // Получаем данные от мыши
    if lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
                                dwElements, 0 ) = DIERR_INPUTLOST then
    begin
      // Снова захватываем
      lpDIMouse.Acquire();
      // Если всё бесполезно, то выходим
      if FAILED( lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
                                          dwElements, 0 ) ) then
         Exit;
    end;

    with Form1 do
    begin
      case od.dwOfs of
        DIMOFS_X:       dwX := od.dwData;
        DIMOFS_Y:       dwY := od.dwData;
        DIMOFS_BUTTON0: if od.dwData = $080 then lbBtn1.Caption := 'Нажата'
                                            else lbBtn1.Caption := '';
        DIMOFS_BUTTON1: if od.dwData = $080 then lbBtn2.Caption := 'Нажата'
                                            else lbBtn2.Caption := '';
        DIMOFS_BUTTON2: if od.dwData = $080 then lbBtn3.Caption := 'Нажата'
                                            else lbBtn3.Caption := '';
        DIMOFS_BUTTON3: if od.dwData = $080 then lbBtn4.Caption := 'Нажата'
                                            else lbBtn4.Caption := '';
      end;
    end;
  end;

  Result := TRUE;
end;




//------------------------------------------------------------------------------
// Имя:      TForm1.Idle()
// Описание: Вызывает функцию опроса состояния мыши
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
  dwOffsX,
  dwOffsY: DWORD; // Смещение мыши
begin
  // Получаем данные и записываем их в offsX и offsY
  if not UpdateMouseState( dwOffsX, dwOffsY ) then
  begin
    MessageBox( Form1.Handle, 'Потеряно устройство ввода!',
                'Ошибка', MB_ICONHAND );
    Form1.Close();
  end;

  // Вычисляем абсолютные координаты
  Inc( mouseX, dwOffsX );
  Inc( mouseY, dwOffsY );

  lbX.Caption := Format( '%d', [ mouseX ] );
  lbY.Caption := Format( '%d', [ mouseY ] );

  imCursor.Left := 234 + mouseX; // 234 - координата, если мы хотим, чтобы
  imCursor.Top  := 234 + mouseY; // курсор был с начала работы в центре окна

  Done := FALSE;
end;




//------------------------------------------------------------------------------
// Имя:      TForm1.FormActivate()
// Описание: Производит инициализацию DirectInput при активизации окна
//------------------------------------------------------------------------------
procedure TForm1.FormActivate(Sender: TObject);
begin
  if not InitDirectInput( Form1.Handle ) then
  begin
    MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
                'Ошибка!', MB_ICONHAND );
    Form1.Close();
  end;

  // Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как
  // определить, есть ли у мыши колёсико?
  GetMouseCaps();

  // Приводим UI в соответствующий вид
  lbBtn1.Caption := '';
  lbBtn2.Caption := '';
  lbBtn3.Caption := '';
  lbBtn4.Caption := '';

  Application.OnIdle := Idle;
end;




//------------------------------------------------------------------------------
// Имя:      TForm1.FormKeyDown()
// Описание: Обрабатывает клавиатурный ввод
//------------------------------------------------------------------------------
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Form1.Close();
end;




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

end.