olednd.pas

是一个delphi的流程制作软件

    function GetBeforeScrollEvent : TNotifyEvent;
    procedure SetBeforeScrollEvent (Value : TNotifyEvent);
    function GetAfterScrollEvent : TNotifyEvent;
    procedure SetAfterScrollEvent (Value : TNotifyEvent);
  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
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property AutoScroll : boolean read FAutoScroll write FAutoScroll;
    property Scroller : TAutoScroller read FAutoScroller write FAutoScroller;
    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;
    property OnScroll : TOnScrollEvent read GetScrollEvent write SetScrollEvent;
    property OnBeforeScroll : TNotifyEvent read GetBeforeScrollEvent write SetBeforeScrollEvent;
    property OnAfterScroll : TNotifyEvent read GetAfterScrollEvent write SetAfterScrollEvent;
  end;

// A control drop target is no more than a form drop target but with a
// control property so you can change it to any TWinControl descendant.
  TControlDropTarget = class (TFormDropTarget)
  private
    FControl : TWinControl;
    procedure SetControl (Value : TWinControl);
  protected
    procedure Notification (Component : TComponent; Operation : TOperation); override;
  published
    property Control : TWinControl read FControl write SetControl;
  end;

// Replacement TDragControl object that uses Win 95 drag cursors
// rather than the Delphi ones
  TDragCurControlObject = class (TDragControlObject)
  protected
    function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  public
  end;

//--- These are simple drag and drop destination components that work without
//    using ole2, com etc
type
  TDnDStartEvent = procedure (Sender: TObject; Count, X, Y: integer) of object;
  TDnDItemEvent = procedure (Sender: TObject; const Item: string) of object;

  TCustomDnD = class (TComponent)
  private
    FParent: THandle;
    FActive: boolean;
    FOnDnDStart: TDnDStartEvent;
    FOnDnDItem: TDnDItemEvent;
    FOnDnDFinish: TNotifyEvent;
    procedure SetActive (Value : boolean);
  public
    property Active: boolean read FActive write SetActive;
    property OnDnDStart: TDnDStartEvent read FOnDnDStart write FOnDnDStart;
    property OnDnDItem: TDnDItemEvent read FOnDnDItem write FOnDnDItem;
    property OnDnDFinish: TNotifyEvent read FOnDnDFinish write FOnDnDFinish;
  end;

  TDnDRun = class (TCustomDnD)
  protected
    procedure Loaded; override;
  public
    procedure Execute;
  published
    property Active;
    property OnDnDStart;
    property OnDnDItem;
    property OnDnDFinish;
  end;

  TDnDForm = class(TCustomDnD)
  private
    FOldDnDefWndProc,
    FNewDefWndProc: pointer;
    procedure NewDefWndProc (var Msg: TMessage);
  protected
    procedure Loaded; override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Active;
    property OnDnDStart;
    property OnDnDItem;
    property OnDnDFinish;
  end;

  TDnDControl = class(TDnDForm)
  private
    FControl: TWinControl;
    procedure SetControl (Value: TWinControl);
  protected
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  published
    property Control: TWinControl read FControl write SetControl;
  end;


function FileTimeToDateTime (Value : TFileTime) : TDateTime;
function DateTimeToFileTime (Value : TDateTime) : TFileTime;
procedure RealizeLength (var S : string);

implementation

// resource files contains cursors
{$R ole.res}

uses
  OleHelpers;

var
  Scrolling : boolean = false;

//--- returns the normal response for a wanted effect:
//  no keys       = "move"
//  control only  = "copy"
//  control/shift = "link" - ignored in this case
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;

//--- procedure to set a string length to the actual length
procedure RealizeLength (var S : string);
begin
  SetLength (S, StrLen(pchar(S)))
end;

//--- Convert a TFileTime to an integer representation

function FileTimeToDateTime (Value : TFileTime) : TDateTime;

  function FileDateToDateTime(FileDate: Integer): TDateTime;

    function EncodeTime(Hour, Min, Sec, MSec: Word) : TDateTime;
    begin
      if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
        Result := (Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / MSecsPerDay
      else
        Result := 0
    end;

    function EncodeDate(Year, Month, Day: Word) : TDateTime;
    var
      I: Integer;
      DayTable: PDayTable;
    begin
      DayTable := @MonthDays[IsLeapYear(Year)];
      if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and (Day >= 1) and (Day <= DayTable^[Month]) then
      begin
        for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);
        I := Year - 1;
        Result := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta
      end else
        Result := 0
    end;

  begin
    Result :=
      EncodeDate(
        LongRec(FileDate).Hi shr 9 + 1980,
        LongRec(FileDate).Hi shr 5 and 15,
        LongRec(FileDate).Hi and 31) +
      EncodeTime(
        LongRec(FileDate).Lo shr 11,
        LongRec(FileDate).Lo shr 5 and 63,
        LongRec(FileDate).Lo and 31 shl 1, 0)
  end;

