Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым
DRKB ➤ Графика и Мультимедиа ➤ DirectX и DelphiX ➤ Пример опроса мыши методами DirectInput
DRKB Banner

Все желающие могут разместить у себя на сайте баннер DRKB:

DRKB

Код баннера:


Top.Mail.Ru


Пример опроса мыши методами DirectInput

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

Форма:

object Form1: TForm1
  Left = 221
  Top = 31
  BorderIcons = []
  BorderStyle = bsSingle
  Caption = 
    'DirectInput 8: буферизированный опрос мыши (нажмите Esc для выхо' +
    'да)'
  ClientHeight = 500
  ClientWidth = 500
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  Position = poScreenCenter
  OnActivate = FormActivate
  OnDestroy = FormDestroy
  OnKeyDown = FormKeyDown
  PixelsPerInch = 96
  TextHeight = 13
  object imCursor: TImage
    Left = 234
    Top = 234
    Width = 32
    Height = 32
    AutoSize = True
    Picture.Data = {
      055449636F6E0000010001002020000001000800A80800001600000028000000
      2000000040000000010008000000000080040000000000000000000000010000
      0000000000000000800080008000000080800000008000000080800000008000
      C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
      00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
      6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
      00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
      0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
      6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
      00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
      4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
      C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
      32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
      DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
      FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
      50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
      DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
      FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
      50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
      DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
      FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
      50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
      DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
      C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
      32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
      49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
      6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
      00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
      00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
      6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
      00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
      00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
      CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
      6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
      0E0E0E0000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000BABA00000000000000000000000000000000000000
      00000000000000000000C5C5C5BA000000000000000000000000000000000000
      00000000000000000000C5ABC5BA000000000000000000000000000000000000
      000000000000000000C5ABC5BA00000000000000000000000000000000000000
      00000000C500000000C5ABC5BA00000000000000000000000000000000000000
      00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
      00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
      00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
      00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
      00000000C2C4D1C5000000000000000000000000000000000000000000000000
      00000000C2C5C500000000000000000000000000000000000000000000000000
      00000000C2C50000000000000000000000000000000000000000000000000000
      00000000D0000000000000000000000000000000000000000000000000000000
      00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
      FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
      007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
      7FFFFFFF}
  end
  object gb1: TGroupBox
    Left = 360
    Top = 8
    Width = 129
    Height = 145
    Caption = 'Состояние мыши'
    TabOrder = 0
    object lbX0: TLabel
      Left = 17
      Top = 24
      Width = 10
      Height = 13
      Caption = 'X:'
    end
    object lbY0: TLabel
      Left = 17
      Top = 40
      Width = 10
      Height = 13
      Caption = 'Y:'
    end
    object lb1: TLabel
      Left = 16
      Top = 64
      Width = 46
      Height = 13
      Caption = 'Кнопка1:'
      Enabled = False
    end
    object lb2: TLabel
      Left = 16
      Top = 80
      Width = 46
      Height = 13
      Caption = 'Кнопка2:'
      Enabled = False
    end
    object lb3: TLabel
      Left = 16
      Top = 96
      Width = 46
      Height = 13
      Caption = 'Кнопка3:'
      Enabled = False
    end
    object lbBtn1: TLabel
      Left = 72
      Top = 64
      Width = 30
      Height = 13
      Caption = 'lbBtn1'
      Enabled = False
    end
    object lbBtn2: TLabel
      Left = 72
      Top = 80
      Width = 30
      Height = 13
      Caption = 'lbBtn2'
      Enabled = False
    end
    object lbBtn3: TLabel
      Left = 72
      Top = 96
      Width = 30
      Height = 13
      Caption = 'lbBtn3'
      Enabled = False
    end
    object lb4: TLabel
      Left = 16
      Top = 112
      Width = 46
      Height = 13
      Caption = 'Кнопка4:'
      Enabled = False
    end
    object lbBtn4: TLabel
      Left = 72
      Top = 112
      Width = 30
      Height = 13
      Caption = 'lbBtn4'
      Enabled = False
    end
    object lbX: TLabel
      Left = 72
      Top = 24
      Width = 6
      Height = 13
      Caption = '0'
    end
    object lbY: TLabel
      Left = 72
      Top = 40
      Width = 6
      Height = 13
      Caption = '0'
    end
  end
end

{******************************************************************************
 *                                                                            *
 *  Придумал и написал Кода Виктор, Март 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;
    lbEMail: TLabel;
    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;
 
 
 
 
//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
const
  CURSOR_SPEED = 2.0;
 
var
  lpDI8:       IDirectInput8       = nil;
  lpDIMouse:   IDirectInputDevice8 = nil;
 
  dwMouseXPos: DWORD = 0;
  dwMouseYPos: DWORD = 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;
 
  // Захвытываем мышь
  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 );
 
  // Приводим GUI в соответствующий вид
  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(*по параметру*)x, y: DWORD ): Boolean;
var
  ms: TDIMOUSESTATE;
