oledragsource.pas

是一个delphi的流程制作软件

begin
  Result := false;
  if not FDragging then
  begin
// Assemble the Effects wanted
    Effects := deNone;
    if FCopy then
      Effects := Effects or deCopy;
    if FMove then
      Effects := Effects or deMove;
    if FLink then
      Effects := Effects or deLink;

    if (Effects <> deNone) and Assigned (FDataSource) then
    begin
// Tell the dataobject what effects are called for
      FDataSource.PreferredDropEffect := Effects;
// Obtain the dataobject to drag
      DataObject := FDataSource.DataObject;
      try
// Fire the OnBeforeDrag event passing the dataobject, the effects
// and allow the punter to cancel the drag
        Cancel := false;
        if Assigned (FBeforeDrag) then
          FBeforeDrag (Self, DataObject, Effects, Cancel);

        if Cancel then
          Returned := ddCancel
        else begin
// Call the API
          FDragging := true;
          try
            Returned := DoDragDrop (DataObject, Self, Effects, FEffect)
          finally
            FDragging := false
          end
        end;
// Deal with the results, returning the function true if a drop occured,
// False if a cancel occurred, raise an exception on error (via OleCheck)
        case Returned of
          ddDrop   : Result := true;
          ddCancel : ;  // Result := false
        else
          OleCheck (Returned)
        end;
// Fire the AfterDrag event to allow the punter to take action
        if Assigned (FAfterDrag) then
          FAfterDrag (Self, FEffect, Result)
      finally
// Release the DataObject
        DataObject := nil
      end
    end
  end
end;

// Provide standard behaviour for a drag operation
procedure TCustomDragSource.QueryContinueDrag (EscapePressed : boolean; KeyState : TShiftState; var Result : integer);
begin
  if EscapePressed then  // cancel the drop
    Result := ddCancel
  else
    if not (ssLeft in KeyState) then
      Result := ddDrop;   // drop has occurred

// Fire event - max flexiblity
  if Assigned (FQueryDrag) then
    FQueryDrag (Self, EscapePressed, KeyState, Result);

// Fire drop cancelled event if appropriate
  if (Result = ddCancel) and Assigned (FDragCancelled) then
    FDragCancelled (Self)
end;

// Provide standard feedback to the punter
procedure TCustomDragSource.GiveFeedback (Effect : integer; var Result : integer);
var
  Cursor : TCursor;
begin
  Cursor := Cursors.Cursor (Effect);
  if Cursor = crDefault then
    Result := ddDefault
  else
    Result := ddOk;

  if Assigned (FGiveFeedback) then
    FGiveFeedback (Self, Effect, Cursor, Result);

  if (Result = ddOk) and (Cursor <> crDefault) then
    SetCursor (Screen.Cursors [Cursor])
end;

//--- Drop Source linked to a control ------------------------------------------
// The drop source will link to any control (ie one descended from
// TControl by inserting our own WndProc into the control).
constructor TControlDragSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FTimer := TTimer.Create (Self);
  with FTimer do
  begin
    OnTimer := DebounceTimedOut;
    Enabled := false
  end;
  FDebounceMode := dmStartDrag;
  FDebounceTime := ddDragDelay;
  FDebounceDist := ddDragMinDist;
  FDragMode := dmAutomatic
end;

destructor TControlDragSource.Destroy;
begin
  FTimer.Free;
  Disconnect;
  inherited Destroy
end;

function TControlDragSource.GetPending : boolean;
begin
  Result := FTimer.Enabled
end;

// Put our WndProc into the linked control
procedure TControlDragSource.Connect;
begin
// Without the ComponentState test the drag behaviour works in design
// mode, I don't recommend this but it's fun to try it out.
  if (not (csDesigning in ComponentState)) and
    Assigned (FControl) then
  begin
    FOldWndProc := FControl.WindowProc;
    FControl.WindowProc := NewWndProc
  end
end;

// Restore the linked control WndProc
procedure TControlDragSource.Disconnect;
begin
  if Assigned (FControl) and Assigned (FOldWndProc) then
  begin
    FControl.WindowProc := FOldWndProc;
    FOldWndProc := nil
  end
end;

// Change the dragmode, connecting or disconnecting our wndproc
procedure TControlDragSource.SetDragMode (Value : TDragMode);
begin
  if Value <> FDragMode then
  begin
    FDragMode :=  Value;
    if FDragMode = dmAutomatic then
      Connect
    else
      Disconnect
  end
end;

// Change the linked control
procedure TControlDragSource.SetControl (Value: TControl);
begin
  Disconnect;
  FControl := Value;
  if Assigned (FControl) then
  begin
    if FDragMode = dmAutomatic then
      Connect;
    FControl.FreeNotification (Self)
  end
end;

// Disconnect the control and restore our WndProc
procedure TControlDragSource.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);

  if (Operation = opRemove) and (AComponent = FControl) then
  begin
    Disconnect;
    FControl := nil
  end
end;

// WndProc watches for a left mouse down if a drag detection occurs,
// starts a drag process. This procedure allows for a variety of behaviours
// depending on the control its linked to (and taste).
procedure TControlDragSource.NewWndProc (var Msg: TMessage);
var
  dX,
  dY : integer;
  Mp : TPoint;
begin
  case FDebounceMode of
    dmIgnore : ; // fall thro' to OldWndProc
    dmImmediate :  if Msg.Msg = WM_LButtonDown then
                   begin
                     Execute;
                     exit
                   end;
    dmDragDetect : if Msg.Msg = WM_LButtonDown then
                   begin
                     if DragDetect (FControl) then
                       Execute;
                     exit
                   end;
  else
    case Msg.Msg of
// left button down, so start the debounce timer and remember the original
// message and mouse position to use later.  If debounce time interval is zero
// then use drag detect function to decide if a drag has started.
    WM_LButtonDown : begin
                       if FDebounceTime = 0 then
                       begin
                         if DragDetect (FControl) then
                           Execute;
                         exit
                       end;
                       GetCursorPos (FMouse);
                       FTimer.Interval := FDebounceTime;
                       FMsg := Msg;
                       FTimer.Enabled := true;
                       exit
                     end;
// Left button up then if the debounce timer was running then kill it and
// send the original left button down message, before the left button up to
// simulate what has happened
    WM_LButtonUp :   if Pending then
                     begin
                       FTimer.Enabled := false;
                       FOldWndProc (FMsg)
                     end;
// Mouse has moved, if debounce timer is running then see if the mouse
// has moved the minimum distance to start the drag operation
    WM_MouseMove :   if Pending then
                     begin
                       GetCursorPos (Mp);
                       dX := abs (Mp.X - FMouse.X);
                       dY := abs (Mp.Y - FMouse.Y);
                       if (dX > FDebounceDist) or (dY > FDebounceDist) then
                       begin
// Move min distance is detected so either -
                         if FDebounceMode = dmAllowSelect then
                         begin
// Kill the drag process to allow a selection to happen
                           FTimer.Enabled := false;
                           FOldWndProc (FMsg)
                         end else begin
// or start the drag operation now
                           DebounceTimedOut (nil);
                           exit
                         end
                       end
                     end
    end
  end;
// No interest in the message so pass it on
  FOldWndProc (Msg)
end;

procedure TControlDragSource.DebounceTimedOut (Sender : TObject);
begin
  FTimer.Enabled := false;
  Execute // carry out the drag operation
end;

end.