» Delphi » FMX・ビジュアルプログラミング » FMX フォームでクリック/ダブルクリックを判定する。Delphi Forum | Borland / Inprise / CodeGear / Embarcadero Delphi や C++Builder に関する情報交換の場です。ハンドル名で投稿できます。

ゲスト
ようこそゲストさん。このフォーラムに投稿するには登録が必要です。ユーザ名: パスワード: ログイン情報を保存

Forum » Delphi » FMX・ビジュアルプログラミング » FMX フォームでクリック/ダブルクリックを判定する。

ページ: [1]

	トピック: FMX フォームでクリック/ダブルクリックを判定する。

DEKO

管理者
投稿数: 2691

FMX フォームでクリック/ダブルクリックを判定する。
on: 2013/10/31 01:16 Thu

以下に示すユニットに定義された TBaseFormHD / TBaseForm3D いずれかからフォームを継承すると、フォームの OnClick / OnDblClick が使えるようになります。クリックとダブルクリックのイベントを同時に指定してもちゃんと判定されます。

Windows / OS X で動作する。
OnDblClick イベントハンドラが割り当てられている場合: ダブルクリックは 2 回目の MouseUp により最短で検出される。ダブルクリック時間終了を待たない。シングルクリックはダブルクリック時間経過後に検出される。
OnDblClick イベントハンドラが割り当てられていない場合: シングルクリックは初回の MouseUp により最短で検出される。ダブルクリック時間終了を待たない。
マウスカーソルがコントロールの上にある場合には OnClick / OnDblClick イベントは発生しない。
シングルクリックキャンセルが可能。

TTimer 版と GetTick 版がありますが、どちらも動作に変わりはないのでお好みでお選び下さい。

[FMX.BaseForm.pas (TTimer 版)]

// -----------------------------------------------------------------------------
// OnClick / OnDblClick を備えたベースフォーム
// TTimer 版
// -----------------------------------------------------------------------------
unit FMX.BaseForm;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  {$IFDEF MSWINDOWS}
  Winapi.Windows,
  {$ENDIF}
  {$IFDEF MACOS}
  MacAPI.Foundation, MacAPI.AppKit,
  {$ENDIF}
  FMX.Types, FMX.Forms;

type
  { TBaseFormHD }
  TBaseFormHD = class(TForm)
    procedure Timer_Timer(Sender: TObject);
  private
    { private 宣言 }
    FTimer: TTimer;
    FStartPoint: TPointF;
    FIntervalOver: Boolean;
    FIsMouseUp: Boolean;
    FMouseClickEvent: TNotifyEvent;
    FMouseDblClickEvent: TNotifyEvent;
    function IsMouseOnControl(X, Y: Single): Boolean;
    procedure GenerateClickEvent;
  public
    { public 宣言 }
    constructor Create(AOwner: TComponent); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  published
    { published 宣言 }
    property OnClick: TNotifyEvent read FMouseClickEvent write FMouseClickEvent;
    property OnDblClick: TNotifyEvent read FMouseDblClickEvent write FMouseDblClickEvent;
  end;

  { TBaseForm3D }
  TBaseForm3D = class(TForm3D)
    procedure Timer_Timer(Sender: TObject);
  private
    { private 宣言 }
    FTimer: TTimer;
    FStartPoint: TPointF;
    FIntervalOver: Boolean;
    FIsMouseUp: Boolean;
    FMouseClickEvent: TNotifyEvent;
    FMouseDblClickEvent: TNotifyEvent;
    function IsMouseOnControl(X, Y: Single): Boolean;
    procedure GenerateClickEvent;
  public
    { public 宣言 }
    constructor Create(AOwner: TComponent); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  published
    { published 宣言 }
    property OnClick: TNotifyEvent read FMouseClickEvent write FMouseClickEvent;
    property OnDblClick: TNotifyEvent read FMouseDblClickEvent write FMouseDblClickEvent;
  end;

