コンポーネント内でマウスホイールのイベントに対応したいのですが

解決

PMAN 2010-06-10 00:28:48 No: 38642

既存のコンポーネントを継承して新たにマウスホイールに対応するコンポーネントを作ろうとしてるのですがイベントがうまく拾えません。
publishedにプロパティを追加するだけではだめなのでしょうか?

type
  TPaintBoxB = class(TPaintBox)
  private
  protected
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  published
    //追加
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

上記でオブジェクトインスペクタにはイベントは追加されてるですがホイールを回してもイベントが起きません。
よろしくお願いします。

take 2010-06-10 18:11:07 No: 38643

そのソースをコンパイルすると
「OnMouseWheel」は基本クラスに存在しませんっていうエラー出てますけど？

で、やりたいのはこういうこと？

interface

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

type
  TPaintBoxB = class(TPaintBox)
  private
  protected
  public
    procedure WMMousewheel(var Msg: TMessage); message WM_MOUSEWHEEL;
  published
   //追加
  end;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    FPaintBox : TPaintBoxB;
  public
    { Public 宣言 }
  end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FPaintBox := TPaintBoxB.Create(Self);
  FPaintBox.Parent := Self;
  FPaintBox.Align := alClient;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
FPaintBox.Free;
end;

procedure TPaintBoxB.WMMousewheel(var Msg: TMessage);
begin
  if (Msg.WParam > 0) then
  begin
    { ホイールを奥に動かした時の処理 }
    ShowMessage('ホイールが奥に動いた');
  end
  else
  begin
    { ホイールを手前に動かした時の処理 }
    ShowMessage('ホイールが手前に動いた');
  end;
end;

PMAN 2010-06-12 04:04:10 No: 38644

takeさん、御世話になります。

>OnMouseWheel」は基本クラスに存在しませんっていうエラー出てますけど？
こちらではコンパイルできます。
ちなみに動作環境はdel2010でWin7上です。
試しにdel7でも試したのですがエラーはでませんでした。
OnMouseWheelはaintBox<-TGraphicControl<-TControl<-TComponentのprotectedに定義されてましたのですがpublishedにするだけでは駄目なのでしょうか?

作りたいコンポーネントはコンポーネント内でホイールの回転を感知して図形の拡大、縮小を行いたいのです。

参考ソースを試してみましたが、原点がディスプレイの左上となってるのか、フォーム内で回転させても、右下あたりでは感知してくれません。
(ディスプレイの左上では大丈夫です。)
感知する範囲はフォームのサイズになってるみたいです。
補正するにはどうしたらいいのでしょうか?

Mr.XRAY 2010-06-12 21:48:07 No: 38645

こんにちは．

WM_MOUSEWHEELとか，マウスホイール関係のメッセージは，過去の記事(この掲示板だけでなく)
いろいろ問題があるようです．
これは，その環境にもよるようです．マウス添付のドライバーのインストールの有無とか．

マウスホイール関係の処理は，私の場合，コンポーネント内部ではなく，
アプリケーション側で処理するようにしています．

TApplicationのOnMessageイベントハンドラを作成
メッセージ内で座標値を取得し，その座標値に応じた処理コードを書く

TApplicationは，Delphiのバージョンによっては，コンポーネントがあります．
「コンポーネント内でマウスホイールのイベントに」
ということにはなりませんが，目的の動作ができないことには始まりませんので．

Mr.XRAY 2010-06-12 21:55:29 No: 38646

間違えました．
TApplication ---> TApplicationEvents
です．

..としたら 2010-06-13 02:52:23 No: 38647

>参考ソースを試してみましたが、原点がディスプレイの左上となってるのか、フォーム内で回転させても、右下あたりでは感知してくれません。

MouseWheelメッセージはフォーカスがあるコントロールに来るので、
Panelの上にPaintBoxを乗せたコンポを作るのもありかも。

PMAN 2010-06-14 00:41:50 No: 38648

Mr.XRAYさん、ありがとうございます。

私も最終的にはアプリ側で処理さるしかないかなと思っます。
しかしListBoxはスクロールホイルの回転に対応してる(コンポーネント内部での感知ではないですが)ので、その部分を移植してコンポーネント内のみでの反応に改良したらいけそうな気がして現在試行錯誤してる最中です。
しかしソース覗いてもどこでホイールの処理してるのかチンプンカンプンでめげそうですが。

..としたらさんの御指摘ですが

>MouseWheelメッセージはフォーカスがあるコントロールに来るので、

今も確かに来てるのですが、感知する矩形範囲の始点がアクティブフォームの左上でなくディスプレイの左上となってしまってて悩んでいます。

もう少し頑張ってみたいと思ってますので皆さんの意見もよろしくお願い致します。

ズレてる？…だったら 2010-06-16 02:44:25 No: 38649

