olednd.pas

是一个delphi的流程制作软件

//===================== DRAG AND DROP UTILITIES ================================
//
// This unit contains utility types, constants, procedures, functions, classes
// and components to help with the development of OLE based drag/drop and
// clipboard operations using COM interfaces.
//
// The unit contains translations of C style names into Delphi style sets
// and constants.  Translation of wide chars into Delphi strings and C style
// structures into Delphi styled records.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//==============================================================================


unit OleDnD;

interface

{$INCLUDE OLE.INC}

uses
  Windows, SysUtils, ActiveX, Classes, Graphics, ShellAPI, ComObj, ShlObj,
  ExtCtrls, IDLUtils, Forms, Controls, Messages,
{$IFDEF GIF}
  GifImage,
{$ENDIF}
  OleInterface, OleConsts;

// Global memory block returned by CF_OBJECTPOSITIONS: The object contains an
// array of TPoint structures.  The first structure specifies the screen coordinates
// of a group of shell objects and the remaining structures specify the relative
// offsets of each item in the group (pixels).
type
  PObjectPositions = ^TObjectPositions;
  TObjectPositions = packed record
    Count : integer;
    Group : TPoint;
    Offsets : array of TPoint
  end;

// This is a more user-friendly object descriptor than that used by windows
// and declared in the ActiveX unit.  The Hungarian notation is dropped and
// the offsets to PWideChar have been replaced by strings.  It is used by both
// CF_OBJECTDESCRIPTOR and CF_LINKSRCDESCRIPTOR formats. (IMHO)
type
  PObjectDescriptor = ^TObjectDescriptor;
  TObjectDescriptor = packed record
    CLSID : TCLSID;
    DrawAspect : integer;
    Size,
    Point : TPoint;  // himetric
    Status : integer;
    FullUserTypeName,
    SrcOfCopy : string;
  end;

function XlatObjectDescriptor (ND : TObjectDescriptor) : hGlobal; overload;
function XlatObjectDescriptor (const OD : ActiveX.TObjectDescriptor) : TObjectDescriptor; overload;

// This is a more user-friendly descriptor than that used by windows and
// declared in the ShlObj unit.  The Hungarian notation is dropped, file
// date and times is replaced by the more usual Delhi integer format and
// the null terminated char for a filename is now a dynamic string.  However,
// note that I have truncated filesize to integer.  It is used by the
// CF_FILEDESCRIPTOR formats. (IMHO)
type
  PFileDescriptor = ^TFileDescriptor;
  TFileDescriptor = packed record
    Flags : integer;
    CLSID : TCLSID;
    Size,
    Point : TPoint;   // himetric
    FileAttributes : integer;
    CreationTime,
    LastAccessTime,
    LastWriteTime : TDateTime;
    FileSize : integer;
    FileName : string
  end;

function XlatFileDescriptor (const ND : TFileDescriptor) : ShlObj.TFileDescriptor; overload;
function XlatFileDescriptor (const FD : ShlObj.TFileDescriptor) : TFileDescriptor; overload;

// This is a format enumerator for an IDataObject interface.
type
  TEnumFormats = class
  private
    FDataObject : IDataObject;
    FEnumerator : IEnumFormatEtc;
    FFormatEtc  : TFormatEtc;
    FMediumValid,
    FValid      : boolean;
    FCount      : integer;
    FMedium     : TStgMedium;
    procedure SetDataObject (Value : IDataObject);
    function SomeText (Format : TClipFormat) : string;
    function SomeWideText (Format : TClipFormat) : PWideChar;
    function SomeList (Format : TClipFormat) : TStringList;
    function SomeList0 (Format : TClipFormat) : TStringList;
    function SomeList1 (Format : TClipFormat) : TStringList;
    function SomeDescriptor (Format : TClipFormat) : TObjectDescriptor;
  public
    constructor Create (DataObject : IDataObject);
    destructor Destroy; override;
// frees memory associated with the storage medium
    procedure FreeMedium;