const
  CLICK_JUDGE_DIST  =   4; // クリック判定用
  DOUBLE_CLICK_TIME = 500; // ダブルクリック判定時間 (規定)

implementation

function CalcDist(a, b: TPointF): Single;
begin
  result := Sqrt(Sqr(a.X - b.X) + Sqr(a.Y - b.Y));
end;

{ TBaseFormHD }

constructor TBaseFormHD.Create(AOwner: TComponent);
begin
  inherited;
  FTimer := TTimer.Create(Self);
  FTimer.Enabled  := False;

  FTimer.Interval := DOUBLE_CLICK_TIME;
  {$IFDEF MSWINDOWS}
  FTimer.Interval := GetDoubleClickTime;
  {$ENDIF}
  {$IFDEF MACOS}
  // OSX 用の処理
  {$ENDIF}

  FTimer.OnTimer  := Timer_Timer;
end;

procedure TBaseFormHD.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft)  then
      begin
        if (ssDouble in Shift) then
          begin
            FTimer.Enabled  := False;
            if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
              if Assigned(FMouseDblClickEvent) then
                OnDblClick(Self);
          end
        else
          begin
            FStartPoint := PointF(X, Y);
            if Assigned(FMouseDblClickEvent) then
              begin
                FIntervalOver  := False;
                FIsMouseUp     := False;
                FTimer.Enabled := True;
              end;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseFormHD.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
          begin
            if (not Assigned(FMouseDblClickEvent)) or FIntervalOver then
              GenerateClickEvent
            else
              FIsMouseUp := True;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseFormHD.Timer_Timer(Sender: TObject);
begin
  FIntervalOver := True;
  FTimer.Enabled  := False;
  if FIsMouseUp then
    GenerateClickEvent;
end;

function TBaseFormHD.IsMouseOnControl(X, Y: Single): Boolean;
begin
  result := (IControl(ObjectAtPoint(ClientToScreen(PointF(X, Y)))) <> nil);
  if result then
    FTimer.Enabled  := False;
end;

procedure TBaseFormHD.GenerateClickEvent;
begin
  FIntervalOver := False;
  FTimer.Enabled  := False;
  if Assigned(FMouseClickEvent) then
    OnClick(Self);
end;

{ TBaseForm3D }

constructor TBaseForm3D.Create(AOwner: TComponent);
begin
  inherited;
  FTimer := TTimer.Create(Self);
  FTimer.Enabled  := False;

  FTimer.Interval := DOUBLE_CLICK_TIME;
  {$IFDEF MSWINDOWS}
  FTimer.Interval := GetDoubleClickTime;
  {$ENDIF}
  {$IFDEF MACOS}
  // OSX 用の処理
  {$ENDIF}

  FTimer.OnTimer  := Timer_Timer;
end;

procedure TBaseForm3D.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft)  then
      begin
        if (ssDouble in Shift) then
          begin
            FTimer.Enabled  := False;
            if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
              if Assigned(FMouseDblClickEvent) then
                OnDblClick(Self);
          end
        else
          begin
            FStartPoint := PointF(X, Y);
            if Assigned(FMouseDblClickEvent) then
              begin
                FIntervalOver  := False;
                FIsMouseUp     := False;
                FTimer.Enabled := True;
              end;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseForm3D.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
          begin
            if (not Assigned(FMouseDblClickEvent)) or FIntervalOver then
              GenerateClickEvent
            else
              FIsMouseUp := True;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseForm3D.Timer_Timer(Sender: TObject);
begin
  FIntervalOver := True;
  FTimer.Enabled  := False;
  if FIsMouseUp then
    GenerateClickEvent;
end;

function TBaseForm3D.IsMouseOnControl(X, Y: Single): Boolean;
begin
  result := (IControl(ObjectAtPoint(ClientToScreen(PointF(X, Y)))) <> nil);
  if result then
    FTimer.Enabled  := False;
end;