真琴：「そろそろ梅雨入りが近いかも、ねぇ、おじいちゃん」
勝爺：「そうだな、オレのカンではたぶん来週あたり…、今のうちに屋根の修理しておくか」
真琴：「えっ、おじいちゃんが？落ちたりしたら大変だから、業者さんに頼んだ方がイイんじゃない？」
勝爺：「なぁに大丈夫だよ、気をつけてやるから」
真琴：「ホントに？やっぱり心配だなぁ」
裕子：「こんにちは〜、あれ？何が始まるの？」
勝爺：「おぅユウコ、お前は何時もタイミングいいな、マコトと一緒に下でこのハシゴをおさえてくれ」
裕子：「え〜？マサルさんがハシゴで屋根に登るの？アタシの上には落ちてこないでよ？^^;」

【パネルの上にPaintBoxを乗せたTPaintPanelコンポ】
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ThemeMgr;

type
  TPaintPanel = class;
  TPaintBox = class(ExtCtrls.TPaintBox)
  private
   FPaintPanel: TPaintPanel;
   procedure WMLButtonDown(var Msg: TMessage); message WM_LBUTTONDOWN;
   procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
  end;

  TPaintPanel = class(TPanel)
  private
   FPaintBox: TPaintBox;
   FOnMouseWheel: TMouseWheelEvent;
   procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
  public
   procedure SetParent(aParent: TWinControl); override;
  published
   property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel;
  end;

type
  TForm1 = class(TForm)
   Memo1: TMemo;
   ThemeManager1: TThemeManager;
   procedure FormCreate(Sender: TObject);
  private
   FSize: Integer;
   PaintPanel1: TPaintPanel;
   procedure PaintPanel1MouseWheel(Sender: TObject; Shift: TShiftState;
     WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TPaintPanel.SetParent(aParent: TWinControl);
begin
  inherited;
  if aParent = nil then exit;
  // PaintPanelの内部いっぱいにPaintBoxを作成
  FPaintBox := TPaintBox.Create(Self);
  FPaintBox.FPaintPanel := Self;
  FPaintBox.Parent := Self;
  FPaintBox.Align := alClient;
//Self.ParentBackground := False;  // D6以降でXPManを使う場合に必要？
end;

procedure TPaintBox.WMLButtonDown(var Msg: TMessage);
begin
  inherited;
  // PaintBox上でマウスの左ボタンを押したら親のPaintPanelにFocusをセット
  Parent.SetFocus;
end;

procedure TPaintBox.WMMouseWheel(var Msg: TWMMouseWheel);
var
  p1, p2: TPoint;
  Handled: Boolean;
begin
  // マウスカーソルがコンポ上にあるか？(スクリーン全体でWheelEventを起こす場合は判定不要)
  P1 := ClientToScreen(Point(Left, Top));
  P2 := ClientToScreen(Point(Left+Width, Top+Height));
  if (Msg.XPos < P1.X)or(Msg.XPos > P2.X) then exit;
  if (Msg.YPos < P1.Y)or(Msg.YPos > P2.Y) then exit;
  // カーソルがコンポ上にあってFocusがあればWheelイベント発生させる
  Handled := False;
  if Assigned(FPaintPanel.FOnMouseWheel) then begin
    FPaintPanel.FOnMouseWheel(FPaintPanel, KeysToShiftState(Msg.Keys), Msg.WheelDelta, ScreenToClient(Point(Msg.XPos,MSG.YPos)), Handled);
    exit;
  end;
  // Handledの戻り値は無視
  // 必要ならここでOnMouseWheelUP、OnMouseWheelDOWNイベントを発生させる
end;

procedure TPaintPanel.WMMouseWheel(var Msg: TWMMouseWheel);
begin
  // 親のPanelに来たメッセージを子のPaintBoxに横流し
  // このコードの追加でマウスカーソルがスクリーン上の何処にあっても感知できる
  FPaintBox.WMMouseWheel(Msg);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Form上にPaintPanelコンポを動的生成
  PaintPanel1 := TPaintPanel.Create(Self);
  PaintPanel1.Parent := Self;
//PaintPanel1.Align := alClient;
  PaintPanel1.Top := 50;
  PaintPanel1.Left := 30;
  PaintPanel1.Width := 400;
  PaintPanel1.Height := 300;
  PaintPanel1.Color := clYellow; // clWhite;
  PaintPanel1.BevelInner := bvNone;
  PaintPanel1.BevelOuter := bvNone;
  PaintPanel1.OnMouseWheel := PaintPanel1MouseWheel;
  FSize := 0;
end;

// コンポのOnMouseWheelイベントハンドラ
procedure TForm1.PaintPanel1MouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
// マウスの各値をMemoに表示
Memo1.Lines.Add(Format('%d：%d：%.8X / %d',[MousePos.X, MousePos.Y, WheelDelta, Integer(ssShift in Shift)]));
// Wheelの回転でPaintBoxに描いた赤い四角形のサイズを拡大／縮小させる
with TPaintPanel(Sender) do begin
  Canvas.Pen.Color := clRed xor Color;
  Canvas.Pen.Mode := pmXOR;
  Canvas.PolyLine([Point(0, 0), Point(0, FSize), Point(Fsize, FSize), Point(FSize, 0), Point(0, 0)]);
  if (WheelDelta > 0) then begin   // ホイールを奥に動かした時
   if FSize > 0 then dec(FSize);
  end else begin                   // ホイールを手前に動かした時
   inc(FSize);
  end;
  Canvas.PolyLine([Point(0, 0), Point(0, FSize), Point(Fsize, FSize), Point(FSize, 0), Point(0, 0)]);
end;
end;

勝爺：「ご苦労さん、まぁこれで雨漏りはしないだろぅ、ん？ナンだ？差し出したその手は」
裕子：「バイト代の請求、…アタシも屋根の上に登らされて手伝わされたンだから、当然でしょ？」
勝爺：「それならな、後で、美味しい夕食をごちそうしてやるから…」
裕子：「ホント^^？」
勝爺：「それがバイト代のかわりだぞ」
裕子：「う〜ん、もう…いつもこんなカンジで丸め込まれちゃうんだから〜」
真琴：「ねぇ、おじいちゃん、雨漏りの原因はナンだったの？」
勝爺：「屋根のスレートのパネルがズレて隙間ができてたんだ、この前の強風のせいだろう」
真琴：「そのズレ直せたの？じゃぁもう大丈夫ね？二人ともケガしなくて良かった^^」
裕子：「屋根の上でマサルさんが危うく落ちそうになったのよ、それを助けてあげたンだから感謝してもらわないと…」
真琴：「そんな危ないコトが？ユウコ、ありがとう、…アタシも発生場所のズレを直してコンポ内のドコでもWheelイベントの感知が出来るようになったのよ」
裕子：「え？ナンの話？」
真琴：「ハルコさんだったら、もっと良いやり方するかもしれないけど、アタシはこれが精一杯」
裕子：「マコト、ノンキ過ぎ、ハルコさんの心配はしないの？もう捜索願い出した方がイイんじゃない？」
真琴：「大丈夫、ハルコさんがドコに居るかは分かってるのよ、でも、いつコッチに帰るのかは…^^;」

いけ 2010-06-17 04:34:20 No: 38650

綺麗じゃないけど、こんな感じでどう？

まずは、コンポーネント。
type
  TpaintBoxB = class(TPaintBox)
  private
    { Private 宣言 }
  protected
    { Protected 宣言 }
  public
    { Public 宣言 }
    procedure MouseWheelHandler(var Message: TMessage); override;
  published
    { Published 宣言 }
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
  end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TpaintBoxB]);
