--------  キリトリ  -------------------------------------------------
unit HintDrag;

{********************************************************************

ドラッグ時にヒント表示を行い、メッセージ処理を自由に行うためのユニット

※注意
BeginHintDrag で開始したドラッグを中断させる場合は、CancelHintDrag
あるいは EndHintDrag を使用する。ドラッグしているかどうかの判別には
HintDragging を使用する。OnStartDrag イベントハンドラで、新しいドラッ
グオブジェクトを生成する場合は、THintDragObject から派生したものにする。

※使用例
uses
  HintDrag;

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Index: Integer;
begin
  Index := ListBox1.ItemAtPos(Point(X, Y), True);
  if (Index >= 0) and (Button = mbLeft) then
    BeginHintDrag(ListBox1, False, ListBox1.Items[Index]);
end;

※メッセージ処理について
マウスメッセージは THintDragObject.MouseMsg で処理する。
キーメッセージは、TDragHintWindow.WMKeyDown で処理する。

キーメッセージを処理するためには、ヒントウィンドに Parent 設定と
SetFocus 処理が必要なので、メインフォームのフォーカスは失われる。
ドラッグ対象コントロールにスクロールメッセージなどを送る場合には
メインフォームにちらつきが出て見苦しい。

キーメッセージの処理は対象コンポーネントの WndProc を override
することを推奨する。

例
type
  TMyListBox = class(TListBox)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

implementation

uses
  HintDrag;

procedure TMyListBox.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_KEYDOWN then
    if (TWMKey(Message).CharCode = VK_ESCAPE) and
      HintDragging(Self) then
      CancelHintDrag;
  inherited WndProc(Message);
end;

※コンパイル指令

したがって、このユニットでは、デフォルトでキーメッセージを処理しない
仕様になっている。
キーメッセージの処理を行う場合は、$UNDEF KEYMESSAGE の行を削除
すること
*********************************************************************}

{$DEFINE KEYMESSAGE}
{$UNDEF KEYMESSAGE}

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms;

type
  THintDragObject = class(TDragControlObject)
  protected
    function Capture: HWND; virtual;
    procedure ReleaseCapture(Handle: HWND); virtual;
    procedure MouseMsg(var Message: TMessage); virtual;
  end;

  TDragHintWindow = class(THintWindow)
  private
    {$IFDEF KEYMESSAGE}
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    {$ENDIF}
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    {$IFDEF VER90}
    function CalcHintRect(const AHint: string): TRect;
    {$ENDIF}
    procedure ShowDragHint; virtual;
    procedure HideDragHint; virtual;
  end;

procedure BeginHintDrag(Control: TControl; Immediate: Boolean;
    HintText: String);
procedure EndHintDrag(Control: TControl; Drop: Boolean);
function HintDragging(Control: TControl): Boolean;
procedure CancelHintDrag;

implementation

uses
  Consts;

var
  DragHintWindow: TDragHintWindow;
  HintDragControl: TControl;
  HintDragObject: TDragObject;
  HintDragFreeObject: Boolean;
  HintDragTarget: Pointer;
  HintDragHandle: HWND;
  HintDragCapture: HWND;
  HintDragStartPos: TPoint;
  HintDragPos: TPoint;
  HintDragSaveCursor: HCURSOR;
  HintDragActive: Boolean;
  HintDragText: String;

procedure HintDragTo(const Pos: TPoint); forward;
procedure HintDragDone(Drop: Boolean); forward;

{ drag and drop functions }

function HintDragMessage(Handle: HWND; Msg: TDragMessage;
  Source: TDragObject; Target: Pointer; const Pos: TPoint): Longint;
var
  DragRec: TDragRec;
begin
  Result := 0;
  if Handle <> 0 then
  begin
    DragRec.Pos := Pos;
    DragRec.Target := Target;
    DragRec.Source := Source;
    Result := SendMessage(Handle, CM_DRAG, Longint(Msg),
                                           Longint(@DragRec));
  end;
end;

function HintDoDragOver(DragMsg: TDragMessage): Boolean;
begin
  Result := False;
  if HintDragTarget <> nil then
    Result :=  LongBool(HintDragMessage(HintDragHandle, DragMsg,
                        HintDragObject, HintDragTarget, HintDragPos));
end;

procedure HintDragTo(const Pos: TPoint);
const
  Threshold = 5;
var
  DragCursor: TCursor;
  Target: TControl;
  TargetHandle: HWND;
  WinControl: TWinControl;
begin
  if HintDragActive or
    (Abs(HintDragStartPos.X - Pos.X) >= Threshold) or
    (Abs(HintDragStartPos.Y - Pos.Y) >= Threshold) then
  begin
    HintDragActive := True;
    Target := FindDragTarget(Pos, False); // controls.pas
    WinControl := FindVCLWindow(Pos);     // controls.pas
    if WinControl <> nil then
      TargetHandle := WinControl.Handle
    else
      TargetHandle := 0;
    if Target <> HintDragTarget then
    begin
      HintDoDragOver(dmDragLeave);
      HintDragTarget := Target;
      HintDragHandle := TargetHandle;
      HintDragPos := Pos;
      HintDoDragOver(dmDragEnter);
    end;
    HintDragPos := Pos;
    DragCursor := THintDragObject(HintDragObject).GetDragCursor(
                      HintDoDragOver(dmDragMove), Pos.X, Pos.Y);
    Windows.SetCursor(Screen.Cursors[DragCursor]);
    if HintDragText <> '' then
      if HintDragObject is THintDragObject then
        DragHintWindow.ShowDragHint;
  end;
end;

procedure HintDragInit(ADragObject: TDragObject; Immediate: Boolean);
begin
  HintDragObject := ADragObject;
  HintDragTarget := nil;
  GetCursorPos(HintDragStartPos);
  HintDragSaveCursor := Windows.GetCursor;
  HintDragActive := Immediate;
  HintDragCapture := THintDragObject(HintDragObject).Capture;
  if HintDragActive then HintDragTo(HintDragStartPos);
end;

--------  キリトリ  下の発言に続きます-------------------------------
                                                   本田勝彦

Original document by 本田勝彦        氏 ID:(VYR01647)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。