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

解決

祐一 2009-08-20 00:20:44 No: 35447

現在仕掛かってる仕事で十字型のマウスポインターを表示する仕組みがどうしても必要になりました。出来なくて困っています。
そこで質問です。

質問１...Cursor(マウスポインター)で独自のユーティリティーを掲載してるサイトをご存知でしょうか？あったらお教え下さい。

質問２...現状で独自のマウスポインターが作れないのでフォーム内に以下のプログラムを作成しています。OnMouseMoveイベントでShapeコンポーネントを２個移動させていますが線が反応するのにムラが生じてしまいます。（Shapeコンポーネント１個ですと上手く反応します）。タイムリーに反応させる方法をお教え下さい。宜しくお願いします。

「作成手順」...フォーム内にShapeコンポーネントを２個、Labelコンポーネントを１個置きます。（Shape1が縦線、Shape2が横線です）

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Width  :=1;
  Shape1.Top    :=1;
  Shape1.Height :=Height;

  Shape2.Height :=1;
  Shape2.Left   :=0;
  Shape2.Width  :=Width;
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;

窓の中のねずみ 2009-08-20 00:41:56 No: 35448

ん？ CursorプロパティをcrCrossにするだけ。

祐一 2009-08-20 01:39:37 No: 35449

窓の中のねずみさん、マウスポインターの縦がフォームのHeightで横がWidthになる大きな十字型になります。crCrossですと小さすぎてしまいます。説明不足ですみません。

ナンプ 2009-08-20 02:04:22 No: 35450

恐らく、マウスがShapeの上にあるときにFormのMouseMoveイベントが起きないからではないですか？

良い方法かわかりませんが、Formと同じ大きさのImageをFormに置いて、ImageのMouseMoveイベントでShapeを移動させるというのはどうでしょう？

3K 2009-08-20 02:22:57 No: 35451

1) マウスの位置を調べる。
2) その位置に縦の線と横の線を描く。
3) マウスを移動
4) 2で書いた線を消す。

上記の繰り返しで多分やりたいことが出来るのでは？

参考HP
https://www.petitmonte.com/bbs/answers?question_id=6131

祐一 2009-08-20 05:58:40 No: 35452

皆さん有難うございました！！Timer関数を使いなんとか解決出来ました。

にしの 2009-08-20 06:13:15 No: 35453

解決したようですが、最初のアプローチからであれば、問題は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;

にしの 2009-08-20 06:21:30 No: 35454

２カ所修正と追記です。

Message.Result := 0;
の場所は、if 〜 thenの中の方がよかったかも。
TShapeではエラーが起きませんでしたが、TEditを配置したらエラーになりました。
追記として、ほかのコントロールがあった場合にも、それらのコントロールの上を通過するときWM_MOUSEMOVEがForm1に渡されないので同じようにする必要があります。

OldWndProc3 := Edit1.WindowProc;
Edit1.WindowProc := Edit1WndProc;

としておき、

procedure TForm1.Edit1WndProc(var Message: TMessage);
begin
  OldWndProc3(Message);
  if Message.Msg = WM_MOUSEMOVE then
  begin
    Message.Result := 0;
    RedirectMouseMove(Edit1, Message);
  end;
end;

でOK。

４OZ レベルライン 2009-08-20 20:08:20 No: 35455

Ｄ７ですが、Image Editor で自分の思うようなカーソルを作成し、.resに入れ、Const でカーソルの定義を行い、

const
crMyCursor_001 = 1;

FormCreate(Sender: TObject);
begin
  ***
  ***
  LoadScreenCursor(crMyCursor_001,'Cursor_001');

  と指定した上で、必要なコンポーネントの

MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
で Screen.Cursor := 1; とすれば、いかがでしょうか。

以下は釣りの仕掛け図を描くための一部ですが、
こまごましている釣り部品をデフォルメした計上のカーソルを独自に作成して試用しています。

var
Form_Main: TForm_Main;

  { カーソルの定義}
  const
   crMyCursor_001  = 1;
   crMyCursor_002  = 2;
   crMyCursor_003  = 3;

implementation

{$R *.dfm}
{$R My_Cursor.res}

procedure LoadScreenCursor(index:Integer;Name:string);
begin
    Screen.Cursors[index] := LoadCursor(HInstance, pChar(Name));
    if Screen.Cursors[index]=0 then
        raise Exception.Create('Can not load the cursor ['+Name+']');
end;

//初期設定
procedure TForm_Main.FormCreate(Sender: TObject);
begin
  LoadScreenCursor(crMyCursor_001,'Cursor_001');
  LoadScreenCursor(crMyCursor_002,'Cursor_002');
  LoadScreenCursor(crMyCursor_003,'Cursor_003');
end;

//表題にマウスが入ったら
procedure TForm_Main.Panel2MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
Screen.Cursor := 0;
end;

procedure TForm_Main.Cursor_Select();
begin
  case Btn_Flg of
    0:begin  Screen.Cursor :=  0;  end;
    1:begin  Screen.Cursor :=  1;  end ;
    2:begin  Screen.Cursor :=  2;  end ;
    3:begin  Screen.Cursor :=  3;  end ;
  else
    begin
      Screen.Cursor := 0;
    end;
  end;
end;

趣旨と違っていればごめんなさい。