end;

{ TpaintBoxB }

procedure TpaintBoxB.MouseWheelHandler(var Message: TMessage);
var
  ClientPos: TPoint;
begin
  with TCMMouseWheel(Message) do
  begin
    ClientPos := ScreenToClient(SmallPointToPoint(Pos));
    if (0 <= ClientPos.X) and (ClientPos.X <= Self.Width ) and
       (0 <= ClientPos.Y) and (ClientPos.Y <= Self.Height) then
    begin
      Result := 0;
      if DoMouseWheel(ShiftState, WheelDelta, SmallPointToPoint(Pos)) then
        Message.Result := 1
      else if Assigned(Parent) then
        with TMessage(Message) do
          Result := Parent.Perform(CM_MOUSEWHEEL, WParam, LParam);
    end;
  end;
end;

end.

本当はコンポーネントだけで済ませたかったけど
メッセージが飛んでこない？から、こんな感じで画面を作る。
type
  TForm1 = class(TForm)
    paintBoxB1: TpaintBoxB;
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    procedure MouseWheelHandler(var Message: TMessage); override;
  end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.MouseWheelHandler(var Message: TMessage);
begin
paintBoxB1.MouseWheelHandler(Message);
inherited;
end;

多分TpaintBoxBのメッセージを受ける位置がずれている。
調査したら分かるかもしれないけど、分かってもTpaintBoxB
コンポーネントだけで解決できるか微妙かも？

PMAN 2010-06-20 00:22:06 No: 38651

ズレてる？…だったらさんいけさんありがとうございます。

ズレてる？…だったらさんの
【パネルの上にPaintBoxを乗せたTPaintPanelコンポ】
でなんとかなりそうです。

当初の疑問「publishedにプロパティを追加するだけではだめなのでしょうか?」は残ったままでが、ひとまずコンポ化ができそうです。
なので、解決と致します。

又分からないときはみなさんよろしくお願いします。