www.pudn.com > TMS.Component.Pack.v5.0.rar > adveddd.pas, change:2009-01-24,size:19437b

{*************************************************************************} 
{ Drag'n'drop interface support file                                      } 
{ for Delphi 5,6,7,2005,2006 & C++Builder 5,6,2006                        } 
{                                                                         } 
{ written by TMS Software                                                 } 
{            copyright © 1996-2003                                        } 
{            Email : info@tmssoftware.com                                 } 
{            Web : http://www.tmssoftware.com                             } 
{                                                                         } 
{ The source code is given as is. The author is not responsible           } 
{ for any possible damage done due to the use of this code.               } 
{ The component can be freely used in any application. The complete       } 
{ source code remains property of the author and may not be distributed,  } 
{ published, given or sold in any form as such. No parts of the source    } 
{ code can be included in any other component or application without      } 
{ written authorization of the author.                                    } 
{*************************************************************************} 
 
unit AdvEddd; 
 
{$H+} 
 
{$I TMSDEFS.INC} 
{$H+} 
 
{$IFDEF VER125} 
 {$HPPEMIT '#include <oleidl.h>'} 
{$ENDIF} 
 
{$IFDEF VER130} 
 {$HPPEMIT '#include <oleidl.h>'} 
{$ENDIF} 
 
{$IFDEF VER140} 
  {$IFDEF BCB} 
  {$HPPEMIT '#include <oleidl.h>'} 
  {$ENDIF} 
{$ENDIF} 
 
{$IFDEF VER180} 
  {$HPPEMIT '#include <oleidl.h>'} 
{$ENDIF} 
 
interface 
 
{$IFNDEF TMSDOTNET} 
uses 
  Windows, Messages, ActiveX, StdCtrls, Classes, 
  Controls, SysUtils, Forms, ShlObj; 
 
const 
  deNone   = DROPEFFECT_NONE; 
  deMove   = DROPEFFECT_MOVE; 
  deCopy   = DROPEFFECT_COPY; 
  deLink   = DROPEFFECT_LINK; 
  deScroll = DROPEFFECT_SCROLL; 
  ddGet = DATADIR_GET; 
  ddSet = DATADIR_SET; 
 
  tsGlobal       = TYMED_HGLOBAL;   // handle to global memory clock 
  tsFile         = TYMED_FILE;      // file 
  tsStream       = TYMED_ISTREAM;   // stream interface 
  tsStorage      = TYMED_ISTORAGE;  // storage interface 
  tsGDI          = TYMED_GDI;       // gdi object 
  tsMetafilePict = TYMED_MFPICT;    // metafilepict structure 
  tsEnhMetafile  = TYMED_ENHMF;     // enhanced metafile 
  tsNull         = TYMED_NULL;      // no storage 
 
 
type 
  TEnumFormats = class 
  private 
    FDataObject : IDataObject; 
    FEnumerator : IEnumFormatEtc; 
    FFormatEtc  : TFormatEtc; 
    FValid      : boolean; 
    FCount      : integer; 
    FFiles      : TStringList; 
    procedure SetDataObject (Value : IDataObject); 
    function SomeText (Format : TClipFormat) : string; 
    function SomeFiles(var Files:TStringList):boolean; 
    function GetAspect:integer; 
    procedure SetAspect(value:integer); 
    function GetcfFormat:TClipFormat; 
    procedure SetcfFormat(value:TClipFormat); 
    function GetlIndex:integer; 
    procedure SetlIndex(value:integer); 
    function GetTymed:integer; 
    procedure SetTymed(value:integer); 
  public 
    constructor Create (DataObject : IDataObject); 
    destructor Destroy; override; 
    function Reset : boolean; 
    function Next : boolean; 
    function HasFormat (ClipFormat : TClipFormat) : boolean; 
    function Handle (Tymed : integer): hGlobal; 
    function GlobalHandle : hGlobal; 
    function HasText : boolean; 
    function HasFile : boolean; 
    function HasRTF : boolean; 
    function Text : string; 
    function RTF : string; 
    property Count : integer read FCount; 
    property DataObject : IDataObject read FDataObject write SetDataObject; 
    property Valid : boolean read FValid; 
    property FormatEtc : TFormatEtc read FFormatEtc; 
    property Aspect : integer read GetAspect write SetAspect; 
    property Format : TClipFormat read GetcfFormat write SetcfFormat; 
    property Index : integer read GetlIndex write SetlIndex; 
    property Medium : integer read GetTymed write SetTymed; 
  end; 
 
  TAEDropTarget = class (TInterfacedObject, 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; 
  private 
    FOk : boolean; 
  public 
    constructor Create; 
    procedure DropText(pt:TPoint;s:string); virtual; 
    procedure DropRTF(pt:TPoint;s:string); virtual; 
    procedure DropFiles(pt:TPoint;Files:TStrings); virtual; 
    procedure DragMouseMove(pt:TPoint;var Allow:boolean); virtual; 
  end; 
 
  TAEDropSource = class (TInterfacedObject, IDropSource) 
  private 
    fNoAccept:boolean; 
  public 
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall; 
    function GiveFeedback(dwEffect: Longint): HResult; stdcall; 
  end; 
 
  TSourceDataObject = class (TInterfacedObject, IDataObject) 
  private 
    textdata:string; 
    rtfdata:string; 
  public 
    constructor Create(const stxt,srtf:string); 
  public 
    function GetData(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall; 
    function GetDataHere (const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall; 
    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall; 
    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall; 
    function GetCanonicalFormatEtc(const formatetcIn: TFormatEtc;   out formatetcOut: TFormatEtc): HResult; stdcall; 
    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall; 
    function DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall; 
    function DUnadvise(dwConnection: Longint): HResult; stdcall; 
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall; 
  end; 
 
  TSourceEnumFormatEtc = class (TInterfacedObject, IEnumFormatEtc) 
  protected 
    FIndex : integer; // Next FormatEtc to get 
  public 
    function Next (CountRequested: Longint; out FormatEtcArray; PCountFetched: PLongint): HResult; stdcall; 
    function Skip (count: Longint) : HResult; stdcall; 
    function Reset : HResult; stdcall; 
    function Clone (out enumFmt : IEnumFormatEtc) : HResult; stdcall; 
  end; 
 
  TFormatEtcArray = array[0..19] of TFormatEtc; 
  PFormatEtcArray = ^TFormatEtcArray; 
 
 
function StandardEffect (Keys : TShiftState) : integer; 
function StartTextDoDragDrop(stxt,srtf:string;dwOKEffects: Longint; var dwEffect: Longint): HResult; 
procedure SetRTFAware(value:boolean); 
 
{$ENDIF} 
implementation 
{$IFNDEF TMSDOTNET} 
var 
  CF_RTF : integer; 
  RTFAware:boolean; 
 
procedure SetRTFAware(value:boolean); 
begin 
 RTFAware:=value; 
end; 
 
function StandardEffect (Keys : TShiftState) : integer; 
begin 
  Result := deMove; 
  if ssCtrl in Keys then 
    Result := deCopy 
end; 
 
constructor TEnumFormats.Create (DataObject : IDataObject); 
begin 
  inherited Create; 
  SetDataObject (DataObject); 
  FFiles:=TStringList.Create; 
 
  if OpenClipBoard(0) then 
    begin 
     CF_RTF:=RegisterClipboardformat('Rich Text Format'); 
     CloseClipBoard; 
    end; 
end; 
 
destructor TEnumFormats.Destroy; 
begin 
  SetDataObject (nil); 
  FFiles.Free; 
  inherited Destroy 
end; 
 
function TEnumFormats.Next : boolean; 
var 
  Returned : integer; 
begin 
  inc (FCount); 
  FValid := FEnumerator.Next (1, FFormatEtc, @Returned) = S_OK; 
  Result := FValid 
end; 
 
function TEnumFormats.Reset : boolean; 
begin 
  FValid := false; 
  FCount := 0; 
  Result := Succeeded (FEnumerator.Reset) 
end; 
 
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 
  FDataObject := nil; 
  FDataObject := Value; 
  if Assigned (FDataObject) then 
  begin 
    Result := FDataObject.EnumFormatEtc (ddGet, FEnumerator); 
    Assert (Succeeded (Result), 'Cannot get the format enumerator'); 
    Reset 
  end 
end; 
 
function TEnumFormats.Handle (Tymed : integer): hGlobal; 
var 
  FormatEtc : TFormatEtc; 
  Medium : TStgMedium; 
begin 
  Result := 0; 
  if FValid and (FFormatEtc.tymed and Tymed = Tymed) then 
  begin 
    FormatEtc := FFormatEtc; 
    FormatEtc.tymed := FormatEtc.tymed and Tymed; // use only the requested type 
    if Succeeded (FDataObject.GetData (FormatEtc, Medium)) then 
      Result := Medium.hGlobal 
  end 
end; 
 
function TEnumFormats.GlobalHandle : hGlobal; 
begin 
  Result := Handle (tsGlobal) 
end; 
 
function TEnumFormats.SomeText (Format : TClipFormat) : string; 
var 
  H : hGlobal; 
  P : PChar; 
begin 
  Result := ''; 
  if HasFormat (Format) then 
  begin 
    H := GlobalHandle; 
    if H <> 0 then 
    begin 
      P := GlobalLock (H); 
      try 
        Result := P 
      finally 
        GlobalUnLock (H) 
      end 
    end 
  end 
end; 
 
function TEnumFormats.SomeFiles(var Files: TStringList): boolean; 
var 
  DropFiles:PDropFiles; 
  Filename:PChar; 
  s:string; 
  H:hGlobal; 
 
begin 
  FFiles.Clear; 
 
  H:= GlobalHandle; 
  if H<>0 then 
   begin 
    DropFiles := PDropFiles(GlobalLock(H)); 
    try 
     Filename := PChar(DropFiles) + DropFiles^.pFiles; 
     while (Filename^ <> #0) do 
     begin 
       if (DropFiles^.fWide) then // -> NT4 compatability 
       begin 
         s := WideCharToString(PWideChar(Filename)); 
          inc(Filename, (Length(s) + 1) * 2); 
        end else 
       begin 
         s := StrPas(Filename); 
          inc(Filename, Length(s) + 1); 
       end; 
        Files.Add(s); 
      end; 
   finally 
      GlobalUnlock(H); 
   end; 
  end; 
 
 if Files.count > 0 then 
 result := true else 
 result := false; 
end; 
 
function TEnumFormats.RTF : string; 
begin 
 Result := SomeText(CF_RTF); 
end; 
 
function TEnumFormats.Text : string; 
begin 
 Result := SomeText(CF_TEXT) 
end; 
 
function TEnumFormats.HasText : boolean; 
begin 
 Result := HasFormat(CF_TEXT) 
end; 
 
function TEnumFormats.HasRTF : boolean; 
begin 
 Result := HasFormat(CF_RTF); 
end; 
 
function TEnumFormats.HasFile : boolean; 
begin 
 Result := HasFormat(CF_HDROP) 
end; 
 
constructor TAEDropTarget.Create; 
begin 
 inherited Create; 
end; 
 
function TAEDropTarget.DragEnter (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; 
begin 
  with TEnumFormats.Create (DataObj) do 
  try 
    FOk := HasText or HasFile or (HasRTF and RTFAware); 
  finally 
    Free 
  end; 
 
  if FOk then 
    dwEffect := StandardEffect (KeysToShiftState (grfKeyState)) 
  else 
    dwEffect := deNone; 
  Result := NOERROR; 
end; 
 
function TAEDropTarget.DragOver (grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; 
var 
 allow:boolean; 
begin 
  if FOk then 
    dwEffect := StandardEffect (KeysToShiftState (grfKeyState)) 
  else 
    dwEffect := deNone; 
 
  allow:=true;   
  DragMouseMove(pt,allow); 
  if not allow then dwEffect:=deNone; 
 
  Result := NOERROR; 
end; 
 
function TAEDropTarget.DragLeave: HResult; 
begin 
  Result := NOERROR 
end; 
 
function TAEDropTarget.Drop (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; 
begin 
  if FOk then 
  begin 
    with TEnumFormats.Create(DataObj) do 
    try 
     if HasRTF and RTFAware then DropRTF(pt,RTF) 
     else 
     if HasText then DropText(pt,Text); 
     if HasFile then 
       begin 
        SomeFiles(fFiles); 
        DropFiles(pt,fFiles); 
       end; 
    finally 
      Free 
    end; 
 
    dwEffect := StandardEffect (KeysToShiftState (grfKeyState)) 
  end else 
    dwEffect := deNone; 
 
  Result := NOERROR 
end; 
 
procedure TAEDropTarget.DropText(pt:tpoint;s:string); 
begin 
end; 
 
procedure TAEDropTarget.DropRTF(pt:tpoint;s:string); 
begin 
end; 
 
procedure TAEDropTarget.DropFiles(pt:tpoint;files:tstrings); 
begin 
end; 
 
procedure TAEDropTarget.DragMouseMove(pt: TPoint; var Allow: boolean); 
begin 
 allow:=true; 
end; 
 
 
 
 
function TSourceEnumFormatEtc.Next (CountRequested: Longint; out FormatEtcArray; PCountFetched: PLongint): HResult; 
Var 
  N: integer; 
  FormatEtcArrayOut: TFormatEtcArray absolute FormatEtcArray; 
Label the_end; 
Begin 
  Result := S_FALSE; 
 
  N := 0; 
  while (N  CountRequested) and (N+FIndex  3) do 
  Begin 
    Case N+Findex of 
     0:Begin 
        formatetcArrayOut[0].cfFormat := CF_TEXT; 
        formatetcArrayOut[0].ptd      := nil; 
        formatetcArrayOut[0].dwAspect := DVASPECT_CONTENT; 
        formatetcArrayOut[0].lindex   := -1; 
        formatetcArrayOut[0].tymed    := TYMED_HGLOBAL; 
      end; 
    1:Begin 
        formatetcArrayOut[0].cfFormat := CF_UNICODETEXT; 
        formatetcArrayOut[0].ptd      := nil; 
        formatetcArrayOut[0].dwAspect := DVASPECT_CONTENT; 
        formatetcArrayOut[0].lindex   := -1; 
        formatetcArrayOut[0].tymed    := TYMED_HGLOBAL; 
      end; 
 
    2:Begin 
        formatetcArrayOut[0].cfFormat := CF_RTF; 
        formatetcArrayOut[0].ptd      := nil; 
        formatetcArrayOut[0].dwAspect := DVASPECT_CONTENT; 
        formatetcArrayOut[0].lindex   := -1; 
        formatetcArrayOut[0].tymed    := TYMED_HGLOBAL; 
      end; 
     end; 
    Inc(FIndex); 
    Inc(N); 
  end; 
  If PCountFetched <> nil then PCountFetched^ := N; 
  if N = CountRequested then Result := S_OK; 
 
end; 
 
function TSourceEnumFormatEtc.Skip (count: Longint) : HResult; 
Begin 
  FIndex := FIndex + count; 
  If FIndex > 3 then {changed from 2 to 3} 
    Begin 
      FIndex := 3; 
      Result := S_FALSE; 
    end 
  else Result := S_OK; 
end; 
 
function TSourceEnumFormatEtc.Reset : HResult; 
Begin 
  FIndex := 0; 
  Result := S_OK; 
end; 
 
function TSourceEnumFormatEtc.Clone (out enumFmt : IEnumFormatEtc) : HResult; stdcall; 
Var 
  MyFormatEtc: TSourceEnumFormatEtc; 
Begin 
  MyFormatEtc := TSourceEnumFormatEtc.Create; 
  enumFmt := MyFormatEtc; 
  Result := S_OK; 
end; 
 
constructor TSourceDataObject.Create(const stxt,srtf:string); 
begin 
 inherited Create; 
 textdata:=stxt; 
 rtfdata:=srtf; 
end; 
 
function TSourceDataObject.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; 
Begin 
 if dwDirection <> DATADIR_GET then 
  Begin 
    enumFormatEtc := nil; 
    Result := E_NOTIMPL; 
    exit; 
  end; 
 enumFormatEtc := TSourceEnumFormatEtc.Create; 
 Result := S_OK; 
end; 
 
 
function TSourceDataObject.QueryGetData(const formatetc: TFormatEtc): HResult; 
Begin 
 Result := DV_E_FORMATETC; 
 if (formatetc.dwAspect = DVASPECT_CONTENT) and 
    ((formatetc.cfFormat = CF_TEXT) or (formatetc.cfFormat = CF_UNICODETEXT) or ((formatetc.cfFormat = CF_RTF) and RTFAware)) and 
    (formatetc.tymed = TYMED_HGLOBAL) then Result := S_OK; 
end; 
 
function TSourceDataObject.GetData(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; 
Var 
  HGlobalData: HGlobal; 
  PGlobalData: PChar; 
  AllocLen: integer; 
  RTFLen : integer; 
  TXTLen : integer; 
Label the_end; 
Begin 
  Result:=DV_E_FORMATETC; 
  medium.tymed:=0; 
  medium.hGlobal:=0; 
  medium.unkForRelease:=nil; 
 
  If (QueryGetData(formatetc)<>S_OK) then goto the_end; 
 
  medium.tymed:=TYMED_HGLOBAL; 
 
  TXTLen:=Length(textdata); 
  RTFLen:=Length(rtfdata); 
 
  case formatetc.cfFormat of 
  CF_TEXT:AllocLen:=TXTLen+1; 
  CF_UNICODETEXT:AllocLen:=TXTLen*2+2; 
  else AllocLen:=0; 
  end; 
 
  if (formatetc.cfFormat=CF_RTF) then AllocLen:=RTFLen; 
 
  HGlobalData:=GlobalAlloc((GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT), AllocLen); 
  if (HGlobalData<>0) then 
  begin 
    PGlobalData := GlobalLock (HGlobalData); // lock while we are using it 
    case formatetc.cfFormat of 
    CF_TEXT:StrCopy(PGlobalData, PChar(textdata)); 
    CF_UNICODETEXT:StringToWideChar(textdata, PWideChar(PGlobalData), AllocLen+1); 
    end; 
 
    if (formatetc.cfFormat = CF_RTF) then StrCopy(PGlobalData, PChar(rtfdata)); 
 
    GlobalUnlock (HGlobalData); 
    medium.hGlobal := HGlobalData; 
    Result := S_OK; 
  end; 
the_end: 
 
end; 
 
function TSourceDataObject.GetDataHere (const formatetc: TFormatEtc; out medium: TStgMedium): HResult; 
Begin 
  Result := DV_E_FORMATETC; 
end; 
 
function TSourceDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; 
Begin 
  Result := DV_E_FORMATETC; 
end; 
 
function TSourceDataObject.GetCanonicalFormatEtc(const formatetcIn: TFormatEtc;   out formatetcOut: TFormatEtc): HResult; 
Begin 
  formatetcOut.ptd := nil; 
  Result := E_NOTIMPL; 
end; 
 
function TSourceDataObject.DAdvise(const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall; 
Begin 
  Result := OLE_E_ADVISENOTSUPPORTED; 
end; 
 
function TSourceDataObject.DUnadvise(dwConnection: Longint): HResult; stdcall; 
Begin 
  Result := OLE_E_ADVISENOTSUPPORTED; 
end; 
 
function TSourceDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall; 
Begin 
  Result := OLE_E_ADVISENOTSUPPORTED; 
end; 
 
function TAEDropSource.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; 
//------------------------------------------------------- 
Begin 
  Result := S_OK; 
  If fEscapePressed then Result := DRAGDROP_S_CANCEL else 
    if ((grfKeyState and MK_LBUTTON) = 0) then // mouse-up 
      Result := DRAGDROP_S_DROP; 
end; 
 
function TAEDropSource.GiveFeedback(dwEffect: Longint): HResult; 
Begin 
  fNoAccept:=dwEffect=DROPEFFECT_NONE; 
  Result:=DRAGDROP_S_USEDEFAULTCURSORS; 
end; 
 
function StartTextDoDragDrop(stxt,srtf:string;dwOKEffects: Longint; var dwEffect: Longint): HResult; 
Var 
  DropSource   : TAEDropSource;     // Pascal versions for debugging purposes 
  DataObject   : TSourceDataObject; 
  MyIDropSource: IDropSource;     // Ixxx versions to generate references 
  MyIDataObject: IDataObject; 
 
Begin 
  DropSource     := TAEDropSource.Create; 
  MyIDropSource  := DropSource; 
 
  DataObject     := TSourceDataObject.Create(stxt,srtf); 
  MyIDataObject  := DataObject; 
 
  Result := activex.DoDragDrop(MyIDataObject, MyIDropSource, dwOKEffects, dwEffect); 
 
  if DropSource.fNoAccept then Result:=DRAGDROP_S_CANCEL; 
end; 
 
function TEnumFormats.GetAspect: integer; 
begin 
 result:=FFormatEtc.dwAspect; 
end; 
 
function TEnumFormats.GetcfFormat: TClipFormat; 
begin 
 result:=FFormatEtc.cfFormat; 
end; 
 
function TEnumFormats.GetlIndex: integer; 
begin 
 result:=FFormatEtc.lIndex; 
end; 
 
function TEnumFormats.GetTymed: integer; 
begin 
 result:=FFormatEtc.Tymed; 
end; 
 
procedure TEnumFormats.SetAspect(value: integer); 
begin 
 FFormatEtc.dwAspect:=value; 
end; 
 
procedure TEnumFormats.SetcfFormat(value: TClipFormat); 
begin 
 FFormatEtc.cfFormat:=value; 
end; 
 
procedure TEnumFormats.SetlIndex(value: integer); 
begin 
 FFormatEtc.lIndex:=value; 
end; 
 
procedure TEnumFormats.SetTymed(value: integer); 
begin 
 FFormatEtc.Tymed:=value; 
end; 
 
initialization 
 RTFAware:=false; 
 CF_RTF:=0; 
{$ENDIF} 
end.