olednd.pas

是一个delphi的流程制作软件

  FGD : PFileGroupDescriptor;
  Loop : integer;
  FD : PFileDescriptor;
begin
  Result := TStringList.Create;
  if HasFileDescriptors then
  begin
    Block := GlobalHandle;
    try
      FGD := GlobalLock (Block);
      try
// loop to get items
{$RANGECHECKS OFF}
        for Loop := 0 to FGD^.cItems - 1 do
        begin
          New (FD);
          FD^ := XlatFileDescriptor (FGD^.FGD[Loop]);
          Result.AddObject (FD^.Filename, pointer (FD))
        end
{$RANGECHECKS ON}
      finally
        GlobalUnlock (Block)
      end
    finally
      FreeMedium
    end
  end
end;

function TEnumFormats.HasFileDescriptors : boolean;
begin
  Result := HasFormat (CF_FILEDESCRIPTOR)
end;

// Utility used to free a returned File descriptor list, also correctly frees Objects held
procedure FreeFileDescriptorList (List : TStringList);
var
  Loop : integer;
begin
  for Loop := List.Count - 1 downto 0 do
    FreeMem (PFileDescriptor (List.Objects [Loop]));
  List.Free
end;

function TEnumFormats.HasEmbeddedObject : boolean;
begin
  Result := HasFormat (CF_EMBEDDEDOBJECT)
end;

function TEnumFormats.EmbeddedObject : IStorage;
begin
  if HasEmbeddedObject then
    try
      Result := StorageInterface
    finally
      FreeMedium
    end
  else
    Result := nil
end;

function TEnumFormats.HasShellScrap : boolean;
begin
  Result := HasFormat (CF_SHELLSCRAP)
end;

function TEnumFormats.ShellScrap : IStorage;
begin
  if HasShellScrap then
    try
      Result := StorageInterface
    finally
      FreeMedium
    end
  else
    Result := nil
end;


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

constructor TStdDropTarget.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FParent := (AOwner as TForm).Handle;
  FHandle := FParent;  // default the drop target to the form
  FNewDefWndProc := MakeObjectInstance (NewDefWndProc);
  FOldDefWndProc := pointer (SetWindowLong (FParent, GWL_WndProc, longint(FNewDefWndProc)))
end;

destructor TStdDropTarget.Destroy;
begin
  FDataObject := nil;
  SetWindowLong (FParent, GWL_WndProc, longint(FOldDefWndProc));
  FreeObjectInstance (FNewDefWndProc);
  inherited Destroy
end;

procedure TStdDropTarget.Loaded;
begin
  inherited Loaded;
  FActive := false;
  Active := FWantActive
end;

// We need to revoke the drag drop target before the form is destroyed.
// This is achieved by trapping the WM_DESTROY message sent to the form (parent).
// It could be done using the forms OnDestroy handler but this might be
// a problem if someone else uses it.  Or it could be done by creating a
// descendant of TForm which has the desired effects but I haven't used this
// approach.
procedure TStdDropTarget.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;

// Change the active property and call RegisterDragDrop and RevokeDragDrop
// as appropriate.  If component is currently loading then keep the active value
// and use it in the Loaded procedure.
procedure TStdDropTarget.SetActive (Value : boolean);
var
  Result : HRESULT;
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if not (csDesigning in ComponentState) and
       not (csLoading   in ComponentState) then
//    if ComponentState * [csDesigning, csLoading] = [] then
    begin
      if FHandle <> 0 then
        if FActive then
        begin
          Result := RegisterDragDrop (FHandle, Self);
          Assert (Result = 0, Format ('Register Drag Drop failed ($%x)', [Result]));
          Result := CoLockObjectExternal (Self, true, false);
          Assert (Result = 0, Format ('Couldn''t lock drop target ($%x)', [Result]))
        end else begin
          Result := RevokeDragDrop (FHandle);
          Assert (Result = 0, Format ('Revoke Drag Drop failed ($%x)', [Result]));
          Result := CoLockObjectExternal (Self, false, true );
          Assert (Result = 0, Format ('Couldn''t unlock drop target ($%x)', [Result]));
          FDataObject := nil
        end
    end else
      FWantActive := Value
  end
end;

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

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

//=== COM Drop Object methods ==================================================

destructor TComDragObject.Destroy;
begin
  FDataObject := nil;
  inherited Destroy
end;

//=== Drag utilities ===========================================================
// A lot here has been clipped, renamed and modified from controls.pas

var
  ComDragObject : TComDragObject = nil;    // There can be only one!
  WindowAtom: TAtom = 0;

function Controls_DragMessage (Handle : hWnd; Msg : TDragMessage; Target : pointer; const Pos : TPoint): longint;
var
  DragRec: TDragRec;
begin
  Result := 0;
  if Handle <> 0 then
  begin
    DragRec.Pos := Pos;
    DragRec.Target := Target;
    DragRec.Source := ComDragObject;
    DragRec.Docking := false;
    Result := SendMessage (Handle, CM_DRAG, longint(Msg), longint(@DragRec))
  end
end;

function Controls_DoDragOver (DragMsg: TDragMessage) : boolean;
begin
  Result := false;
  with ComDragObject do
    if Assigned (DragTarget) then
      Controls_DoDragOver := longbool (Controls_DragMessage (DragHandle, DragMsg, DragTarget, DragPos))
end;

