--------  キリトリ  上の発言からの続きです　-------------------------

type
  TDmy = class(TControl);

procedure HintDragInitControl(Control: TControl; Immediate: Boolean);
var
  ADragObject: TDragObject;
begin
  HintDragControl := Control;
  try
    ADragObject := nil;
    HintDragFreeObject := False;
    if Assigned(TDmy(Control).OnStartDrag) then
      TDmy(Control).OnStartDrag(Control, ADragObject);
    if ADragObject = nil then
    begin
      ADragObject := THintDragObject.Create(Control);
      HintDragFreeObject := True;
    end;
    HintDragInit(ADragObject, Immediate);
  except
    HintDragControl := nil;
    raise;
  end;
end;

procedure HintDragDone(Drop: Boolean);
var
  DragSave: TDragObject;
  Accepted: Boolean;
  DragMsg: TDragMessage;
  TargetPos: TPoint;
begin
  DragSave := nil;
  HintDragControl := nil;
  try
    THintDragObject(HintDragObject).ReleaseCapture(HintDragCapture);
    DragSave := HintDragObject;
    Windows.SetCursor(HintDragSaveCursor);
    try
      if TObject(HintDragTarget) is TControl then
        TargetPos := TControl(HintDragTarget).ScreenToClient(HintDragPos)
      else
        TargetPos := HintDragPos;
      Accepted := HintDragActive and
                  HintDoDragOver(dmDragLeave) and Drop;
      HintDragObject := nil;
      DragMsg := dmDragDrop;
      if not Accepted then
      begin
        DragMsg := dmDragCancel;
        HintDragPos.X := 0;
        HintDragPos.Y := 0;
        TargetPos.X := 0;
        TargetPos.Y := 0;
      end;
      HintDragMessage(HintDragHandle, DragMsg, DragSave,
                      HintDragTarget, HintDragPos);
      THintDragObject(DragSave).Finished(HintDragTarget, TargetPos.X,
                                         TargetPos.Y, Accepted);
      HintDragTarget := nil;
    finally
      HintDragObject := nil;
    end;
  finally
    DragHintWindow.HideDragHint;
    if HintDragFreeObject then
      DragSave.Free;
  end;
end;

{ interfaced procedure & function }

procedure CancelHintDrag;
begin
  if HintDragObject <> nil then
    HintDragDone(False);
  HintDragControl := nil;
end;

function HintDragging(Control: TControl): Boolean;
begin
  Result := HintDragControl = Control;
end;

procedure EndHintDrag(Control: TControl; Drop: Boolean);
begin
  if HintDragging(Control) then
    HintDragDone(Drop);
end;

procedure BeginHintDrag(Control: TControl; Immediate: Boolean;
    HintText: String);
var
  P: TPoint;
begin
  if Control is TForm then
    raise EInvalidOperation.CreateRes(SCannotDragForm);
  if HintDragControl = nil then
  begin
    HintDragControl := Control;
    if csLButtonDown in Control.ControlState then
    begin
      GetCursorPos(P);
      P := Control.ScreenToClient(P);
      Control.Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
    end;
    if HintDragControl = Control then
      HintDragInitControl(Control, Immediate);
    HintDragText := HintText;
  end;
end;

{ THintDragObject }

function THintDragObject.Capture: HWND;
begin
  Result := AllocateHWnd(MouseMsg);
  SetCapture(Result);
end;

procedure THintDragObject.ReleaseCapture(Handle: HWND);
begin
  Windows.ReleaseCapture;
  DeallocateHWND(Handle);
end;

procedure THintDragObject.MouseMsg(var Message: TMessage);
var
  P: TPoint;
begin
  try
    case Message.Msg of
      WM_MOUSEMOVE:
        begin
          P := SmallPointToPoint(TWMMouse(Message).Pos);
          Windows.ClientToScreen(HintDragCapture, P);
          HintDragTo(P);
        end;
      WM_LBUTTONUP:
        HintDragDone(True);
      WM_RBUTTONDOWN:
        HintDragDone(False);
    end;
  except
    if HintDragControl <> nil then HintDragDone(False);
    raise;
  end;
end;

{ TDragHintWindow }

procedure TDragHintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  {$IFDEF KEYMESSAGE}
  Params.Style := WS_POPUP;
  {$ELSE}
  Params.Style := WS_POPUP or WS_DISABLED;
  {$ENDIF}
end;

{$IFDEF KEYMESSAGE}
procedure TDragHintWindow.WMKeyDown(var Message: TWMKeyDown);
begin
  if TWMKeyDown(Message).CharCode = VK_ESCAPE then
    CancelHintDrag;
end;
{$ENDIF}

{$IFDEF VER90}
function TDragHintWindow.CalcHintRect(const AHint: string): TRect;
begin
  Result := Rect(0, 0, Screen.Width, 0);
  DrawText(Canvas.Handle, PChar(AHint), -1, Result,
    DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
  Inc(Result.Right, 6);
  Inc(Result.Bottom, 2);
end;
{$ENDIF}

procedure TDragHintWindow.ShowDragHint;
var
  CursorHeight, CursorWidth, CaptionHeight: Integer;
  HintPos: TPoint;
  HintWinRect: TRect;
begin
  if not HandleAllocated then
    HandleNeeded;
  CaptionHeight := GetSystemMetrics(SM_CYCAPTION);
  CursorHeight := GetSystemMetrics(SM_CYCURSOR);
  CursorWidth := GetSystemMetrics(SM_CXCURSOR);
  HintPos := HintDragPos;
  Inc(HintPos.Y, CursorHeight - CaptionHeight);
  Inc(HintPos.X, CursorWidth - CaptionHeight + 3);
  HintWinRect := CalcHintRect(HintDragText);
  OffsetRect(HintWinRect, HintPos.X, HintPos.Y);
  { ActivateHint no adjust }
  Caption := HintDragText;
  BoundsRect := HintWinRect;
  SetWindowPos(Handle, HWND_TOPMOST, HintWinRect.Left, HintWinRect.Top,
    0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
  {$IFDEF KEYMESSAGE}
  if HintDragControl is TWinControl then
    Parent := TWinControl(HintDragControl);
  SetFocus;
  {$ENDIF}
end;

procedure TDragHintWindow.HideDragHint;
begin
  {$IFDEF KEYMESSAGE}
  Parent := nil;
  {$ENDIF}
  if HandleAllocated then
    ReleaseHandle;
end;

initialization
  DragHintWindow := TDragHintWindow.Create(Application);

finalization
  DragHIntWindow.Free;

end.
--------  キリトリ  -------------------------------------------------
                                                   本田勝彦

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

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