oledropsource.pas

是一个delphi的流程制作软件

unit OleDropSource;

{$INCLUDE OLE.INC}

interface

uses
  Windows, SysUtils, Classes, ActiveX, Controls, Messages, Forms,
  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;

  TCustomDropSource = class (TBaseDropSource)
  private
    FQueryDrag : TQueryDragEvent;
    FGiveFeedback : TGiveFeedbackEvent;
    FDragCancelled : TNotifyEvent;
    FAfterDrag : TAfterDragEvent;
    FBeforeDrag : TBeforeDragEvent;
    FDragging,
    FCopy,
    FMove,
    FLink : boolean;
    FEffect : integer;
    FDataSource : TDelphiDataSource;
    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 : TDelphiDataSource 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
  TStdDropSource = class (TCustomDropSource)
  published
    property Copy;
    property Cursors;
    property Link;
    property Move;
    property DataSource;
    property OnBeforeDrag;
    property OnQueryDrag;
    property OnGiveFeedback;
    property OnDragCancelled;
    property OnAfterDrag;
  end;

// 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).
  TControlDropSource = class (TCustomDropSource)
  private
    FDragMode : TDragMode;
    FControl : TControl;
    FOldWndProc : TWndMethod;
    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;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property DragMode : TDragMode read FDragMode write SetDragMode default dmAutomatic;
    property Control : TControl read FControl write SetControl;
    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 TCustomDropSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FCursors := TDropCursors.Create;
  FCopy := true
end;

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

procedure TCustomDropSource.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 TCustomDropSource.Execute : boolean;
var
  Effects : integer;
  Returned : HRESULT;
  DataObject : IDataObject;
  Cancel : boolean;
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
// 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 TCustomDropSource.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 TCustomDropSource.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 TControlDropSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FDragMode := dmAutomatic
end;

destructor TControlDropSource.Destroy;
begin
  Disconnect;
  inherited Destroy
end;

// Put our WndProc into the linked control
procedure TControlDropSource.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 TControlDropSource.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 TControlDropSource.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 TControlDropSource.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 TControlDropSource.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 if a DragDetect occurs,
// starts a drag process.
procedure TControlDropSource.NewWndProc (var Msg: TMessage);
var
  MousePos : TPoint;
begin
  GetCursorPos (MousePos);
  if (Msg.Msg = WM_LButtonDown) and DragDetect (FControl, MousePos) then
  begin
    Execute;
    exit
  end;

  FOldWndProc (Msg)
end;

end.