function Controls_DragTo (const Pos: TPoint) : boolean;

  function DragFindTarget (const Pos: TPoint; var Handle : hWnd): pointer;

    function DragFindWindow (const Pos: TPoint): hWnd;

      function IsDelphiHandle (Handle: hWnd): boolean;
      begin
        Result := (Handle <> 0) and (GetProp(Handle, MakeIntAtom(WindowAtom)) <> 0)
      end;

    begin
      Result := WindowFromPoint (Pos);
      while Result <> 0 do
        if not IsDelphiHandle (Result) then
          Result := GetParent (Result)
        else
          Exit
    end; // DragFindWindow

  begin
    Handle := DragFindWindow (Pos);
    Result := pointer (Controls_DragMessage (Handle, dmFindTarget, nil, Pos))
  end; // DragFindTarget

var
  Target : TControl;
  TargetHandle : hWnd;

begin
  Target := DragFindTarget (Pos, TargetHandle);
  with ComDragObject do
  begin
    if Target <> DragTarget then
    begin
      Controls_DoDragOver (dmDragLeave);
      DragTarget := Target;
      DragHandle := TargetHandle;
      DragPos := Pos;
      Controls_DoDragOver (dmDragEnter)
    end;
    DragPos := Pos;
    if Assigned (DragTarget) then
      DragTargetPos := TControl(DragTarget).ScreenToClient(Pos)
  end;
  Result := Controls_DoDragOver (dmDragMove)
end; // DragTo

//=== General (Delhi Emulator) Drop Target =====================================
// This descendant of TStdDropTarget will send messages to Delphi controls on
// a form which will surface as OnDragOver and OnDragDrop events.

procedure TDelphiDropTarget.DragEnter (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  CancelDrag;
  DragOver (DataObject, State, Pt, Effect, Result)
end;

procedure TDelphiDropTarget.DragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  ComDragObject.FDataObject := DataObject;
  ComDragObject.FState := State;
  ComDragObject.FEffect := Effect;
  ComDragObject.FResult := Result;
  if Controls_DragTo (pt) then
  begin
    Result := ComDragObject.FResult;
    Effect := ComDragObject.FEffect
  end else
    Effect := deNone
end;

procedure TDelphiDropTarget.DragLeave (var Result : integer);
begin
  Controls_DoDragOver (dmDragLeave);
  ComDragObject.DragTarget := nil;
  ComDragObject.DragHandle := 0
end;

procedure TDelphiDropTarget.Drop (DataObject: IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  ComDragObject.FDataObject := DataObject;
  ComDragObject.FState := State;
  ComDragObject.FEffect := Effect;
  ComDragObject.FResult := Result;
  if Controls_DragTo (pt) then
  begin
    Result := ComDragObject.FResult;
    Effect := ComDragObject.FEffect;
    if Effect <> deNone then
    begin
      Controls_DoDragOver (dmDragDrop);
      Result := ComDragObject.FResult;
      Effect := ComDragObject.FEffect
    end
  end else
    Effect := deNone
end;

//=== A drop target component which makes a form sensitive to all drops ========

constructor TFormDropTarget.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FAutoScroller := TAutoScroller.Create (AOwner as TForm)
end;

destructor TFormDropTarget.Destroy;
begin
  FAutoScroller.Free;
  inherited Destroy
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 TFormDropTarget.DragEnter (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.
// If active then the autoscroller is called before the OnDragOverEvent
procedure TFormDropTarget.DragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  if FAutoScroll and FAutoScroller.Process (Pt) then
    Effect := Effect or deScroll;
  if Assigned (FOnDragOver) then
    FOnDragOver (Self, DataObject, State, Pt, Effect, Result)
end;

// OnDragLeave only has a Result parameter (NOERROR by default).
procedure TFormDropTarget.DragLeave (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 TFormDropTarget.Drop (DataObject: IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer);
begin
  Effect := StandardEffect (State);
  if Assigned (FOnDrop) then
    FOnDrop (Self, DataObject, State, Pt, Effect, Result)
end;

procedure TFormDropTarget.SetScrollEvent (Value : TOnScrollEvent);
begin
  FAutoScroller.OnScroll := Value
end;

function TFormDropTarget.GetScrollEvent : TOnScrollEvent;
begin
  Result := FAutoScroller.OnScroll
end;

function TFormDropTarget.GetBeforeScrollEvent : TNotifyEvent;
begin
  Result := FAutoScroller.OnBeforeScroll
end;

procedure TFormDropTarget.SetBeforeScrollEvent (Value : TNotifyEvent);
begin
  FAutoScroller.OnBeforeScroll := Value
end;

function TFormDropTarget.GetAfterScrollEvent : TNotifyEvent;
begin
  Result := FAutoScroller.OnAfterScroll
end;

procedure TFormDropTarget.SetAfterScrollEvent (Value : TNotifyEvent);
begin
  FAutoScroller.OnAfterScroll := Value
end;


//=== An individual control is sensitive =======================================

procedure TControlDropTarget.SetControl (Value : TWinControl);
var
  OldActive : boolean;
begin
  if Value <> FControl then
  begin
    OldActive := FActive;
    Active := false;
    FControl := Value;
    if Assigned (FControl) then
    begin
      FAutoScroller.Control := FControl;
      FHandle := FControl.Handle;
      Active := OldActive
    end else
      FHandle := 0
  end
end;

procedure TControlDropTarget.Notification (Component : TComponent; Operation : TOperation);
begin
  inherited Notification (Component, Operation);
  if (Operation = opRemove)  and (Component = FControl) then
    Control := nil
end;

//=== Auto Scroll Helper =======================================================

constructor TAutoScroller.Create (AControl : TWinControl);
begin
  inherited Create;
  FControl := AControl;
  Assert (Assigned (F