oledragsource.pas

是一个delphi的流程制作软件

//====================== DRAG SOURCE COMPONENTS ================================
//
// This unit contains the control aspects for a drag operation.  Does not
// contain anything that actually acquires data (see OleDataObject).
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//==============================================================================


unit OleDragSource;

{$INCLUDE OLE.INC}

interface

uses
  Windows, SysUtils, Classes, ActiveX, Controls, Messages, Forms, ExtCtrls,
  OleDataObject, OleConsts, OleInterface, OleHelpers, OleErrors;

//--- Cursor Support Utility ---------------------------------------------------
// This is a holder class for the six cases of type of cursor that you can
// provide during a drop operation - Move, Copy, Link and each of these while
// scrolling is happening. Descended from TPersistent so it knows how to stream.
type
  TDropCursors = class (TPersistent)
  private
    FCopy,
    FCopyScroll,
    FMove,
    FMoveScroll,
    FLink,
    FLinkScroll : TCursor;
  public
// Given a type of effect (deCopy, deMove, deLink combined possibly with deScroll
// this function returns the cursor type to use (a TCursor).
    function Cursor (Effect : integer) : TCursor;
  published
    property Copy : TCursor read FCopy write FCopy default crDefault;
    property CopyScroll : TCursor read FCopyScroll write FCopyScroll default crDefault;
    property Move : TCursor read FMove write FMove default crDefault;
    property MoveScroll : TCursor read FMoveScroll write FMoveScroll default crDefault;
    property Link : TCursor read FLink write FLink default crDefault;
    property LinkScroll : TCursor read FLinkScroll write FLinkScroll default crDefault;
  end;

//--- Drop Source Component ----------------------------------------------------
// This class makes a drag opeartion possible.  The key method is the Execute function
// which actually carries on the necessary API calls to make the drag operation
// occur.  In this base class there is no initiator that calls Execute this is
// up to the user.  Typically you would call Execute in a left mouse event handler
// when deciding that a drag can take place.  This is a Custom class that does
// not publish properties.  Descendant classes publish properties and can initiate
// drag operations.

  TQueryDragEvent = procedure (Sender : TObject; EscapePressed : boolean; KeyState : TShiftState; var Result : integer) of object;
  TGiveFeedbackEvent = procedure (Sender : TObject; Effect : integer; var Cursor : TCursor; var Result : integer) of object;
  TAfterDragEvent = procedure (Sender : TObject; Effect : integer; Dropped : boolean) of object;
  TBeforeDragEvent = procedure (Sender : TObject; DataObject : IDataObject; var Effects : integer; var Cancel : boolean) of object;
//TDragCancelledEvent = TNotifyEvent;

  TCustomDragSource = class (TBaseDropSource)
  private
    FQueryDrag : TQueryDragEvent;
    FGiveFeedback : TGiveFeedbackEvent;
    FDragCancelled : TNotifyEvent;
    FAfterDrag : TAfterDragEvent;
    FBeforeDrag : TBeforeDragEvent;
    FDragging,
    FCopy,
    FMove,
    FLink : boolean;
    FEffect : integer;
    FDataSource : TCustomDataSource;
    FCursors : TDropCursors;
  protected
    procedure QueryContinueDrag (EscapePressed : boolean; KeyState : TShiftState; var Result : integer); override;
    procedure GiveFeedback (Effect : integer; var Result : integer); override;
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
 // True if a drag opration is underway - used to prevent re-entrancy in Execute
    property Dragging : boolean read FDragging;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
// Set up and call the API to make the drag operation happen.  Returns true if a
// drop occurred, or false if there was an error, the drag was cancelled (by
// pressing Esc is standard) or no drop occurred
    function Execute : boolean;
// Returns the effect (Copy, Move, Link) that was asked for
// when the Execute function returns
    property Effect : integer read FEffect;
// Set to True if Copy is permitted
    property Copy : boolean read FCopy write FCopy default true;
// A set of six cursors to use
    property Cursors : TDropCursors read FCursors write FCursors;
// Set to true if Link is permitted
    property Link : boolean read FLink write FLink default false;
// Set to True if Move is permitted
    property Move : boolean read FMove write FMove default false;
// Connect this to the datasource associated with this drag operation.  Dragging
// cannot occur without this (suprisingly)
    property DataSource : TCustomDataSource read FDataSource write FDataSource;
// Called when a drag has been detected but before the API is called
    property OnBeforeDrag : TBeforeDragEvent read FBeforeDrag write FBeforeDrag;
// Called routinely by Windows to check that drag operations are to continue. See the
// implementation below of QueryContinueDrag method for the default operation.
// You need only to add this Event if the default operation is not what you want.
    property OnQueryDrag : TQueryDragEvent read FQueryDrag write FQueryDrag;
// Called routinely to modify the displayed cursor.
// You need only to add this Event if the default operation is not what you want.
    property OnGiveFeedback : TGiveFeedbackEvent read FGiveFeedback write FGiveFeedback;
// If a cancel operation occurs then this event is fired
    property OnDragCancelled : TNotifyEvent read FDragCancelled write FDragCancelled;
