RealICQClient/Includes/DRAGDROP/Components/DropSource3.pas

unit DropSource3;

// -----------------------------------------------------------------------------
//
//			*** NOT FOR RELEASE ***
//
// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite
// Module:          DropSource3
// Description:     Deprecated TDropSource class.
//                  Provided for compatibility with previous versions of the
//                  Drag and Drop Component Suite.
// Version:         4.0
// Date:            25-JUN-2000
// Target:          Win32, Delphi 3-6 and C++ Builder 3-5
// Authors:         Angus Johnson, ajohnson@rpi.net.au
//                  Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright        © 1997-2000 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------


interface

uses
  DragDrop,
  DropSource,
  ActiveX,
  Classes;

{$include DragDrop.inc}

const
  MAXFORMATS = 20;

type
  // TODO -oanme -cStopShip : Verify that TDropSource can be used for pre v4 components.
  TDropSource = class(TCustomDropSource)
  private
    FDataFormats: array[0..MAXFORMATS-1] of TFormatEtc;
    FDataFormatsCount: integer;

  protected
    // IDataObject implementation
    function QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall;

    // TCustomDropSource implementation
    function HasFormat(const FormatEtc: TFormatEtc): boolean; override;
    function GetEnumFormatEtc(dwDirection: LongInt): IEnumFormatEtc; override;

    // New functions...
    procedure AddFormatEtc(cfFmt: TClipFormat; pt: PDVTargetDevice;
      dwAsp, lInd, tym: longint); virtual;

  public
    constructor Create(AOwner: TComponent); override;
  end;

implementation

uses
  ShlObj,
  SysUtils,
  Windows;

// -----------------------------------------------------------------------------
//			TEnumFormatEtc
// -----------------------------------------------------------------------------

type

  pFormatList = ^TFormatList;
  TFormatList = array[0..255] of TFormatEtc;

  TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
  private
    FFormatList: pFormatList;
    FFormatCount: Integer;
    FIndex: Integer;
  public
    constructor Create(FormatList: pFormatList; FormatCount, Index: Integer);
    { IEnumFormatEtc }
    function Next(Celt: LongInt; out Elt; pCeltFetched: pLongInt): HRESULT; stdcall;
    function Skip(Celt: LongInt): HRESULT; stdcall;
    function Reset: HRESULT; stdcall;
    function Clone(out Enum: IEnumFormatEtc): HRESULT; stdcall;
  end;
// -----------------------------------------------------------------------------

constructor TEnumFormatEtc.Create(FormatList: pFormatList;
            FormatCount, Index: Integer);
begin
  inherited Create;
  FFormatList := FormatList;
  FFormatCount := FormatCount;
  FIndex := Index;
end;
// -----------------------------------------------------------------------------

function TEnumFormatEtc.Next(Celt: LongInt;
  out Elt; pCeltFetched: pLongInt): HRESULT;
var
  i: Integer;
begin
  i := 0;
  WHILE (i < Celt) and (FIndex < FFormatCount) do
  begin
    TFormatList(Elt)[i] := FFormatList[fIndex];
    Inc(FIndex);
    Inc(i);
  end;
  if pCeltFetched <> NIL then pCeltFetched^ := i;
  if i = Celt then result := S_OK else result := S_FALSE;
end;
// -----------------------------------------------------------------------------

function TEnumFormatEtc.Skip(Celt: LongInt): HRESULT;
begin
  if Celt <= FFormatCount - FIndex then
  begin
    FIndex := FIndex + Celt;
    result := S_OK;
  end else
  begin
    FIndex := FFormatCount;
    result := S_FALSE;
  end;
end;
// -----------------------------------------------------------------------------

function TEnumFormatEtc.ReSet: HRESULT;
begin
  fIndex := 0;
  result := S_OK;
end;
// -----------------------------------------------------------------------------

function TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HRESULT;
begin
  enum := TEnumFormatEtc.Create(FFormatList, FFormatCount, FIndex);
  result := S_OK;
end;

// -----------------------------------------------------------------------------
//			TDropSource
// -----------------------------------------------------------------------------

constructor TDropSource.Create(AOwner: TComponent);
begin
  inherited Create(aOwner);
  FDataFormatsCount := 0;
end;
// -----------------------------------------------------------------------------

function TDropSource.QueryGetData(const FormatEtc: TFormatEtc): HRESULT; stdcall;
var
  i: integer;
begin
  result:= S_OK;
  for i := 0 to FDataFormatsCount-1 do
    with FDataFormats[i] do
    begin
      if (FormatEtc.cfFormat = cfFormat) and
         (FormatEtc.dwAspect = dwAspect) and
         (FormatEtc.tymed and tymed <> 0) then exit; //result:= S_OK;
    end;
  result:= E_FAIL;
end;
// -----------------------------------------------------------------------------

function TDropSource.GetEnumFormatEtc(dwDirection: Integer): IEnumFormatEtc;
begin
  if (dwDirection = DATADIR_GET) then
    Result := TEnumFormatEtc.Create(pFormatList(@FDataFormats), FDataFormatsCount, 0)
  else
    result := nil;
end;
// -----------------------------------------------------------------------------

procedure TDropSource.AddFormatEtc(cfFmt: TClipFormat;
  pt: PDVTargetDevice; dwAsp, lInd, tym: longint);
begin
  if fDataFormatsCount = MAXFORMATS then exit;

  FDataFormats[fDataFormatsCount].cfFormat := cfFmt;
  FDataFormats[fDataFormatsCount].ptd := pt;
  FDataFormats[fDataFormatsCount].dwAspect := dwAsp;
  FDataFormats[fDataFormatsCount].lIndex := lInd;
  FDataFormats[fDataFormatsCount].tymed := tym;
  inc(FDataFormatsCount);
end;
// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------

function TDropSource.HasFormat(const FormatEtc: TFormatEtc): boolean;
begin
  Result := True;
 { TODO -oanme -cStopShip : TDropSource.HasFormat needs implementation }
end;

initialization
  OleInitialize(NIL);
  ShGetMalloc(ShellMalloc);

finalization
  ShellMalloc := nil;
  OleUninitialize;
end.