Obsługa Interfejsu IDropTarget (DragNDrop)

Na pytanie jak przenieść coś z innej aplikacji do naszej, za pomocą myszy (dNd), odpowiedzi są dwie. Albo obsłużyć komunikat windows WM_DROPFILES albo zaimplementowac interfejs IDropTarget.

Jeśli chodzi o pierwszą z możliwości to jej opis znajduje się już w serwisie.

Do zrozumienia wymagana jest już dość dobra znajomość Delphi (i elementy WinAPI).

Oto kod:

Unit1.pas

unit Unit1;
{Reichel Bartosz
http:\\reichel.pl
[email protected]
2006.08.03
}
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, StdCtrls, ComCtrls, Unit2, Spin;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Edit1: TEdit;
    RichEdit1: TRichEdit;
    SpinEdit1: TSpinEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FText:String;
  public
     TDT1:TTextDroptarget;
     TDT2:TTextDroptarget;
     TDT3:TTextDroptarget;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  TDT1 := TTextDroptarget.Create(Memo1.Handle);
  TDT2 := TTextDroptarget.Create(Edit1.Handle);
  TDT3 := TTextDroptarget.Create(SpinEdit1.Handle);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//pamietajmy interfejs sam sie niszczy, wystarczy _Release a ta metode wywoluje RevokeDragDrop
 TDT1.Revoke;
 TDT2.Revoke;
 TDT2.Revoke;
end;

end.

 

Unit1.dfm

object Form1: TForm1
  Left = 246
  Top = 111
  Width = 562
  Height = 370
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Memo1: TMemo
    Left = 8
    Top = 16
    Width = 305
    Height = 233
    Lines.Strings = (
      'Tu mo'#380'esz upu'#347#263'i'#263' tekst')
    TabOrder = 0
  end
  object Edit1: TEdit
    Left = 8
    Top = 264
    Width = 121
    Height = 21
    TabOrder = 1
    Text = 'Edit1'
  end
  object RichEdit1: TRichEdit
    Left = 328
    Top = 16
    Width = 217
    Height = 313
    Lines.Strings = (
      'Tekst z okna RichEdit1, lub innej aplikacji '
      'takiej jak np. wordpad, MS Word mo'#380'e'
      'by'#263' kopiowany (za pomoc'#261' metody '
      'przeci'#261'gnij i upu'#347#263') do okien takich jak'
      'TMemo, TEdit, TSpinEdit i pokrewnych '
      'okna  z klasy EDIT.')
    TabOrder = 2
  end
  object SpinEdit1: TSpinEdit
    Left = 8
    Top = 312
    Width = 121
    Height = 22
    MaxValue = 0
    MinValue = 0
    TabOrder = 3
    Value = 0
  end
end

 

Unit2.pas

unit Unit2;
{Reichel Bartosz
http:\\reichel.pl
[email protected]
2006.08.03
}

interface
uses Windows, Messages, SysUtils, ActiveX;

type
  TTextDroptarget = class(TInterfacedObject,IDropTarget)
  private
    { Private declarations }
    FWindow:THandle;
  public
    { Public declarations }
      constructor create(Handle:THandle);
      destructor Destroy; override;
//IDropTarget < metody interfejsu
      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;
      procedure Revoke;

  end;



implementation


constructor TTextDroptarget.Create(Handle:THandle);
begin
 inherited Create;
 FWindow := Handle;
 RegisterDragDrop(FWindow,Self as IDropTarget);
end;

procedure TTextDroptarget.Revoke;
begin
 RevokeDragDrop(FWindow);
end;


destructor TTextDroptarget.Destroy;
begin
 //tu można niszczy..
 inherited;
end;

function TTextDroptarget.DragEnter(const dataObj:IDataObject;grfKeyState:Longint;pt:TPoint;var dwEffect:Longint):HResult;stdcall;
begin
    Result:=S_OK;
    //czy mozemy upuszczac - powinno byc to bardziej przetestowane - EnumFormatETC
end;

function TTextDroptarget.DragOver(grfKeyState:Longint;pt:TPoint;var dwEffect:Longint):HResult;stdcall;
var
 memopt:TPoint;
 IL:integer;
begin
  dwEffect:=DROPEFFECT_COPY ;
  
  memopt := pt;
  Windows.ScreenToClient(FWindow,memopt);
  //niestety kursor rysuje sie tylko w RichEdit, ktory juz ma obsluge IDropTarget
  //mozna zabawiac sie z kursorem -> CreateCaret ShowCaret
  IL := SendMessage(FWindow, EM_CHARFROMPOS,0,MAKELPARAM(memopt.x, memopt.y));
  SendMessage(FWindow, EM_SETSEL,  Lo(IL),Lo(IL));


  Result:=S_OK;
end;

function TTextDroptarget.DragLeave:HResult;stdcall;
begin
     Result:=S_OK;
end;

function TTextDroptarget.Drop(const dataObj:IDataObject;grfKeyState:Longint;pt:TPoint;var dwEffect:Longint):HResult;stdcall;
var
   Medium:TSTGMedium;
   Format:TFormatETC;
   Data:PChar;
   memopt:TPoint;
   IL:Integer;
begin
     dataObj._AddRef;//mowimy, ze uzywamy tej instancji aby nie zostala skasowana
     Format.cfFormat := CF_TEXT; //chcemy miec tylko tekst -> patrz formaty schowka
     Format.ptd := nil;
     Format.dwAspect := DVASPECT_CONTENT;
     Format.lindex := -1;
     Format.tymed := TYMED_HGLOBAL; //jako uchwyt do pamieci globalnej

     if dataObj.GetData(Format,Medium) = S_OK then
     begin
     
      Data := PChar(GlobalLock(Medium.hGlobal));

      memopt := pt;
      ScreenToClient(FWindow,memopt);
      IL := SendMessage(FWindow, EM_CHARFROMPOS,0,MAKELPARAM(memopt.x, memopt.y));
      //chcemy aby tekst byl upiuszczony w danym miejscu jakiegos komponentu
      //bazujacego na klasie EDIT
      SendMessage(FWindow, EM_SETSEL,  Lo(IL),Lo(IL));
      SendMessage(FWindow, EM_REPLACESEL, 1, Integer(Data));

      GlobalUnlock(Medium.hGlobal);
      ReleaseStgMedium(Medium);

     end;

     dataObj._Release;//teraz niech sie dzieje co sie chce ....

     //efekt -> od niego zalezny jest ksztalt kursora
     dwEffect:=DROPEFFECT_COPY;

     Result:=S_OK;
end;


//startujemy OLE
initialization
   OleInitialize(nil);

finalization
   OleUninitialize;

end.