simplecontainerdrop.pas

是一个delphi的流程制作软件

//===================== OLE DRAG AND DROP DESTINATION HELPER ===================
//
// This component allows easy implementation of drag and drop onto a
// TOleContainer on a Delphi form.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

unit SimpleContainerDrop;

{$HINTS OFF}
{$ASSERTIONS OFF}  // turn on for debugging

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OleCtnrs, ActiveX;

const
// Drop effects as Delphi style constants
  deNone   = DROPEFFECT_NONE;
  deMove   = DROPEFFECT_MOVE;
  deCopy   = DROPEFFECT_COPY;
  deLink   = DROPEFFECT_LINK;
  deScroll = DROPEFFECT_SCROLL;

type
  TOnDragEvent = procedure (Sender : TObject; DataObject : IDataObject; State : TShiftState; MousePt : TPoint; var Effect, Result : integer) of Object;
  TOnDragLeaveEvent = procedure (Sender : TObject; var Result : integer) of Object;

  TSimpleOleContainerDropTarge = class (TComponent, IUnknown, IDropTarget)
// IUnknown
    function QueryInterface (const IID: TGUID; out Obj): HResult; override; stdcall;
    function _AddRef : integer; stdcall;
    function _Release : integer; stdcall;
// IDropTarget
    function DragEnter (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
    function DragOver (grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
    function DragLeave : HResult; stdcall;
    function Drop (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
// Wrapper component
  private
    FOle : TOleContainer;
    FActive : boolean;
    FDataObject : IDataObject;
    FOnDragEnter : TOnDragEvent;
    FOnDragOver : TOnDragEvent;
    FOnDragLeave : TOnDragLeaveEvent;
    FOnDrop : TOnDragEvent;
    FParent : THandle;
    FOldDefWndProc,
    FNewDefWndProc : pointer;
    procedure SetActive (Value : boolean);
    procedure SetControl (Value : TOleContainer);
    procedure NewDefWndProc (var Msg : TMessage);
  protected
    procedure DoDragEnter (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); virtual;
    procedure DoDragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); virtual;
    procedure DoDragLeave (var Result : integer); virtual;
    procedure DoDrop (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); virtual;
    procedure Notification (Component : TComponent; Operation : TOperation); override;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Register; virtual;
    procedure Revoke; virtual;
  published
    property Active : boolean read FActive write SetActive;
    property Ole : TOleContainer read FOle write SetControl;
    property OnDragEnter : TOnDragEvent read FOnDragEnter write FOnDragEnter;
    property OnDragOver : TOnDragEvent read FOnDragOver write FOnDragOver;
    property OnDragLeave : TOnDragLeaveEvent read FOnDragLeave write FOnDragLeave;
    property OnDrop : TOnDragEvent read FOnDrop write FOnDrop;
  end;

procedure Register;

implementation
//=== UTILITIES ================================================================
//--- returns the normal response for a wanted effect:
//  no keys       = "move"
//  control only  = "copy"
//  control/shift = "link"
function StandardEffect (Keys : TShiftState) : integer;
begin
  Result := deMove;
  if ssCtrl in Keys then
  begin
    Result := deCopy;
    if ssShift in Keys then
      Result := deLink
  end
end;

//=== DROP TARGET COMPONENT ====================================================
// This is a wrapper component for the Drag Target Interface.  It holds the
// interface and relays the interface calls via events.  An Active property
// allows program control over whether the drop target can currently receive
// dropped objects.

constructor TSimpleOleContainerDropTarge.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FParent := (AOwner as TForm).Handle;
  FNewDefWndProc := MakeObjectInstance (NewDefWndProc);
  FOldDefWndProc := pointer(SetWindowLong (FParent, GWL_WndProc, longint(FNewDefWndProc)))
end;

destructor TSimpleOleContainerDropTarge.Destroy;
begin
  SetWindowLong (FParent, GWL_WndProc, longint(FOldDefWndProc));
  FreeObjectInstance (FNewDefWndProc);
  inherited Destroy
end;

// We need to revoke the drag drop target before the Ole container is destroyed.
// This is achieved by trapping the WM_DESTROY message sent to the form.
procedure TSimpleOleContainerDropTarge.NewDefWndProc (var Msg : TMessage);
begin
  if FActive and (Msg.Msg = WM_DESTROY) then
    Active := false;

  with Msg do
    Result := CallWindowProc (FOldDefWndProc, FParent, Msg, wParam, lParam)
end;

//--- IUknown Interface --------------------------------------------------------
// This is a minimal interface which does not permit reference counting so that
// the interface is only destroyed when the component is destroyed.

function TSimpleOleContainerDropTarge.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface (IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE
end;

function TSimpleOleContainerDropTarge._AddRef : integer;
begin
  Result := -1
end;

function TSimpleOleContainerDropTarge._Release : integer;
begin
  Result := -1
end;

//--- IDropTarget methods ------------------------------------------------------
// This is the actual drop target handler that Windows sees.  It calls the
// appropriate DoXxxxx methods in the Delphi wrapper component.

// When a dragged object is brought into the window this interface method is
// called.  By default the drop effect is set to none (no entry sign).  The
// DoDragEnter method of the component is called.
function TSimpleOleContainerDropTarge.DragEnter (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_NONE;
  Result := NOERROR;
  FDataObject := DataObj;
  DoDragEnter (DataObj, KeysToShiftState (grfKeyState), Pt, dwEffect, integer(Result))
end;

// This interface method is called repeatedly as the dragged object is moved around
// inside the drop target.
function TSimpleOleContainerDropTarge.DragOver (grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_NONE;
  Result := NOERROR;
  DoDragOver (FDataObject, KeysToShiftState (grfKeyState), Pt, dwEffect, integer(Result))
end;

// This interface method is called if the dragged object leaves the drop target.
function TSimpleOleContainerDropTarge.DragLeave: HResult;
begin
  Result := NOERROR;
  DoDragLeave (integer(Result))
end;

// This interface method is called if the object is dropped in the target.
function TSimpleOleContainerDropTarge.Drop (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_NONE;
  Result := NOERROR;
  DoDrop (DataObj, KeysToShiftState (grfKeyState), Pt, dwEffect, integer(Result))
end;

//--- Dropo target component methods -------------------------------------------

// Change the active property and call RegisterDragDrop and RevokeDragDrop
// as appropriate.
procedure TSimpleOleContainerDropTarge.SetActive (Value : boolean);
var
  Result : HRESULT;
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if not (csDesigning in ComponentState) and Assigned (FOle) then
      if FActive then
      begin
        Result := RegisterDragDrop (FOle.Handle, Self);
        Assert (Result = 0, Format ('Register Drag Drop failed ($%x)', [Result]))
      end else begin
        Result := RevokeDragDrop (FOle.Handle);
        Assert (Result = 0, Format ('Revoke Drag Drop failed ($%x)', [Result]))
      end
  end
end;

// Change the Ole container that is the drop target.
procedure TSimpleOleContainerDropTarge.SetControl (Value : TOleContainer);
var
  OldActive : boolean;
begin
  if Value <> FOle then
  begin
    OldActive := Active;
    Active := false;
    FOle := Value;
    if Assigned (FOle) then
      Active := OldActive
  end
end;

// Notification of the removal of the OleContainer, in which case the Ole property
// is set to nil and the drop target is revoked.  If a TOleContainer is put on
// a form that has OleDropTarget then the Ole property is set to that container.
procedure TSimpleOleContainerDropTarge.Notification (Component : TComponent; Operation : TOperation);
begin
  inherited Notification (Component, Operation);

  case Operation of
    opInsert : if not Assigned (FOle) and
                 ([csDesigning, csLoading]*ComponentState = [csDesigning]) and
                 (Component is TOleContainer) then
                   Ole := TOleContainer (Component);
    opRemove : if Component = FOle then
                 Ole := nil
  end
end;

// Register and Revoke can be used to enable and disable the drop target
// by changing the Active property.
procedure TSimpleOleContainerDropTarge.Register;
begin
  Active := true
end;

procedure TSimpleOleContainerDropTarge.Revoke;
begin
  Active := false
end;

// Drag enter event called by drop target interface.  This method translates
// the keystate informtion in a Delphi TShiftState set and initially selects
// a move effect based on the standard keys.  If assigned the OnDragEnter
// event is called passing the data object interface, the keystate, the mouse
// position, the current move effect (which can be modified).  The Result
// value can be modified (by default NOERROR).  Each of these DoXxxxxx procedures
// are declared virtual so they can be overriden in descendant components.
procedure TSimpleOleContainerDropTarge.DoDragEnter (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  if Assigned (FOnDragEnter) then
    FOnDragEnter (Self, DataObject, State, Pt, Effect, Result)
end;

// See DoDragEnter above as this Event has identical parameters.
procedure TSimpleOleContainerDropTarge.DoDragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  if Assigned (FOnDragOver) then
    FOnDragOver (Self, DataObject, State, Pt, Effect, Result)
end;

// OnDragLeave only has a Result parameter (NOERROR by default).
procedure TSimpleOleContainerDropTarge.DoDragLeave (var Result : integer);
begin
  if Assigned (FOnDragLeave) then
    FOnDragLeave (Self, Result)
end;

// See DoDragEnter above as this Event has identical parameters.
// If OnDrop has not been assigned then use the standard effects to copy, move
// or link the object into the ole container
procedure TSimpleOleContainerDropTarge.DoDrop (DataObject: IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
var
  CreateInfo : TCreateInfo;
begin
  Assert (Assigned (FOle), 'Ole not assigned for Drop');

  Effect := StandardEffect (State);
  if Assigned (FOnDrop) then
    FOnDrop (Self, DataObject, State, Pt, Effect, Result)
  else begin
    ZeroMemory (@CreateInfo, SizeOf (TCreateInfo));
    if Effect = deLink then
      CreateInfo.CreateType := ctLinkFromData
    else
      CreateInfo.CreateType := ctFromData;
    CreateInfo.DataObject := DataObject;
    FOle.CreateObjectFromInfo (CreateInfo)
  end
end;

//=== Register Component =======================================================

procedure Register;
begin
  RegisterComponents ('My Controls', [TSimpleOleContainerDropTarge])
end;

end.