// reset to the start of the enum list
    function Reset : boolean;
// returns next formatetc or first if reset just called
    function Next : boolean;
// returns true if a given format is available
    function HasFormat (ClipFormat : TClipFormat) : boolean;
// returns the handle to a given type of medium required
    function Handle (Tymed : integer; Index : integer = -1): hGlobal;
// Handles for different types of medium
    function GlobalHandle : hGlobal;
    function MetafileHandle : hMetafile;
    function EnhMetafileHandle : hEnhMetafile;
    function GDIHandle : hGlobal;
    function StorageInterface (Index : integer = -1) : IStorage;
    function StreamInterface (Index : integer = -1) : IStream;

// These are real formats that might be available -
// Text available ?
    function HasText : boolean;
    function Text : string;
// RTF available ?
    function HasRtf : boolean;
    function Rtf : string;
// Oem Text available ?
    function HasOemText : boolean;
    function OemText : string;
// WideChar ?
    function HasWide : boolean;
    function Wide : PWideChar;
// a single filename (or first of a list) ?
    function HasFilename : boolean;
    function Filename : string;
// a list of printer friendly names ?
    function HasPrinters : boolean;
    function Printers : TStringList;
// a list of filenames ?
    function HasFilenames : boolean;
    function Filenames : TStringList;
// a list of real names for filename mapping ?
    function HasFilenameMap : boolean;
    function FilenameMap : TStringList;
// DIF format
    function HasDIF : boolean;
    function DIF : TStringList;
// SYLK format
    function HasSYLK : boolean;
    function SYLK : TStringList;
// CSV format
    function HasCSV : boolean;
    function CSV : TStringList;
// enhanced metafile
    function EnhMetafile : TMetafile;
    function HasEnhMetafile : boolean;
// win 3.1 metafile
    function Metafile : TMetaFile;
    function HasMetafile : boolean;
// bitmap
    function Bitmap : TBitmap;
    function HasBitmap : boolean;
// DIB
    function HasDIB : boolean;
    function DIB : TBitmap;
// Icon
    function HasIcon : boolean;
    function Icon : TIcon;
{$IFDEF GIF}
// GIF
    function HasGIF : boolean;
    function GIF : TGifImage;
{$ENDIF}
// Palette
    function HasPalette : boolean;
    function Palette : hPalette;
// Screen picture (enhanced metafile)
    function ScreenPicture : TMetafile;
    function HasScreenPicture : boolean;
// URL available ?
    function HasURL : boolean;
    function URL : string;
// Locale
    function Locale : LCID;
    function HasLocale : boolean;
// Drop Effect
    function PreferredDropEffect : integer;
    function HasPreferredDropEffect : boolean;
// Object Descriptor
    function ObjectDescriptor : TObjectDescriptor;
    function HasObjectDescriptor : boolean;
// Link Source Descriptor
    function LinkDescriptor : TObjectDescriptor;
    function HasLinkDescriptor : boolean;
// Link Source
    function HasLinkSource : boolean;
    function LinkSource : IStream;
// ID List
    function IDList : TStringList;
    function HasIDList : boolean;
// Object Positions
    function HasObjectPositions : boolean;
    function ObjectPositions : TObjectPositions;
// File Descriptor
    function HasFileDescriptors : boolean;
    function FileDescriptors : TStringList;
//Embedded Object
    function HasEmbeddedObject : boolean;
    function EmbeddedObject : IStorage;
//ShellScrap Object
    function HasShellScrap : boolean;
    function ShellScrap : IStorage;

// number of formats available
    property Count : integer read FCount;
// the dataobject interface for which enum is required
    property DataObject : IDataObject read FDataObject write SetDataObject;
// true if formatetc stuff is valid
    property Valid : boolean read FValid;
    property MediumValid : boolean read FMediumValid;
