//-----------------------------------------------------------------------------
// Drag & Drop Component
// Copyright (c) 2003 By Mental Studio -- http://mental.mentsu.com
// Author: Raptor.z<raptor@mentsu.com>
// Date: Dec.03-03, Dec.11-03
//-----------------------------------------------------------------------------
unit MOleDragDrop;
interface
uses
SysUtils, Classes, Types, Controls, Windows, ActiveX, ShellAPI, ShlObj, Graphics;
type
TOleDragEnterEvent = procedure (Sender: TObject; aDataObj : IDataObject;
grfKeyState : Integer; pt : TPoint; var dwEffect : Integer;
var feFormat : TFormatEtc ) of object;
TOleDragOverEvent = procedure (Sender: TObject;
grfKeyState : Integer; pt : TPoint; var dwEffect : Integer ) of object;
TOleDragLeaveEvent = TNotifyEvent;
TOleDragDropEvent = procedure (Sender: TObject; aDataObj : IDataObject;
grfKeyState : Integer; pt : TPoint; var dwEffect : Integer;
var feFormat : TFormatEtc ) of object;
TOleTextDropEvent = procedure (Sender: TObject; aText : String ) of object;
TOleFileDropEvent = procedure (Sender: TObject; aFiles : TStrings ) of object;
TOleBitmapDropEvent= procedure (Sender: TObject; aBitmap: TBitmap ) of object;
TMOleDragDrop = class;
TMOleDropTarget = class(TInterfacedObject, IDropTarget )
private
//FRefCount : Integer;
FOwner : TMOleDragDrop;
FCanDrop : HResult;
FDragResult : HResult;
FFormatEtc : TFormatEtc;
function DrawBitmap(aDest: TBitmap; aHandle, aPalette: Cardinal): Boolean;
protected
(*
{ Iunkown }
function _AddRef:integer;stdcall;
function _Release:integer;stdcall;
function QueryInterface(const IID:TGUID;out Obj):HResult;stdcall;
*)
{ IDropTarget }
Function DragEnter( const aDataObj : 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 aDataObj : IDataObject; grfKeyState : Longint; pt : TPoint;
var dwEffect : Longint ) : HResult; stdcall;
public
Constructor Create( aOwner : TMOleDragDrop );
Destructor Destroy; Override;
(*
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
class function NewInstance: TObject; override;
*)
function GetDataText(aDataObj: IDataObject; aFmtEtc: TFormatEtc): String;
function GetDataFiles(aDataObj: IDataObject; aFmtEtc: TFormatEtc; aFiles: TStrings) : Integer;
function GetDataBitmap(aDataObj: IDataObject; aFmtEtc: TFormatEtc; aBitmap: TBitmap) : Boolean;
Property CanDrop : HResult Read FCanDrop;
Property DragResult : HResult Read FDragResult Write FDragResult;
end;
TMOleDragDrop = class(TComponent)
private
{ Private declarations }
FOleDrag : TMOleDropTarget;
FDropControl : TWinControl;
//FEnabledSource : Boolean;
FEnabledTarget : Boolean;
FOnDragEnter : TOleDragEnterEvent;
FOnDragOver : TOleDragOverEvent;
FOnDragLeave : TOleDragLeaveEvent;
FOnDragDrop : TOleDragDropEvent;
FOnTextDrop : TOleTextDropEvent;
FOnFileDrop : TOleFileDropEvent;
FOnURLDrop : TOleTextDropEvent;
FOnHTMLDrop : TOleTextDropEvent;
FOnBitmapDrop: TOleBitmapDropEvent;
Procedure SetDropControl( aValue : TWinControl );
Procedure SetEnabledTarget( aValue : Boolean );
protected
{ Protected declarations }
Procedure Loaded; override;
Procedure Notification( aComponent : TComponent; aOperation : TOperation ); Override;
public
{ Public declarations }
Property OleDrag : TMOleDropTarget Read FOleDrag;
Constructor Create( AComponent : TComponent ); Override;
Destructor Destroy( ); Override;
published
{ Published declarations }
Property DropControl : TWinControl Read FDropControl Write SetDropControl;
Property EnabledTarget : Boolean Read FEnabledTarget Write SetEnabledTarget Default true;
property OnDragEnter : TOleDragEnterEvent Read FOnDragEnter Write FOnDragEnter;
property OnDragOver : TOleDragOverEvent Read FOnDragOver Write FOnDragOver;
property OnDragLeave : TOleDragLeaveEvent Read FOnDragLeave Write FOnDragLeave;
property OnDragDrop : TOleDragDropEvent Read FOnDragDrop Write FOnDragDrop;
property OnTextDrop : TOleTextDropEvent Read FOnTextDrop Write FOnTextDrop;
property OnFileDrop : TOleFileDropEvent Read FOnFileDrop Write FOnFileDrop;
property OnURLDrop : TOleTextDropEvent Read FOnURLDrop Write FOnURLDrop;
property OnHTMLDrop : TOleTextDropEvent Read FOnHTMLDrop Write FOnHTMLDrop;
property OnBitmapDrop: TOleBitmapDropEvent Read FOnBitmapDrop Write FOnBitmapDrop;
end;
Var
CF_URL, CF_HTML : UINT;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MentalCtrls', [TMOleDragDrop]);
end;
{ TMOleDropTarget }
constructor TMOleDropTarget.Create(aOwner: TMOleDragDrop);
begin
FOwner := aOwner;
OleInitialize( Nil );
With FFormatEtc Do
Begin
cfFormat := CF_TEXT;
ptd := Nil;
dwAspect := DVASPECT_CONTENT;
lIndex := -1;
tymed := TYMED_HGLOBAL;
End;
end;
destructor TMOleDropTarget.Destroy;
begin
FOwner.DropControl := Nil;
OleUninitialize;
inherited;
end;
(*
procedure TMOleDropTarget.AfterConstruction;
begin
// Release the constructor's implicit refcount
InterlockedDecrement(FRefCount);
end;
procedure TMOleDropTarget.BeforeDestruction;
begin
if FRefCount <> 0 then
Error(reInvalidPtr);
end;
// Set an implicit refcount so that refcounting
// during construction won't destroy the object.
class function TMOleDropTarget.NewInstance: TObject;
begin
Result := inherited NewInstance;
TInterfacedObject(Result).FRefCount := 1;
end;
{ IUnknown }
function TMOleDropTarget._AddRef: integer;
begin
Result := InterLockedIncrement( FRefCount );
end;
function TMOleDropTarget._Release: integer;
begin
Result := InterLockedDecrement( FRefCount );
If ( Result = 0 ) Then
Destroy;
end;
function TMOleDropTarget.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
If ( GetInterface( IID, Obj ) ) Then
Result := S_OK
Else
Result := E_NOINTERFACE;
end;
*)
{ IDropTarget }
function TMOleDropTarget.DragEnter(const aDataObj: IDataObject;
grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
Var
pEnumFE : IEnumFormatEtc;
fe : TFormatEtc;
nCount : Integer;
nSupports : Boolean;
begin
FDragResult := E_FAIL;
If ( FOwner.FEnabledTarget ) Then
Begin
dwEffect := DROPEFFECT_NONE;
If ( Assigned( FOwner.FOnDragEnter ) ) Then
Begin
FOwner.FOnDragEnter( Self, aDataObj, grfKeyState, pt, dwEffect, FFormatEtc );
fe := FFormatEtc;
End
Else
Begin
aDataObj.EnumFormatEtc( DATADIR_GET, pEnumFE );
nSupports := false;
While ( ( pEnumFE.Next( 1, fe, @nCount ) = S_OK ) AND ( nCount > 0 ) ) Do
Begin
If ( ( fe.ptd = Nil ) AND ( fe.dwAspect = DVASPECT_CONTENT )
AND ( fe.lindex = -1 )
AND ( ( fe.tymed = TYMED_HGLOBAL ) OR ( fe.tymed = TYMED_GDI ) )
AND ( ( ( ( fe.cfFormat = CF_TEXT ) OR ( fe.cfFormat = CF_UNICODETEXT ) )
AND ( Assigned( FOwner.FOnTextDrop ) ) )
OR ( ( fe.cfFormat = CF_HDROP ) AND ( Assigned( FOwner.FOnFileDrop ) ) )
OR ( ( fe.cfFormat = CF_URL ) AND ( Assigned( FOwner.FOnURLDrop ) ) )
OR ( ( fe.cfFormat = CF_HTML ) AND ( Assigned( FOwner.FOnHTMLDrop ) ) )
OR ( ( ( fe.cfFormat = CF_BITMAP ) OR ( fe.cfFormat = CF_DIB ) )
AND ( Assigned( FOwner.FOnBitmapDrop ) ) )
) ) Then
Begin
nSupports := true;
Break;
End;
End;
If ( nSupports ) Then
Begin
FDragResult := aDataObj.QueryGetData( fe );
If ( Not Failed( FDragResult ) ) Then
dwEffect := DROPEFFECT_COPY;
End;
End;
End;
FCanDrop := FDragResult;
Result := FDragResult;
end;
function TMOleDropTarget.DragLeave: HResult;
begin
FDragResult := S_OK;
If ( Assigned( FOwner.FOnDragLeave ) ) Then
FOwner.FOnDragLeave( Self );
Result := FDragResult;
end;
function TMOleDropTarget.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HResult;
begin
FDragResult := S_OK;
If ( Assigned( FOwner.FOnDragOver ) ) Then
FOwner.FOnDragOver( Self, grfKeyState, pt, dwEffect );
Result := FDragResult;
end;
function TMOleDropTarget.Drop(const aDataObj: IDataObject;
grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
pEnumFE : IEnumFormatEtc;
fe : TFormatEtc;
nCount : Integer;
ss : TStrings;
bm : TBitmap;
begin
FDragResult := E_FAIL;
If ( Assigned( FOwner.FOnDragDrop ) ) Then
FOwner.FOnDragDrop( Self, aDataObj, grfKeyState, pt, dwEffect, FFormatEtc )
Else
Begin
aDataObj.EnumFormatEtc( DATADIR_GET, pEnumFE );
While ( ( pEnumFE.Next( 1, fe, @nCount ) = S_OK ) AND ( nCount > 0 ) ) Do
Begin
If ( ( ( fe.cfFormat = CF_TEXT ) (*OR ( fe.cfFormat = CF_UNICODETEXT )*) )
AND ( Assigned( FOwner.FOnTextDrop ) ) ) Then
FOwner.FOnTextDrop( Self, GetDataText( aDataObj, fe ) )
Else If ( ( fe.cfFormat = CF_URL ) AND ( Assigned( FOwner.FOnURLDrop ) ) ) Then
FOwner.FOnURLDrop( Self, GetDataText( aDataObj, fe ) )
Else If ( ( fe.cfFormat = CF_HTML ) AND ( Assigned( FOwner.FOnHTMLDrop ) ) ) Then
FOwner.FOnHTMLDrop( Self, GetDataText( aDataObj, fe ) )
Else If ( ( fe.cfFormat = CF_HDROP ) AND ( Assigned( FOwner.FOnFileDrop ) ) ) Then
Begin
ss := TStringList.Create;
Try
If ( GetDataFiles( aDataObj, fe, ss ) > 0 ) Then
FOwner.FOnFileDrop( Self, ss );
Finally
ss.Free;
End;
End
Else If ( ( ( fe.cfFormat = CF_DIB ) OR ( fe.cfFormat = CF_BITMAP ) )
AND ( Assigned( FOwner.FOnBitmapDrop ) ) ) Then
Begin
bm := TBitmap.Create;
Try
If ( GetDataBitmap( aDataObj, fe, bm ) ) Then
FOwner.FOnBitmapDrop( Self, bm );
Finally
bm.Free;
End;
End;
End;
End;
Result := FDragResult;
end;
function TMOleDropTarget.DrawBitmap(aDest: TBitmap; aHandle, aPalette: Cardinal): Boolean;
// -----------------------------------------------------------------------------
// Miscellaneous DIB Function
//
// From:
// Project: Drag and Drop Component Suite
// Component Names: TDropBMPSource
// Module: DropBMPSource
// Description: Implements Dragging & Dropping of Bitmaps
// FROM your application to another.
// Version: 3.7
// Date: 22-JUL-1999
// Target: Win32, Delphi 3 - Delphi 5, C++ Builder 3, C++ Builder 4
// Authors: Angus Johnson, ajohnson@rpi.net.au
// Anders Melander, anders@melander.dk
// http://www.melander.dk
// Copyright ?1997-99 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
procedure CopyDIBToBitmap(Bitmap: TBitmap; BitmapInfo: PBitmapInfo; DIBSize: integer);
var
BitmapFileHeader : TBitmapFileHeader;
FileSize : integer;
InfoSize : integer;
Stream : TMemoryStream;
begin
// Write DIB to a stream in the BMP file format
Stream := TMemoryStream.Create;
try
FileSize := sizeof(TBitmapFileHeader) + DIBSize;
InfoSize := sizeof(TBitmapInfoHeader);
if (BitmapInfo^.bmiHeader.biBitCount > 8) then
begin
if ((BitmapInfo^.bmiHeader.biCompression and BI_BITFIELDS) <> 0) then
Inc(InfoSize, 12);
end else
Inc(InfoSize, sizeof(TRGBQuad) * (1 shl BitmapInfo^.bmiHeader.biBitCount));
Stream.SetSize(FileSize);
// Initialize file header
FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0);
with BitmapFileHeader do
begin
bfType := $4D42; // 'BM' = Windows BMP signature
bfSize := FileSize; // File size (not needed)
bfOffBits := sizeof(TBitmapFileHeader) + InfoSize; // Offset of pixel data
end;
// Save file header
Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader));
// Save TBitmapInfo structure and pixel data
Stream.Write(BitmapInfo^, DIBSize);
// Rewind and load bitmap from stream
Stream.Position := 0;
Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
begin
If ( aPalette <> 0 ) Then
aDest.LoadFromClipboardFormat( CF_BITMAP, aHandle, aPalette )
Else
Begin
Try
CopyDIBToBitmap( aDest, GlobalLock( aHandle ), GlobalSize( aHandle ) );
Finally
GlobalUnlock( aHandle );
End;
End;
Result := true;
end;
function TMOleDropTarget.GetDataText(aDataObj: IDataObject; aFmtEtc: TFormatEtc): String;
Var
medium : stgMedium;
begin
FDragResult := aDataObj.GetData( aFmtEtc, medium );
Result := String( PChar( GlobalLock( medium.hGlobal ) ) );
if ( ( aFmtEtc.cfFormat = CF_UNICODETEXT ) OR ( aFmtEtc.cfFormat = CF_URL )
OR ( aFmtEtc.cfFormat = CF_HTML ) )
Result = Utf8ToAnsi( Result );
GlobalUnlock( medium.hGlobal );
ReleaseStgMedium( medium );
end;
function TMOleDropTarget.GetDataFiles(aDataObj: IDataObject; aFmtEtc: TFormatEtc;
aFiles: TStrings) : Integer;
Var
medium : stgMedium;
i : Integer;
nCount : Integer;
sBuf : Array [0..MAX_PATH - 1] Of Char;
begin
FDragResult := aDataObj.GetData( aFmtEtc, medium );
Try
i := -1;
nCount := DragQueryFile( medium.hGlobal, i, sBuf, 0 ); // Get the Drag _Files Number.
If ( nCount > 0 ) Then
For i := 0 To nCount - 1 Do
If ( DragQueryFile( medium.hGlobal, i, sBuf, MAX_PATH ) > 0 ) Then
aFiles.Add( String( sBuf ) );
DragFinish( medium.hGlobal );
Finally
ReleaseStgMedium( medium );
End;
Result := aFiles.Count;
end;
function TMOleDropTarget.GetDataBitmap(aDataObj: IDataObject; aFmtEtc: TFormatEtc;
aBitmap: TBitmap) : Boolean;
Var
medium : stgMedium;
medium2 : stgMedium;
begin
Result := true;
FDragResult := aDataObj.GetData( aFmtEtc, medium );
If ( aFmtEtc.cfFormat = CF_BITMAP ) Then
Begin
aFmtEtc.cfFormat := CF_PALETTE;
aDataObj.GetData( aFmtEtc, medium2 );
End
Else
FillChar( medium2, SizeOf( medium2 ), 0 );
Try
DrawBitmap( aBitmap, medium.hBitmap, medium2.hBitmap );
Except
Result := false;
End;
If ( aFmtEtc.cfFormat = CF_PALETTE ) Then
ReleaseStgMedium( medium2 );
ReleaseStgMedium( medium );
end;
{ TMOleDragDrop }
constructor TMOleDragDrop.Create(AComponent: TComponent);
begin
Inherited;
FEnabledTarget := true;
FOleDrag := Nil;
If ( Not ( csDesigning In ComponentState ) ) Then
FOleDrag := TMOleDropTarget.Create( Self );
end;
destructor TMOleDragDrop.Destroy;
begin
DropControl := Nil;
inherited;
end;
procedure TMOleDragDrop.Loaded;
begin
inherited;
If ( Assigned( FOleDrag ) AND Assigned( FDropControl ) ) Then
RegisterDragDrop( FDropControl.Handle, FOleDrag );
end;
Procedure TMOleDragDrop.Notification( aComponent : TComponent;
aOperation : TOperation );
Begin
Inherited Notification( aComponent, aOperation );
If ( ( aComponent = FDropControl ) AND ( aOperation = opRemove ) ) Then
DropControl := Nil;
End;
procedure TMOleDragDrop.SetDropControl(aValue: TWinControl);
begin
If ( aValue <> FDropControl ) Then
Begin
If ( Assigned( FOleDrag ) AND Assigned( FDropControl ) ) Then
Begin
If ( ( aValue = Nil ) AND Assigned( FDropControl.Parent ) ) Then
RevokeDragDrop( FDropControl.Handle );
End;
FDropControl := aValue;
If ( Assigned( FOleDrag ) AND Assigned( FDropControl ) ) Then
RegisterDragDrop( FDropControl.Handle, FOleDrag );
End;
end;
procedure TMOleDragDrop.SetEnabledTarget(aValue: Boolean);
begin
If ( aValue <> FEnabledTarget ) Then
FEnabledTarget := aValue;
end;
Initialization
CF_URL := RegisterClipboardFormat( CFSTR_SHELLURL );
CF_HTML := RegisterClipboardFormat( 'HTML Format' );
end.