var
  LocalFileTime: TFileTime;
  DateTime : integer;
begin
  FileTimeToLocalFileTime (Value, LocalFileTime);
  FileTimeToDosDateTime (LocalFileTime, LongRec(DateTime).Hi, LongRec(DateTime).Lo);
  Result := FileDateToDateTime (DateTime)
end;

function DateTimeToFileTime (Value : TDateTime) : TFileTime;
var
  LocalFileTime: TFileTime;
  DateTime : integer;
begin
  try
    DateTime := DateTimeToFileDate (Value);
    DosDateTimeToFileTime (LongRec(DateTime).Hi, LongRec(DateTime).Lo, LocalFileTime);
    LocalFileTimeToFileTime (LocalFileTime, Result)
  except
// if an invalid date or time conversion occurs then swallow the exception
// and return zero
    ZeroMemory (@Result, SizeOf (TFileTime))
  end
end;

//--- Convert a ShlObj filedescriptor into a Delphi filedescriptor (IMHO)
function XlatFileDescriptor (const FD : ShlObj.TFileDescriptor) : TFileDescriptor;
begin
  ZeroMemory (@Result, sizeof (TFileDescriptor));
  with Result do
  begin
    Flags := FD.dwFlags;
    if Flags and fdCLSID <> 0 then
      CLSID := FD.clsid;
    if Flags and fdSizePoint <> 0 then
    begin
      Size := Classes.Point (FD.sizel.cx, FD.sizel.cy);
      Point := FD.pointl
    end;
    if Flags and fdAttributes <> 0 then
      FileAttributes := FD.dwFileAttributes;
    if Flags and fdCreateTime <> 0 then
      CreationTime := FileTimeToDateTime (FD.ftCreationTime);
    if Flags and fdAccessTime <> 0 then
      LastAccessTime := FileTimeToDateTime (FD.ftLastAccessTime);
    if Flags and fdWritesTime <> 0 then
      LastWriteTime := FileTimeToDateTime (FD.ftLastWriteTime);
// omitted -   nFileSizeHigh;
    if Flags and fdFileSize <> 0 then
      FileSize := FD.nFileSizeLow;
    Filename := FD.cFileName
  end
end;

//--- Convert a Delphi filedescriptor into a ShlObj filedescriptor (IMHO)
function XlatFileDescriptor (const ND : TFileDescriptor) : ShlObj.TFileDescriptor; overload;
begin
  ZeroMemory (@Result, sizeof (ShlObj.TFileDescriptor));
  with Result do
  begin
    dwFlags := ND.Flags;
    if ND.Flags and fdCLSID <> 0 then
      clsid := ND.CLSID;
    if ND.Flags and fdSizePoint <> 0 then
    begin
      sizel.cx := ND.Size.X;
      sizel.cy := ND.Size.Y;
      pointl := ND.Point
    end;
    if ND.Flags and fdAttributes <> 0 then
      dwFileAttributes := ND.FileAttributes;
    if ND.Flags and fdCreateTime <> 0 then
      ftCreationTime := DateTimeToFileTime (ND.CreationTime);
    if ND.Flags and fdAccessTime <> 0 then
      ftLastAccessTime := DateTimeToFileTime (ND.LastAccessTime);
    if ND.Flags and fdWritesTime <> 0 then
      ftLastWriteTime := DateTimeToFileTime (ND.LastWriteTime);
// omitted -   nFileSizeHigh;
    if ND.Flags and fdFileSize <> 0 then
      nFileSizeLow := ND.FileSize;
    StrPCopy (cFilename, ND.FileName)
  end
end;

// Translates an ActiveX.pas Object descriptor into a Delphi object descriptor (IMHO)
function XlatObjectDescriptor (const OD : ActiveX.TObjectDescriptor) : TObjectDescriptor;
begin
  ZeroMemory (@Result, sizeof (TObjectDescriptor));
  with Result do
  begin
    CLSID := OD.CLSID;
    DrawAspect := OD.dwDrawAspect;
    Size := OD.Size;
    Point := OD.Point;
    Status := OD.dwStatus;
    if OD.dwFullUserTypeName <> 0 then
      FullUserTypeName := WideCharToString (PWideChar(integer (@OD) + OD.dwFullUserTypeName));
    if OD.dwSrcOfCopy <> 0 then
      SrcOfCopy := WideCharToString (PWideChar(integer (@OD) + OD.dwSrcOfCopy))
//    else
//      SrcOfCopy := '' // '<Unknown Source>'
  end
end;

// Translates a Delphi object descriptor into an ActiveX descriptor and returns
// a global memory handle to it
function XlatObjectDescriptor (ND : TObjectDescriptor) : hGlobal;
var
  DescSize,
  UTNCharLen,
  SOCCharLen : integer;
  Descriptor : ActiveX.PObjectDescriptor;
  ResultWStr : PWideChar;
