Бывалый
Профиль
Группа: Участник
Сообщений: 180
Регистрация: 16.7.2003
Где: Россия - Уфа
Репутация: нет
Всего: 1
|
Немного недоделано, но всёже работает | Код | {##########################################################}
{# #}
{# Component: TMJOLE (ver. 1.0.1) #}
{# Copyright: MJ Soft 2002 (Russia) FreeWare #}
{# #}
{# Компонент: TMJOLE (версия 1.0.1) #}
{# Написано: MJ Soft 2002 (Россия, г.Уфа) #}
{# Распространение: Бесплатно #}
{# #}
{# http://pascal.dax.ru/delphi/components/ #}
{# e-mail: [email protected] ([email protected]) #}
{# #}
{##########################################################}
unit MJOLE;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Graphics, ActiveX;
type
TOleDragObject = class;
TDragType = (dtCopy, dtMove, dtLink, dtNone);
TDragEvent = procedure(Sender: TObject; State: TDragState;
Source: TOleDragObject; Shift: TShiftState; X, Y: Integer;
var DragType: TDragType) of object;
TDropEvent = procedure(Sender: TObject; Source: TOleDragObject;
Shift: TShiftState; X, Y: Integer; var DragType: TDragType) of object;
TDragContent = (edcText, edcBitmap, edcMetafile, edcFileList, edcOther);
TMJOLE = class(TComponent, IUnknown, IDropTarget)
private
FDragOwner: TWinControl;
FDragOwnerHandle: THandle;
FActive: Boolean;
FNActive: Boolean;
FOnDrag: TDragEvent;
FOnDrop: TDropEvent;
FDragObj: TOleDragObject;
procedure SetDragOwner(const Value: TWinControl);
function GetAboutStr: String;
function GetCopyrightStr: String;
procedure SetActive(const Value: Boolean);
procedure Run;
procedure Stop;
protected
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property About: String read GetAboutStr;
property Copyright: String read GetCopyrightStr;
property DragOwner: TWinControl read FDragOwner write SetDragOwner;
property Active: Boolean read FActive write SetActive;
property OnDrag: TDragEvent read FOnDrag write FOnDrag;
property OnDrop: TDropEvent read FOnDrop write FOnDrop;
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;
end;
TOleDragObject = class(TDragObject)
private
DataObj: IDataObject;
FDataFormats: TStringList;
FKeys: Longint;
protected
function GetText: String;
function GetDragContent: TDragContent;
function GetFileList: String;
function GetBitmap: TBitmap;
function GetStream(Format: Integer): TMemoryStream;
function GethGlobal(Format: Integer): THandle;
public
constructor Create; virtual;
destructor Destroy; override;
function HasDataFormat(Format: Integer): Boolean;
function DataObject: IDataObject;
function AsText(Format: String): String; overload;
function AsText(Format: Word): String; overload;
property Keys: Longint read FKeys;
property DataFormats: TStringList read FDataFormats;
property Text: String read GetText;
property FileList: String read GetFileList;
property Bitmap: TBitmap read GetBitmap;
property Stream[Format: Integer]: TMemoryStream read GetStream;
property hGlobal[Format: Integer]: THandle read GethGlobal;
property Content: TDragContent read GetDragContent;
end;
procedure Register;
implementation
type
PDropFiles = ^TDropFiles;
TDropFiles = record
pfiles: DWORD;
pt: TPOINT;
fNC: BOOL;
fWide: BOOL;
end;
procedure Register;
begin
RegisterComponents('MJ', [TMJOLE]);
end;
function GetFormatName(AFormat: Integer): String;
const
FormatNames: array[1..16] of String = ('TEXT', 'BITMAP', 'METAFILEPICT',
'SYLK', 'DIF', 'TIFF', 'OEMTEXT', 'DIB', 'PALETTE', 'PENDATA', 'RIFF',
'WAVE', 'UNICODETEXT', 'ENHMETAFILE', 'HDROP', 'LOCALE');
begin
if (AFormat>=1) and (AFormat<=16) then
Result := FormatNames[AFormat]
else
begin
SetLength(Result, 128);
SetLength(Result, GetClipboardFormatName(AFormat, PChar(Result), 128));
end;
end;
{ TMJOLE }
constructor TMJOLE.Create(AOwner: TComponent);
begin
inherited;
FActive := False;
FNActive := False;
if AOwner is TWinControl then
FDragOwner := TWinControl(AOwner);
end;
destructor TMJOLE.Destroy;
begin
if FActive then
Stop;
inherited;
end;
function TMJOLE.GetAboutStr: String;
begin
Result := 'Component TMJOLE';
end;
function TMJOLE.GetCopyrightStr: String;
begin
Result := '2002 MJ Soft';
end;
function TMJOLE.DragEnter(const DataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HResult;
var
FormatEtc: IEnumFormatEtc;
Fmt: TFormatEtc;
Shift: TShiftState;
DragEffect: TDragType;
begin
FDragObj := TOleDragObject.Create;
FDragObj.DataObj := DataObj;
FDragObj.FDataFormats.Clear;
if DataObj.EnumFormatEtc(DATADIR_GET, FormatEtc)=S_OK then
while FormatEtc.Next(1, Fmt, nil) = S_OK do
FDragObj.FDataFormats.AddObject(GetFormatName(Fmt.cfFormat), TObject(Fmt.cfFormat));
FDragObj.FKeys := grfKeyState;
Shift := [];
if (MK_LBUTTON and grfKeyState<>0) then Shift := [ssLeft];
if (MK_RBUTTON and grfKeyState<>0) then Shift := Shift + [ssRight];
if (MK_MBUTTON and grfKeyState<>0) then Shift := Shift + [ssMiddle];
if (MK_CONTROL and grfKeyState<>0) then Shift := Shift + [ssCtrl];
if (MK_SHIFT and grfKeyState <> 0) then Shift := Shift + [ssShift];
if ($20 and grfKeyState<>0) then Shift := Shift+[ssAlt];
DragEffect := dtNone;
pt := FDragOwner.ScreenToClient(pt);
if Assigned(FOnDrag) then FOnDrag(Self, dsDragEnter, FDragObj, Shift, pt.X, pt.Y, DragEffect);
case DragEffect of
dtCopy: dwEffect := DROPEFFECT_COPY;
dtMove: dwEffect := DROPEFFECT_MOVE;
dtLink: dwEffect := DROPEFFECT_LINK;
dtNone: dwEffect := DROPEFFECT_NONE;
end;
Result := S_OK;
end;
function TMJOLE.DragLeave: HResult;
var
DragEffect: TDragType;
begin
DragEffect := dtNone;
if Assigned(FOnDrag) then FOnDrag(Self, dsDragLeave, FDragObj, [], -1, -1, DragEffect);
if Assigned(FDragObj) then
begin
FdragObj.Free;
FdragObj := nil;
end;
Result := S_OK;
end;
function TMJOLE.DragOver(grfKeyState: Integer; pt: TPoint;
var dwEffect: Integer): HResult;
var
Shift: TShiftState;
DragEffect: TDragType;
begin
Shift := [];
if (MK_LBUTTON and grfKeyState<>0) then Shift := [ssLeft];
if (MK_RBUTTON and grfKeyState<>0) then Shift := Shift + [ssRight];
if (MK_MBUTTON and grfKeyState<>0) then Shift := Shift + [ssMiddle];
if (MK_CONTROL and grfKeyState<>0) then Shift := Shift + [ssCtrl];
if (MK_SHIFT and grfKeyState<>0) then Shift := Shift + [ssShift];
if ($20 and grfKeyState<>0) then Shift := Shift + [ssAlt];
DragEffect := dtNone;
pt := FDragOwner.ScreenToClient(pt);
if Assigned(FOnDrag) then FOnDrag(Self, dsDragMove, FDragObj, Shift, pt.X, pt.Y, DragEffect);
case DragEffect of
dtCopy: dwEffect := DROPEFFECT_COPY;
dtMove: dwEffect := DROPEFFECT_MOVE;
dtLink: dwEffect := DROPEFFECT_LINK;
else
dwEffect := DROPEFFECT_NONE;
end;
Result := S_OK;
end;
function TMJOLE.Drop(const DataObj: IDataObject; grfKeyState: Integer;
pt: TPoint; var dwEffect: Integer): HResult;
var
Shift: TShiftState;
DragEffect: TDragType;
begin
Shift := [];
if (MK_LBUTTON and grfKeyState<>0) then Shift := [ssLeft];
if (MK_RBUTTON and grfKeyState<>0) then Shift := Shift + [ssRight];
if (MK_MBUTTON and grfKeyState<>0) then Shift := Shift + [ssMiddle];
if (MK_CONTROL and grfKeyState<>0) then Shift := Shift + [ssCtrl];
if (MK_SHIFT and grfKeyState<>0) then Shift := Shift + [ssShift];
if ($20 and grfKeyState<>0) then Shift := Shift + [ssAlt];
DragEffect := dtNone;
pt := FDragOwner.ScreenToClient(pt);
if Assigned(FOnDrop) then FOnDrop(Self, FDragObj, Shift, pt.X, pt.Y, DragEffect);
case DragEffect of
dtCopy: dwEffect := DROPEFFECT_COPY;
dtMove: dwEffect := DROPEFFECT_MOVE;
dtLink: dwEffect := DROPEFFECT_LINK;
dtNone: dwEffect := DROPEFFECT_NONE;
end;
if Assigned(FDragObj) then
begin
FDragObj.Free;
FDragObj := nil;
end;
Result := S_OK;
end;
procedure TMJOLE.SetActive(const Value: Boolean);
begin
if (FActive=Value) then
Exit;
if (FDragOwner=nil) and (Value=True) then
begin
FNActive := True;
Exit;
end;
FNActive := False;
FActive := Value;
if not(csDesigning in ComponentState) then
if Value then
Run
else
Stop;
end;
procedure TMJOLE.SetDragOwner(const Value: TWinControl);
var
RActive: Boolean;
begin
if FDragOwner=Value then
Exit;
RActive := FActive;
Active := False;
FDragOwner := Value;
if RActive or FNActive then
Active := True;
if Value<>nil then
Value.FreeNotification(Self)
end;
procedure TMJOLE.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation=opRemove) and (AComponent=FDragOwner) then
DragOwner := nil;
end;
procedure TMJOLE.Run;
var
HRes: HResult;
Obj: IDropTarget;
begin
FDragOwnerHandle := FDragOwner.Handle;
if not GetInterface(IUnknown, Obj) then
raise Exception.Create('GetInterface failed');
HRes := RegisterDragDrop(FDragOwnerHandle, Obj as IDropTarget);
case HRes of
S_OK, DRAGDROP_E_ALREADYREGISTERED:;
DRAGDROP_E_INVALIDHWND: raise Exception.Create('RegisterDragDrop вернула ошибку, неверный дескриптор окна');
E_OUTOFMEMORY: raise Exception.Create('RegisterDragDrop вернула ошибку, система не выделила память');
E_INVALIDARG: raise Exception.Create('RegisterDragDrop вернула ошибку, невеные аргумента');
CO_E_NOTINITIALIZED: raise Exception.Create('RegisterDragDrop вернула ошибку, coInitialize had not been called');
else
raise Exception.Create('RegisterDragDrop вернула ошибку, неизвестная ошибка с кодом ' + IntToStr(HRes and $7FFFFFFF));
end;
end;
procedure TMJOLE.Stop;
begin
RevokeDragDrop(FDragOwnerHandle);
end;
{ TOleDragObject }
function TOleDragObject.AsText(Format: String): String;
var
Fmt: TFormatEtc;
EFE: IEnumFORMATETC;
FMTCount: Longint;
MDM: TStgMedium;
PCh: PChar;
begin
Result := '';
FillChar(FMT, SizeOf(FMT), 0);
DataObj.EnumFormatEtc(DATADIR_GET, EFE);
EFE.Reset;
repeat
FMTCount := 0;
EFE.Next(1, FMT, @FMTCount);
until (GetFormatName(FMT.cfFormat)=Format) or (FMTCount=0);
if GetFormatName(FMT.cfFormat)<>Format then
Exit;
FMT.tymed := TYMED_HGLOBAL;
FMT.lindex := -1;
if DataObj.GetData(FMT, MDM)=S_OK then
try
if MDM.tymed=TYMED_HGLOBAL then
begin
PCh := GlobalLock(MDM.hGlobal);
Result := StrPas(PCh);
GlobalUnlock(MDM.hGlobal);
end;
finally
if Assigned(MDM.unkForRelease) then
Iunknown(MDM.unkForRelease)._Release;
end;
end;
function TOleDragObject.AsText(Format: Word): String;
var
Fmt: TFormatEtc;
EFE: IEnumFORMATETC;
FMTCount: Longint;
MDM: TStgMedium;
PCh: PChar;
begin
Result := '';
FillChar(FMT, SizeOf(FMT), 0);
DataObj.EnumFormatEtc(DATADIR_GET, EFE);
EFE.Reset;
repeat
FMTCount := 0;
EFE.Next(1, FMT, @FMTCount);
until (FMT.cfFormat=Format) or (FMTCount=0);
if FMT.cfFormat<>Format then
Exit;
FMT.tymed := TYMED_HGLOBAL;
FMT.lindex := -1;
if DataObj.GetData(FMT, MDM)=S_OK then
try
if MDM.tymed=TYMED_HGLOBAL then
begin
PCh := GlobalLock(MDM.hGlobal);
Result := StrPas(PCh);
GlobalUnlock(MDM.hGlobal);
end;
finally
if Assigned(MDM.unkForRelease) then
Iunknown(MDM.unkForRelease)._Release;
end;
end;
constructor TOleDragObject.Create;
begin
inherited;
FDataFormats := TStringList.Create;
end;
function TOleDragObject.DataObject: IDataObject;
begin
Result := DataObj;
end;
destructor TOleDragObject.Destroy;
begin
FDataFormats.Free;
inherited;
end;
function TOleDragObject.GetBitmap: TBitmap;
var
mdm: TStgMedium;
fmt: TFormatEtc;
Pict: TBitmap;
Data: THandle;
Palette: HPALETTE;
EnumFormatEtc: IEnumFormatEtc;
begin
Result := nil;
if not (Assigned(DataObj) and HasDataFormat(CF_BITMAP)) then Exit;
if DataObj.EnumFormatEtc(DATADIR_GET, EnumFormatEtc)<>S_OK then Exit;
Pict := TBitmap.Create;
EnumFormatEtc.Reset;
while EnumFormatEtc.Next(1, fmt, nil)=S_OK do
begin
if fmt.cfFormat=CF_BITMAP then
begin
try
if (DataObj.GetData(fmt, mdm)<>S_OK) or (mdm.tymed<>TYMED_GDI) then
begin
Pict.Free;
Exit;
end;
Data := mdm.hBitmap;
finally
if Assigned(mdm.unkForRelease) then
Iunknown(mdm.unkForRelease)._Release;
end;
if mdm.tymed<>TYMED_GDI then
begin
Pict.Free;
Exit;
end;
EnumFormatEtc.Reset;
Palette := 0;
FillChar(fmt, SizeOf(fmt), 0);
try
Pict.LoadFromClipboardFormat(CF_BITMAP, Data, Palette);
Result := Pict;
except
end;
Exit;
end;
end;
Pict.Free;
end;
function TOleDragObject.GetDragContent: TDragContent;
begin
if HasDataFormat(CF_ENHMETAFILE) then
Result := edcMetaFile
else if HasDataFormat(CF_METAFILEPICT) then
Result := edcMetaFile
else if HasDataFormat(CF_BITMAP) then
Result := edcBitmap
else if HasDataFormat(CF_HDROP) then
Result := edcFileList
else if HasDataFormat(CF_TEXT) then
Result := edcText
else
Result := edcOther;
end;
function TOleDragObject.GetFileList: String;
var
mdm: TStgMedium;
pz: pchar;
pdf: PDropFiles;
fmt: TFormatEtc;
s: string;
begin
Result := '';
if (not Assigned(DataObj)) or (not HasDataFormat(CF_HDROP)) then Exit;
FillChar(fmt, SizeOf(fmt), 0);
fmt.cfFormat := CF_HDROP;
fmt.tymed := TYMED_HGLOBAL;
fmt.lindex := -1;
if DataObj.GetData(fmt, mdm)<>S_OK then Exit;
try
if mdm.tymed=TYMED_HGLOBAL then
begin
pdf := GlobalLock(mdm.hGlobal);
pz := PChar(pdf);
Inc(pz, pdf^.pfiles);
if not (pdf.fWide) then
while (pz[0]<>#0) do
begin
Result := Result+String(pz)+#13#10;
Inc(pz, 1+StrLen(pz));
end
else
while (pz[0] <> #0) do
begin
s := WideCharToString(PWideChar(pz));
Result := Result+s+#13#10;
Inc(pz, Length(s)*2+2);
end;
GlobalUnlock(mdm.HGlobal);
end;
finally
if Assigned(mdm.unkForRelease) then
IUnknown(mdm.unkForRelease)._Release;
end;
end;
function TOleDragObject.GethGlobal(Format: Integer): THandle;
var
mdm: TStgMedium;
fmt: TFormatEtc;
begin
Result := THandle(-1);
if (not Assigned(DataObj)) or (not HasDataFormat(Format)) then Exit;
FillChar(fmt, SizeOf(fmt), 0);
fmt.cfFormat := Format;
fmt.tymed := TYMED_HGLOBAL;
fmt.lindex := -1;
if DataObj.GetData(fmt, mdm)<>S_OK then Exit;
if mdm.tymed=TYMED_HGLOBAL then
Result := mdm.hGlobal;
if Assigned(mdm.unkForRelease) then
IUnknown(mdm.unkForRelease)._Release;
end;
function TOleDragObject.GetStream(Format: Integer): TMemoryStream;
var
mdm: TStgMedium;
pdf: Pointer;
sdf: DWORD;
fmt: TFormatEtc;
S: TMemoryStream;
begin
Result := nil;
if (not Assigned(DataObj)) or (not HasDataFormat(Format)) then Exit;
FillChar(fmt, SizeOf(fmt), 0);
fmt.cfFormat := Format;
fmt.tymed := TYMED_HGLOBAL;
fmt.lindex := -1;
if DataObj.GetData(fmt, mdm)<>S_OK then Exit;
try
if mdm.tymed=TYMED_HGLOBAL then
begin
pdf := GlobalLock(mdm.hGlobal);
sdf := GlobalSize(mdm.hGlobal);
try
S := TMemoryStream.Create;
try
S.Size := sdf;
Move(pdf^, S.Memory^, sdf);
Result := S;
except
S.Free;
end;
finally
GlobalUnlock(mdm.HGlobal);
end;
end;
finally
if Assigned(mdm.unkForRelease) then
IUnknown(mdm.unkForRelease)._Release;
end;
end;
function TOleDragObject.GetText: String;
var
FMT: TFormatEtc;
EFE: IEnumFORMATETC;
FMTCount: Longint;
MDM: TStgMedium;
PCh: PChar;
begin
Result := '';
FillChar(FMT, SizeOf(FMT), 0);
DataObj.EnumFormatEtc(DATADIR_GET, EFE);
EFE.Reset;
repeat
FMTCount := 0;
EFE.Next(1, FMT, @FMTCount);
until (FMT.cfFormat=CF_TEXT) or (FMTCount=0);
if FMT.cfFormat<>CF_TEXT then
Exit;
FMT.tymed := TYMED_HGLOBAL;
FMT.lindex := -1;
if DataObj.GetData(FMT, MDM)=S_OK then
try
if (FMT.cfFormat=CF_TEXT) and (MDM.tymed=TYMED_HGLOBAL) then
begin
PCh := GlobalLock(MDM.hGlobal);
Result := StrPas(PCh);
GlobalUnlock(MDM.hGlobal);
end;
finally
if Assigned(MDM.unkForRelease) then
Iunknown(MDM.unkForRelease)._Release;
end;
end;
function TOleDragObject.HasDataFormat(Format: Integer): Boolean;
var
FMT: TFormatEtc;
EFE: IEnumFORMATETC;
FMTCount: Longint;
begin
if not Assigned(DataObj) then
begin
Result := False;
Exit;
end;
FillChar(FMT, SizeOf(FMT), 0);
DataObj.EnumFormatEtc(DATADIR_GET, EFE);
EFE.Reset;
repeat
FMTCount := 0;
if EFE.Next(1, FMT, @FMTCount)<>S_OK then Break;
until (FMT.cfFormat=Format) or (FMTCount=0);
Result := (FMT.cfFormat=Format);
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
|
Это сообщение отредактировал(а) pascal - 9.8.2003, 17:04 |
Drag and Drop 
Загрузка ...
