Obsługa Interfejsu IDropTarget (DragNDrop)
reichel
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
reichel@rudy.mif.pg.gda.pl
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
reichel@rudy.mif.pg.gda.pl
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.