十字型のマウスポインターを表示するには？ (ID:35453)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

解決したようですが、最初のアプローチからであれば、問題はShape1,Shape2がWM_MOUSEMOVEを受け取って、Form1に渡されないのが原因ですので、以下のようにすればできます。

private
    { Private 宣言 }
    OldWndProc1: TWndMethod;
    OldWndProc2: TWndMethod;
    procedure Shape1WndProc(var Message: TMessage);
    procedure Shape2WndProc(var Message: TMessage);
    procedure RedirectMouseMove(S: TControl; const Message: TMessage);

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Width  :=1;
  Shape1.Top    :=1;
  Shape1.Height :=ClientHeight - 1;//Heightだとスクロールバーが出る

Shape2.Height :=1;
  Shape2.Left   :=0;
  Shape2.Width  :=ClientWidth - 1;//Widthだとスクロールバーが出る

//WindowProcを保存
  OldWndProc1 := Shape1.WindowProc;
  OldWndProc2 := Shape2.WindowProc;

//新しいWindowProcを設定
  Shape1.WindowProc := Shape1WndProc;
  Shape2.WindowProc := Shape2WndProc;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Label1.Caption :=inttostr(X) +'     ' +inttostr(Y);
  Shape1.Left :=X;
  Shape2.Top  :=Y;
end;

procedure TForm1.Shape1WndProc(var Message: TMessage);
begin
  OldWndProc1(Message);
  Message.Result := 0;
  if Message.Msg = WM_MOUSEMOVE then
  begin
    RedirectMouseMove(Shape1, Message);
  end;
end;

procedure TForm1.Shape2WndProc(var Message: TMessage);
begin
  OldWndProc2(Message);
  Message.Result := 0;
  if Message.Msg = WM_MOUSEMOVE then
  begin
    RedirectMouseMove(Shape2, Message);
  end;
end;

procedure TForm1.RedirectMouseMove(S: TControl; const Message: TMessage);
var
  pc, ps: TPoint;
  m: TWMMouseMove;
begin
  pc.X := TWMMouseMove(Message).XPos;
  pc.Y := TWMMouseMove(Message).YPos;
  //コンポーネント上の位置からスクリーン上の位置へ変換
  ps := S.ClientToScreen(pc);
  //スクリーン上の位置からフォーム上の位置へ変換
  pc := Form1.ScreenToClient(ps);
  m := TWMMouseMove(Message);
  m.XPos := pc.X;
  m.YPos := pc.Y;
  Form1.Perform(WM_MOUSEMOVE, TMessage(m).WParam, TMessage(m).LParam);
end;

←解決時は質問者本人がここをチェックしてください。

戻る