// information held by current formatetc if valid
    property FormatEtc : TFormatEtc read FFormatEtc;
    property Aspect : integer read FFormatEtc.dwAspect write FFormatEtc.dwAspect;
    property Format : TClipFormat read FFormatEtc.cfFormat write FFormatEtc.cfFormat;
    property Index : integer read FFormatEtc.lIndex write FFormatEtc.lIndex;
    property Medium : integer read FFormatEtc.Tymed write FFormatEtc.Tymed;
  end;

// Returns a deXXXX constant depending on which keys are pressed
function StandardEffect (Keys : TShiftState) : integer;

// Utility used to correctly free a TStringList obtained from a call
// to the IDList method in the enumerator.  Not part of the enumerator so
// it can be freed without freeing the IDList obtained.
procedure FreeIDList (List : TStringList);

// Utility to correctly free a TStringList obtained from a call to
// the FileDesriptors method in the enumerator.
procedure FreeFileDescriptorList (List : TStringList);

//=== Useful Cursors ===========================================================
// These are the Win 95 system default drag cursors,
// not otherwise present in Delphi.
// N.B. Delphi requires these constants are hardwired, they may clash with
// your cursor identifiers - in which case change them
const
  crDragMove   = 1000;
  crDragNone   = 1001;
  crDragScroll = 1002;

// The use of the drag scroll cursor (an inverted normal drag cursor) appears
// to depend on the version and subversion of Windows in use.  This boolean
// sets whether Delphi controls when being dragged and causing scrolling to
// occur make the scroll cursor appear.  External objects dragged into a Delphi
// window causing scrolling to use a cursor set by the OS not you.
var
  UseScrollCursor : boolean = false;

//=== Scroll helper class ======================================================

//Inset region codes for scroll operations
const
  inNone    = 0;  // not in an inset regions
  inLeft    = 1;  // left edge
  inRight   = 2;  // right edge   -  left and right are exclusive
  inTop     = 4;  // top edge
  inBottom  = 8;  // bottom edge  -  top and bottom are exclusive

// Default values for scrolling inset region size (height/width), delay time
// before scrolling starts, and interval between scrolling when happening.
// These values are initialised with standard ole constants, but can be altered
// to have a global effect on the application.  Could be user adjustable, values
// saved/restored from registry/ini file etc - just up to you.
var
  ScrollInset    : integer = ddScrollInset;
  ScrollDelay    : integer = ddScrollDelay;
  ScrollInterval : integer = ddScrollInterval;
  DragDelay      : integer = ddDragDelay;
  DragMinDist    : integer = ddDragMinDist;

// When a control is about to be scrolled this event is triggered.  The Flags
// variable contains combinations of the inXXXX constants.
type
  TOnScrollEvent = procedure (Sender : TObject; var Flags : integer) of Object;

// This class provides automatic detection and operation of scrolling for a control
// that supports scrolling.  Create is called passing the control to be scrolled.
// The Inset, Delay and Interval values are obtained from the global variables
// but can then be modified by means of their property values.  The process
// function is called with the mouse position relative to the screen and it returns
// true if scrolling is happening, else false.  After scrolling has started the
// Interval property can be varied to alter the scroll repeat speed.
type
  TAutoScroller = class (TPersistent)
  private
    FControl : TWinControl;
    FOnScrollEvent : TOnScrollEvent;
    FOnBeforeScroll,
    FOnAfterScroll,
    FOnTimerEvent : TNotifyEvent;
    FInset,
    FDelay,
    FInterval,
    FTick : integer;
    FTimer : TTimer;
    function GetTimerEnabled : boolean;
    procedure SetTimerEnabled (Value : boolean);
    function GetTimerInterval : integer;
    procedure SetTimerInterval (Value : integer);
    procedure DoTimer (Sender : TObject);
  public
// create and set default values for time delays etc
    constructor Create (AControl : TWinControl);
    destructor Destroy; override;
// call to process the scrolling for the given cursor position.  Returns true
// if scrolling is taking place (or will).  Property values obtained (Tick,
// HScroll and VScroll) now valid).
    function Process (Mouse : TPoint; Screen : boolean = true) : boolean;