procedure TBaseForm3D.GenerateClickEvent;
begin
  FIntervalOver := False;
  FTimer.Enabled  := False;
  if Assigned(FMouseClickEvent) then
    OnClick(Self);
end;
end.

[FMX.BaseForm.pas (GetTick 版)]

// -----------------------------------------------------------------------------
// OnClick / OnDblClick を備えたベースフォーム
// GetTick 版
// -----------------------------------------------------------------------------
unit FMX.BaseForm;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  {$IFDEF MSWINDOWS}
  Winapi.Windows,
  {$ENDIF}
  {$IFDEF MACOS}
  MacAPI.Foundation, MacAPI.AppKit,
  {$ENDIF}
  FMX.Types, FMX.Forms, FMX.Platform;

type
  { TBaseFormHD }
  TBaseFormHD = class(TForm)
  private
    { private 宣言 }
    FDoubleClickTime: Extended;
    FStartPoint: TPointF;
    FStartTime: Extended;
    FDoubleClicked: Boolean;
    FMouseClickEvent: TNotifyEvent;
    FMouseDblClickEvent: TNotifyEvent;
    FIsMouseUp: Boolean;
    FIntervalOver: Boolean;
    function IsMouseOnControl(X, Y: Single): Boolean;
    procedure GenerateClickEvent;
  public
    { public 宣言 }
    constructor Create(AOwner: TComponent); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  published
    { published 宣言 }
    property OnClick: TNotifyEvent read FMouseClickEvent write FMouseClickEvent;
    property OnDblClick: TNotifyEvent read FMouseDblClickEvent write FMouseDblClickEvent;
  end;

  { TBaseForm3D }
  TBaseForm3D = class(TForm3D)
  private
    { private 宣言 }
    FDoubleClickTime: Extended;
    FStartPoint: TPointF;
    FStartTime: Extended;
    FDoubleClicked: Boolean;
    FMouseClickEvent: TNotifyEvent;
    FMouseDblClickEvent: TNotifyEvent;
    FIsMouseUp: Boolean;
    FIntervalOver: Boolean;
    function IsMouseOnControl(X, Y: Single): Boolean;
    procedure GenerateClickEvent;
  public
    { public 宣言 }
    constructor Create(AOwner: TComponent); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  published
    { published 宣言 }
    property OnClick: TNotifyEvent read FMouseClickEvent write FMouseClickEvent;
    property OnDblClick: TNotifyEvent read FMouseDblClickEvent write FMouseDblClickEvent;
  end;

const
  CLICK_JUDGE_DIST  =   4; // クリック判定用
  DOUBLE_CLICK_TIME = 500; // ダブルクリック判定時間 (規定)

implementation

function Get_Tick: Extended;
{$IF FireMonkeyVersion >= 17.0}
begin
  result := IFMXTimerService(TPlatformServices.Current.GetPlatformService(IFMXTimerService)).GetTick;
end;
{$ELSE}
begin
  result := Platform.GetTick;
end;
{$IFEND}

function CalcDist(a, b: TPointF): Single;
begin
  result := Sqrt(Sqr(a.X - b.X) + Sqr(a.Y - b.Y));
end;

{ TBaseFormHD }

constructor TBaseFormHD.Create(AOwner: TComponent);
begin
  inherited;
  FDoubleClickTime := DOUBLE_CLICK_TIME  / 1000;
  {$IFDEF MSWINDOWS}
  FDoubleClickTime := GetDoubleClickTime / 1000;
  {$ENDIF}
  {$IFDEF MACOS}
  // OSX 用の処理
  {$ENDIF}
end;

procedure TBaseFormHD.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if (ssDouble in Shift) then
          begin
            FDoubleClicked := True;
            if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
              if Assigned(FMouseDblClickEvent) then
                OnDblClick(Self);
          end
        else
          begin
            FStartPoint    := PointF(X, Y);
            FStartTime     := Get_Tick;
            FDoubleClicked := False;
            FIsMouseUp     := False;
            FIntervalOver  := False;
            while ((Get_Tick - FStartTime) < FDoubleClickTime) do
              begin
                Application.ProcessMessages;
                if FDoubleClicked then
                  Exit;
              end;
            FIntervalOver := not FDoubleClicked;
            if FIsMouseUp then
              GenerateClickEvent;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseFormHD.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
          begin
            if (not Assigned(FMouseDblClickEvent)) or FIntervalOver then
              GenerateClickEvent
            else
              FIsMouseUp := True;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseFormHD.GenerateClickEvent;