begin
  Result := FALSE;
 
  // Получаем данные от мыши
  if lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) = DIERR_INPUTLOST then
  begin
    // Снова захватываем
    lpDIMouse.Acquire();
    // Если всё бесполезно, то выходим
    if FAILED( lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) ) then
       Exit;
  end;
 
  with Form1 do
  begin
    // Вот так можно сделать движение курсора с переменной скоростью
    if ms.lX < 0 then ms.lX := Round( ms.lX * CURSOR_SPEED ) else
    if ms.lX > 0 then ms.lX := Round( ms.lX * CURSOR_SPEED );
 
    if ms.lY < 0 then ms.lY := Round( ms.lY * CURSOR_SPEED ) else
    if ms.lY > 0 then ms.lY := Round( ms.lY * CURSOR_SPEED );
 
    x := ms.lX ;
    y := ms.lY;
 
    //------
 
    if ms.rgbButtons[ 0 ] = $080 then lbBtn1.Caption := 'Нажата'
                                 else lbBtn1.Caption := '';
    if ms.rgbButtons[ 1 ] = $080 then lbBtn2.Caption := 'Нажата'
                                 else lbBtn2.Caption := '';
    if ms.rgbButtons[ 2 ] = $080 then lbBtn3.Caption := 'Нажата'
                                 else lbBtn3.Caption := '';
    if ms.rgbButtons[ 3 ] = $080 then lbBtn4.Caption := 'Нажата'
                                 else lbBtn4.Caption := '';
  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( dwMouseXPos, dwOffsX );
  Inc( dwMouseYPos, dwOffsY );
 
  lbX.Caption := Format( '%d', [ dwMouseXPos ] );
  lbY.Caption := Format( '%d', [ dwMouseYPos ] );
 
  imCursor.Left := 234 + dwMouseXPos; // 234 - координата, если мы хотим, чтобы
  imCursor.Top  := 234 + dwMouseYPos; // курсор был с начала работы в центре окна
 
  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 := '';
  imCursor.Left := 184; // Курсор центре окна
  imCursor.Top  := 184;
 
  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.

форма:

object Form1: TForm1
  Left = 155
  Top = 34
  BorderIcons = []
  BorderStyle = bsSingle
  Caption = 
    'DirectInput 8: непосредственный опрос мыши (нажмите Esc для выхо' +
    'да)'
  ClientHeight = 500
  ClientWidth = 500
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  Position = poScreenCenter
  OnActivate = FormActivate
  OnDestroy = FormDestroy
  OnKeyDown = FormKeyDown
  PixelsPerInch = 96
  TextHeight = 13
  object imCursor: TImage
    Left = 234
    Top = 234
    Width = 32
    Height = 32
    AutoSize = True
    Picture.Data = {
      055449636F6E0000010001002020000001000800A80800001600000028000000
      2000000040000000010008000000000080040000000000000000000000010000
      0000000000000000800080008000000080800000008000000080800000008000
      C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
      00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
      6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
      00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
      0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
      6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
      00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
      4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
      C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
      32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
      DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
      FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
      50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
      DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
      FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
      50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
      DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
      FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
      50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
      DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
      C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
      32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
      49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
      6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
      00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
      00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
      6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
      00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
      00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
      CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
      6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
      0E0E0E0000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000BABA00000000000000000000000000000000000000
      00000000000000000000C5C5C5BA000000000000000000000000000000000000
      00000000000000000000C5ABC5BA000000000000000000000000000000000000
      000000000000000000C5ABC5BA00000000000000000000000000000000000000
      00000000C500000000C5ABC5BA00000000000000000000000000000000000000
      00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
      00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
      00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
      00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
      00000000C2C4D1C5000000000000000000000000000000000000000000000000
      00000000C2C5C500000000000000000000000000000000000000000000000000
      00000000C2C50000000000000000000000000000000000000000000000000000
      00000000D0000000000000000000000000000000000000000000000000000000
      00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
      FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
      007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
      7FFFFFFF}
  end
  object lbEMail: TLabel
    Left = 8
    Top = 480
    Width = 195
    Height = 13
    Caption = 'Кода Виктор, e-mail kodavic@rambler.ru'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlue
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object gb1: TGroupBox
    Left = 360
    Top = 8
    Width = 129
    Height = 145
    Caption = 'Состояние мыши'
    TabOrder = 0
    object lbX0: TLabel
      Left = 17
      Top = 24
      Width = 10
      Height = 13
      Caption = 'X:'
    end
    object lbY0: TLabel
      Left = 17
      Top = 40
      Width = 10
      Height = 13
      Caption = 'Y:'
    end
    object lb1: TLabel
      Left = 16
      Top = 64
      Width = 46
      Height = 13
      Caption = 'Кнопка1:'
      Enabled = False
    end
    object lb2: TLabel
      Left = 16
      Top = 80
      Width = 46
      Height = 13
      Caption = 'Кнопка2:'
      Enabled = False
    end
    object lb3: TLabel
      Left = 16
      Top = 96
      Width = 46
      Height = 13
      Caption = 'Кнопка3:'
      Enabled = False
    end
    object lbBtn1: TLabel
      Left = 72
      Top = 64
      Width = 30
      Height = 13
      Caption = 'lbBtn1'
      Enabled = False
    end
    object lbBtn2: TLabel
      Left = 72
      Top = 80
      Width = 30
      Height = 13
      Caption = 'lbBtn2'
      Enabled = False
    end
    object lbBtn3: TLabel
      Left = 72
      Top = 96
      Width = 30
      Height = 13
      Caption = 'lbBtn3'
      Enabled = False
    end
    object lb4: TLabel
      Left = 16
      Top = 112
      Width = 46
      Height = 13
      Caption = 'Кнопка4:'
      Enabled = False
    end
    object lbBtn4: TLabel
      Left = 72
      Top = 112
      Width = 30
      Height = 13
      Caption = 'lbBtn4'
      Enabled = False
    end
    object lbX: TLabel
      Left = 72
      Top = 24
      Width = 6
      Height = 13
      Caption = '0'
    end
    object lbY: TLabel
      Left = 72
      Top = 40
      Width = 6
      Height = 13
      Caption = '0'
    end
  end
end

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

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

2001-2024,   DRKB Powered by yoCMS v.0.9.2, Ex.time: 0.0159s.