Delphi Fmx Edit+SpinEditButtonで長押しが効かない

久々にWindowsでDelphiのお仕事があったのですが、

仕様書ちょっとボタンの色が青だったので、いいやFmxでって作って

SpinEdit痛い目にあったので、対応方法含めまとめてみました。

1.VCLでの動作

まずVclで確認です。

ってVCLでまぁ長押しで連続UP/DOWNはできているのですが、なぜ、押してすぐに±１しないってバグ？というか仕様といかという部分はありますが、動画のように連続UP/DOWNできます。

2.FMXでの確認

FMXで動かすSpinEditButtonのイベントはOnUpClickかOnDownClickしかありません。
しかも、離した時に動作します。
（これでは外から押されたときに処理を開始、
離されたらやめるということもできません。）
以下動画

変更のタイミング、この長押し（連続押し）対応言われたの
ほぼユーザーの確認が終わって最後の変更時に言われたので超絶焦りました。
ってかC#だと簡単にできているので、Delphiでもできると思い込んでいた（笑）。
（やっぱ事前確認は必要だね。)

2.対応策の検討

ひとつ前の動画をみればわかりますが、現状離されたら処理になっています。

こんな感じで処理がされています。

希望のタイミング

押されたとき+1、500ms以上の長押し時 100ms/stepでup/downする。

対応するとこうなります。

ってことでめでたしめでたしでした。

対応コード

FMX.Edit.pasを以下の赤色の部分を追加もしくは変更してください。

TSpinEditButton = class(TStyledControl, IEditControl)
strict private
    FUpButton: TCustomButton;
    FDownButton: TCustomButton;
    { Events }
    FOnUpClick: TNotifyEvent;
    FOnDownClick: TNotifyEvent;
    FLongPushTimer: TTimer;
protected
    { Style }
    procedure ApplyStyle; override;
    procedure FreeStyle; override;
    function GetDefaultStyleLookupName: string; override;
    function GetDefaultSize: TSizeF; override;
    { Events }
// procedure DoUpButtonClick(Sender: TObject);
// procedure DoDownButtonClick(Sender: TObject);
    procedure LongPushTimerFired(Sender: TObject);
    procedure DoUpMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure DoDownMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure DoUpMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure DoDownMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    { IEditControl }

{ TSpinEditButton }

procedure TSpinEditButton.ApplyStyle;
begin
inherited ApplyStyle;

   FLongPushTimer := TTimer.Create(Self);
   FLongPushTimer.Interval := 100;
   FLongPushTimer.OnTimer := LongPushTimerFired;
   FLongPushTimer.Enabled := False;
   FLongPushTimer.Tag      := 0;

if FindStyleResource<TCustomButton>('upbutton', FUpButton) then
begin
    FUpButton.TouchTargetExpansion.Bottom := 0;
//    FUpButton.OnClick     := DoUpButtonClick;
    FUpButton.OnMouseDown := DoUpMousedown;
    FUpButton.OnMouseUp   := DoUpMouseUp;
end;
if FindStyleResource<TCustomButton>('downbutton', FDownButton) then
begin
    FDownButton.TouchTargetExpansion.Top := 0;
///     FDownButton.OnClick     := DoDownButtonClick;
    FDownButton.OnMouseDown := DoDownMousedown;
    FDownButton.OnMouseUp   := DoDownMouseUp;
end;
end;

procedure TSpinEditButton.LongPushTimerFired(Sender: TObject);
begin
if( FLongPushTimer.tag = $10) then
begin {up 方向連続押し}
   if Assigned(FOnUpClick) then
      FOnUpClick(Self);
end
else
if( FLongPushTimer.tag = $20) then
begin {up 方向連続押し}
   if Assigned(FOnDownClick) then
      FOnDownClick(Self);
end
else
if( FLongPushTimer.tag and $0f <> 0) then
begin
    FLongPushTimer.tag := Round(FLongPushTimer.tag.ToSingle-1);
end;
end;

procedure TSpinEditButton.DoUpMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
FLongPushTimer.Enabled := true;
FLongPushTimer.Tag      := $15;
if Assigned(FOnUpClick) then
    FOnUpClick(Self);
end;

procedure TSpinEditButton.DoDownMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
FLongPushTimer.Enabled := true;
FLongPushTimer.Tag      := $25;
if Assigned(FOnDownClick) then
    FOnDownClick(Self);
end;

procedure TSpinEditButton.DoUpMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
FLongPushTimer.Enabled := false;
FLongPushTimer.Tag      := $00;
end;

procedure TSpinEditButton.DoDownMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
FLongPushTimer.Enabled := false;
FLongPushTimer.Tag      := $00
end;

procedure TSpinEditButton.FreeStyle;
begin
if(FUpButton <> nil ) then FUpButton.OnMouseDown := Nil;
if(FUpButton <> nil ) then FUpButton.OnMouseUp   := Nil;
if(FDownButton <> nil ) then FDownButton.OnMouseDown := Nil;
if(FDownButton <> nil ) then FDownButton.OnMouseUp   := Nil;
if(FLongPushTimer <> Nil) then FLongPushTimer.DisposeOf();

if FUpButton <> nil then
FUpButton.OnClick := nil;
FUpButton := nil;
if FDownButton <> nil then
FDownButton.OnClick := nil;
FDownButton := nil;

FOnUpClick := nil;
FOnDownClick:= nil;
inherited FreeStyle;
end;

以上

やましょうでした。

Blog Yamasho

2020年9月10日木曜日