// Called after a drop has been made
    property OnAfterDrag : TAfterDragEvent read FAfterDrag write FAfterDrag;
  end;

// Publish properties for standard case - adds no new functionality
  TStdDragSource = class (TCustomDragSource)
  published
    property Copy;
    property Cursors;
    property Link;
    property Move;
    property DataSource;
    property OnBeforeDrag;
    property OnQueryDrag;
    property OnGiveFeedback;
    property OnDragCancelled;
    property OnAfterDrag;
  end;

// Set the mouse behaviour in relation to deciding if a drag operation is called:
// dmIgnore      - left mouse down does not start a drag operation
//                 but is passed on to the control
// dmImmediate   - left mouse button causes a drag operation
//                 to start immediately with no other testing
// dmDragDetect  - the API function DragDetect is used to detect the
//                 drag operation
// dmAllowSelect - if the left button is pressed and held then a timer runs
//                 to debounce the mouse operation, if the timer expires then
//                 the drag event happens, if the timer does not expire when
//                 the left button is released OR if the mouse is not moved a
//                 minimum distance then the drag operation is cancelled.
// dmAllowDrag -   if the left button is pressed and held then a timer runs
//                 to debounce the mouse operation, if the timer expires OR if
//                 the mouse is moved a minimum distance happens then the drag
//                 operation happens, if the timer does not expire when
//                 the left button is released then the drag operation is cancelled.
  TDebounceMode = (dmIgnore, dmImmediate, dmDragDetect, dmAllowSelect, dmStartDrag);

// This decendant has a control property that enables you to link it to any
// descendant of a TControl.  It watches for a Left Mouse Click on the TControl
// and then initiates a drag operation automatically (depending on dragmode
// property).

  TControlDragSource = class (TCustomDragSource)
  private
    FDragMode : TDragMode;
    FControl : TControl;
    FDebounceTime,
    FDebounceDist : integer;
    FDebounceMode : TDebounceMode;
    FMsg : TMessage;
    FMouse : TPoint;
    FTimer : TTimer;
    FOldWndProc : TWndMethod;
    function GetPending : boolean;
    procedure SetControl (Value: TControl);
    procedure SetDragMode (Value : TDragMode);
    procedure NewWndProc (var Msg: TMessage);
  protected
    procedure Connect; virtual;
    procedure Disconnect; virtual;
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
    procedure DebounceTimedOut (Sender : TObject); virtual;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
// property to return status of timer which indicates if a drag has
// potentially started or not
    property Pending : boolean read GetPending;
// Access to the timer component
    property Timer : TTimer read FTimer;
  published
    property DragMode : TDragMode read FDragMode write SetDragMode default dmAutomatic;
    property Control : TControl read FControl write SetControl;
    property DebounceTime : integer read FDebounceTime write FDebounceTime default ddDragDelay;
    property DebounceDist : integer read FDebounceDist write FDebounceDist default ddDragMinDist;
    property DebounceMode : TDebounceMode read FDebounceMode write FDebounceMode default dmStartDrag;
    property Copy;
    property Cursors;
    property Link;
    property Move;
    property DataSource;
    property OnBeforeDrag;
    property OnQueryDrag;
    property OnGiveFeedback;
    property OnDragCancelled;
    property OnAfterDrag;
  end;

implementation

//=== DROP CURSORS =============================================================
// Return the cursor that corresponds to the given effect,
// Use non-scrolling value for scrolling operations if no
// alternative is supplied.

function TDropCursors.Cursor (Effect : integer) : TCursor;
var
  Scrolling : boolean;
begin
  Scrolling := Effect and deScroll <> 0;

  case Effect and (deCopy or deMove or deLink) of
    deCopy : begin
               Result := FCopy;
               if Scrolling and (FCopyScroll <> crDefault) then
                 Result := FCopyScroll
             end;
    deMove : begin
               Result := FMove;
               if Scrolling and (FMoveScroll <> crDefault) then
                 Result := FMoveScroll
             end;
    deLink : begin
               Result := FLink;
               if Scrolling and (FLinkScroll <> crDefault) then
                 Result := FLinkScroll
             end
  else
    Result := crDefault
  end
end;

//=== A SIMPLE DROP SOURCE IMPLEMENTATION ======================================

constructor TCustomDragSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FCursors := TDropCursors.Create;
  FCopy := true
end;

destructor TCustomDragSource.Destroy;
begin
  FCursors.Free;
  inherited Destroy
end;

procedure TCustomDragSource.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FDataSource) then
    FDataSource := nil
end;

// Carry out drag source operation, make dataobject available and
// pass it together with allowable drop types to DoDragDrop API call.
// Returns true if drop operation is called for (Effect property returns
// what effect is wanted).  Returns false if drop in cancelled, no drops are
// allowed or no data source is available.  Can raise exceptions on error.
function TCustomDragSource.Execute : boolean;
var
  Effects : integer;
  Returned : HRESULT;
  DataObject : IDataObject;
  Cancel : boolean;