begin
  FDoubleClicked := False;
  if Assigned(FMouseClickEvent) then
    OnClick(Self);
end;

function TBaseFormHD.IsMouseOnControl(X, Y: Single): Boolean;
begin
  result := (IControl(ObjectAtPoint(ClientToScreen(PointF(X, Y)))) <> nil);
end;

{ TBaseForm3D }

constructor TBaseForm3D.Create(AOwner: TComponent);
begin
  inherited;
  FDoubleClickTime := DOUBLE_CLICK_TIME  / 1000;
  {$IFDEF MSWINDOWS}
  FDoubleClickTime := GetDoubleClickTime / 1000;
  {$ENDIF}
  {$IFDEF MACOS}
  // OSX 用の処理
  {$ENDIF}
end;

procedure TBaseForm3D.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if (ssDouble in Shift) then
          begin
            FDoubleClicked := True;
            if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
              if Assigned(FMouseDblClickEvent) then
                OnDblClick(Self);
          end
        else
          begin
            FStartPoint    := PointF(X, Y);
            FStartTime     := Get_Tick;
            FDoubleClicked := False;
            FIsMouseUp     := False;
            FIntervalOver  := False;
            while ((Get_Tick - FStartTime) < FDoubleClickTime) do
              begin
                Application.ProcessMessages;
                if FDoubleClicked then
                  Exit;
              end;
            FIntervalOver := not FDoubleClicked;
            if FIsMouseUp then
              GenerateClickEvent;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseForm3D.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  try
    if not (Assigned(FMouseClickEvent) or Assigned(FMouseDblClickEvent)) then
      Exit;
    if IsMouseOnControl(X, Y) then
      Exit;
    if (Button = TMouseButton.mbLeft) then
      begin
        if CalcDist(FStartPoint, PointF(X, Y)) < CLICK_JUDGE_DIST then
          begin
            if (not Assigned(FMouseDblClickEvent)) or FIntervalOver then
              GenerateClickEvent
            else
              FIsMouseUp := True;
          end;
      end;
  finally
    inherited;
  end;
end;

procedure TBaseForm3D.GenerateClickEvent;
begin
  FDoubleClicked := False;
  if Assigned(FMouseClickEvent) then
    OnClick(Self);
end;

function TBaseForm3D.IsMouseOnControl(X, Y: Single): Boolean;
begin
  result := (IControl(ObjectAtPoint(ClientToScreen(PointF(X, Y)))) <> nil);
end;
end.

　
使い方は以下のようになります。

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Platform, FMX.BaseForm;

type
  TForm1 = class(TBaseFormHD)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Form1Click(Sender: TObject);
    procedure Form1DblClick(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  OnClick    := Form1Click;    // クリックイベントをアサイン
  OnDblClick := Form1DblClick; // ダブルクリックイベントをアサイン
end;

procedure TForm1.Form1Click(Sender: TObject);
begin
  ShowMessage('Clicked!');
end;

procedure TForm1.Form1DblClick(Sender: TObject);
begin
  ShowMessage('Double Clicked!');
end;

end.

　
コードは FireMonkey HD 用なので TBaseFormHD を継承していますが、FireMonkey 3D を使うときは TBaseForm3D を継承して下さい。OS ネイティブのイベントを用いない "擬似クリック / ダブルクリック" イベントですが、それっぽい動きはすると思います。

ページ: [1]

WP Forum Server by ForumPress | LucidCrew
バージョン: 1.7.5 ; ページロード: 0.055 sec.

ゲスト