begin
  if ND.FullUserTypeName <> '' then
    UTNCharLen := MultiByteToWideChar(0, 0, PChar(ND.FullUserTypeName), Length(ND.FullUserTypeName), nil, 0) + 1
  else
    UTNCharLen := 0;
  if ND.SrcOfCopy <> '' then
    SOCCharLen := MultiByteToWideChar(0, 0, PChar(ND.SrcOfCopy), Length(ND.SrcOfCopy), nil, 0) + 1
  else
    SOCCharLen := 0;
  DescSize := SizeOf(ActiveX.TObjectDescriptor) + ((UTNCharLen + SOCCharLen) * Sizeof(WideChar));

  Result := GlobalAlloc (GMEM_MOVEABLE, DescSize);
  if Result <> 0 then
  begin
    Descriptor := GlobalLock(Result);
    try
      ZeroMemory (Descriptor, DescSize);
      with Descriptor^ do
      begin
        cbSize := DescSize;
        CLSID := ND.CLSID;
        dwDrawAspect := ND.DrawAspect;
        dwStatus := ND.Status;
        if UTNCharLen = 0 then
        begin
          dwFullUserTypeName := 0;

        end else begin
          dwFullUserTypeName := SizeOf (ActiveX.TObjectDescriptor);
          ResultWStr := PWideChar (integer(Descriptor) + dwFullUserTypeName);
          MultiByteToWideChar (0, 0, PChar(ND.FullUserTypeName), Length (ND.FullUserTypeName), ResultWStr, UTNCharLen);
          ResultWStr [UTNCharLen-1] := #0;
        end;

        if SOCCharLen = 0 then
        begin
          dwSrcOfCopy := 0;

        end else begin
          if UTNCharLen = 0 then
            dwSrcOfCopy := SizeOf (ActiveX.TObjectDescriptor)
          else
            dwSrcOfCopy := dwFullUserTypeName + UTNCharLen * SizeOf (WideChar); //SOCCharLen * SizeOf (WideChar);
          ResultWStr := PWideChar (integer (Descriptor) + dwSrcOfCopy);
          MultiByteToWideChar(0, 0, PChar(ND.SrcOfCopy), Length (ND.SrcOfCopy), ResultWStr, SOCCharLen);
          ResultWStr [SOCCharLen-1] := #0
        end
      end
    finally
      GlobalUnlock(Result)
    end
  end
end;

//--- function to return the number of items dropped given a drop handle
function DroppedCount (DropHandle: hDrop): integer;
begin
  Result := DragQueryFile (DropHandle, $FFFFFFFF, nil, 0)
end;

//--- function to return an individual dropped item as a string, given the
//    drop handle and an index to an item
function DroppedItem (DropHandle: hDrop; Item: integer): string;
begin
  SetLength (Result, MAX_PATH+1);
  DragQueryFile (DropHandle, Item, pchar(Result), MAX_PATH);
  RealizeLength (Result)
end;


//=== ENUMERATE FORMATS ========================================================

//--- Create the enumerator and set the dataobject
constructor TEnumFormats.Create (DataObject : IDataObject);
begin
  inherited Create;
  SetDataObject (DataObject)
end;

//--- Destroy the dataobject copy and the enumerator
destructor TEnumFormats.Destroy;
begin
  FreeMedium;
  SetDataObject (nil);
  inherited Destroy
end;

//--- free the memory associated with the storage medium record FMedium
procedure TEnumFormats.FreeMedium;
begin
  if FMediumValid then
  begin
    ReleaseStgMedium (FMedium);
    ZeroMemory (@FMedium, sizeof (TStgMedium))
  end;
  FMediumValid := false
end;

//--- function to obtain the next Format supported by the DataObject, or the
//    first if Reset has just been called, returns true on success
function TEnumFormats.Next : boolean;
var
  FResult : HResult;
  Returned : integer;
begin
  inc (FCount);
  FResult := FEnumerator.Next (1, FFormatEtc, @Returned);
  FValid :=  FResult = S_OK;
  Result := FValid
end;

//--- Reset the Enumerator interface back to the beginning of the list,
//    returns true on success
function TEnumFormats.Reset : boolean;
begin
  FValid := false;
  FCount := 0;
  Result := Succeeded (FEnumerator.Reset)
end;

//--- Enumerate the data object for a specific format, returns true if
//    found, then the FFormatEtc record will be valid
function TEnumFormats.HasFormat (ClipFormat : TClipFormat) : boolean;
begin
  Result := false;
  if Reset then
    while (not Result) and Next do
      Result := ClipFormat = Format
end;

procedure TEnumFormats.SetDataObject (Value : IDataObject);
var
  Result : integer;
begin
// clear current values and free
  FDataObject := nil;