// reset the tick back to the delay interval
    procedure Reset;
//  the linked control
    property Control : TWinControl read FControl write FControl;
// tick value of next event
    property Tick : integer read FTick;
  published
// time delay in mS before scrolling starts
    property Delay : integer read FDelay write FDelay default ddScrollDelay;
// size in pixels of the inset region
    property Inset : integer read FInset write FInset default ddScrollInset;
// interval in mS between successive scrolling events
    property Interval : integer read FInterval write FInterval default ddScrollInterval;
// timer enabled
    property TimerEnabled : boolean read GetTimerEnabled write SetTimerEnabled;
    property TimerInterval : integer read GetTimerInterval write SetTimerInterval default 50;
// before scrolling actually happens
    property OnScroll : TOnScrollEvent read FOnScrollEvent write FOnScrollEvent;
// before windows move and after
    property OnBeforeScroll : TNotifyEvent read FOnBeforeScroll write FOnBeforeScroll;
    property OnAfterScroll : TNotifyEvent read FOnAfterScroll write FOnAfterScroll;
// if timer fires
    property OnTimer : TNotifyEvent read FOnTimerEvent write FOnTimerEvent;
  end;

// This is the IDropTarget interface implemented without using TInterfacedObject.
// It will respond to some object being dropped on the control. It isolates
// the user components from the interface stuff by providing virtual abstract
// methods which must be overridden in descendant classes.  It has an Active
// property which enables or disables dropping.  Automatically closes down
// by watching for its parent form being destroyed.
type
  TStdDropTarget = class (TBaseDropTarget)
  private
    FWantActive,
    FActive : boolean;
    FDataObject : IDataObject;
    FHandle,
    FParent : THandle;
    FOldDefWndProc,
    FNewDefWndProc : pointer;
    procedure SetActive (Value : boolean);
    procedure NewDefWndProc (var Msg : TMessage);
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Revoke; virtual;
    procedure Register; virtual;
    property Parent : THandle read FParent;
    property Handle : THandle read FHandle;
  published
    property Active : boolean read FActive write SetActive;
  end;

// This DropTarget component emulates the Delphi internal drop arrangements
// and makes dropped objects from outside the Delphi application appear through
// the OnDragOver and OnDragDrop event handlers.  The "Source" term in these
// handlers in a pointer to a TComDragObject instance that can be used to
// obtain the IDataObject interface and key states, and return the desired
// Effect and any error result.  It operates by allowing the form to be the
// registered target for drops and then looks at all of the components on
// the form to see on which the mouse is positioned.
type
  TDelphiDropTarget = class (TStdDropTarget)
  private
  protected
    procedure DragEnter (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); override;
    procedure DragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); override;
    procedure DragLeave (var Result : integer); override;
    procedure Drop (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); override;
  public
  published
  end;

// "Source" parameter sent to OnDragOver and OnDragDrop events for Delphi
// components is this class
type
  TComDragObject = class (TBaseDragControlObject)
  private
    FDataObject : IDataObject;
    FEffect,
    FResult : integer;
    FState : TShiftState;
  public
    destructor Destroy; override;
    property DataObject : IDataObject read FDataObject;
    property Effect : integer read FEffect write FEffect;
    property Result : integer read FResult write FResult;
    property State : TShiftState read FState;
  end;

// This is a descendant of TStdDropTarget which is linked to the form on which
// it is placed.  The component calls the OnXXXXXX events as the form is
// entered, moved over, left or dropped on.  It contains an auto scroller
// so that scrolling of the form can be automatic.
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;
  TFormDropTarget = class (TStdDropTarget)
  private
    FOnDragEnter : TOnDragEvent;
    FOnDragOver : TOnDragEvent;
    FOnDragLeave : TOnDragLeaveEvent;
    FOnDrop : TOnDragEvent;
    FAutoScroll : boolean;
    FAutoScroller : TAutoScroller;
    function GetScrollEvent : TOnScrollEvent;
    procedure SetScrollEvent (Value : TOnScrollEvent);