unit ClpBrdFiles;
interface
uses
System.SysUtils,
System.Classes,
Vcl.Controls,
Winapi.Windows,
Winapi.Messages,
System.Variants,
System.Generics.Collections,
Winapi.ShlObj,
Clipbrd,
Winapi.ActiveX,
Vcl.AxCtrls;
type
//Record stored File and Filecontent as Stream
TClipboardFile =
Record
Filename:
string;
// Filename
FileStream: TMemoryStream;
// Content
End;
TClipboardFilesList = TList<TClipboardFile>;
// List of Record
TNotifyClipboardEvent =
procedure of object;
// Event Type
TClpBrdFiles =
class(TComponent)
// Component
private
CF_FILECONTENTS : UINT;
CF_FILEDESCRIPTOR : UINT;
CF_FileGroupDescriptor : UINT;
CF_FileGroupDescriptorW: UINT;
NextWnd: HWND;
// next window
fHWnd : HWND;
// himself
fFiles:TClipboardFilesList;
// Instance of List of Record
fFilesCount:integer;
// count of files
fNotifyClipboardEvent: TNotifyClipboardEvent;
// Callback Event
function GetMessageCount(
const dataObj: IDataObject): integer;
// Load
procedure SaveMessage(
const dataObj: IDataObject; Stream:TMemoryStream;
Index : Integer);
//Save
procedure EmptyList;
// Clear List
function getFileNameByIndex(
index: integer):
string;
// getter
function getFileStreamByIndex(
Index: integer): TStream;
// getter
protected
procedure WndMethod(
var Msg: TMessage);
virtual;
public
constructor Create(AOwner:TComponent);
override;
destructor destroy;
override;
procedure WMCHANGECBCHAIN(Msg:TMessage);
procedure WMDRAWCLIPBOARD(Msg:TMessage);
property Count:integer
read fFilesCount;
// read only property
property FileNameByIndex[
index:integer]:
string read getFileNameByIndex;
property FileStreamByIndex[
Index:integer]:TStream
read getFileStreamByIndex;
published
property NotifyClipboardEvent:TNotifyClipboardEvent
read fNotifyClipboardEvent
write fNotifyClipboardEvent;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
MSch', [TClpBrdFiles]);
end;
// Create Constructor
// initialize the component and create a window handle
// and register the clipboard formats
constructor TClpBrdFiles.Create(AOwner: TComponent);
begin
inherited create(AOwner);
fFiles:= TClipboardFilesList.Create;
fHWnd := AllocateHWnd(WndMethod);
CF_FileContents := $8000
Or RegisterClipboardFormat(CFSTR_FILECONTENTS)
And $7FFF;
CF_FileGroupDescriptor := $8000
Or RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA)
And $7FFF;
CF_FileGroupDescriptorW := $8000
Or RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW)
And $7FFF;
NextWnd := SetClipboardViewer(fHwnd);
end;
// release the component
destructor TClpBrdFiles.destroy;
begin
ChangeClipboardChain(fHWND, NextWnd);
EmptyList;
fFiles.Free;
DeallocateHWnd(fHWnd);
inherited;
end;
// clear the list
procedure TClpBrdFiles.EmptyList;
var
I:Integer;
begin
for I := 0
to fFiles.Count-1
do
fFiles[i].FileStream.Free;
fFiles.Clear;
end;
// get the Filename by index
function TClpBrdFiles.getFileNameByIndex(
index: integer):
string;
begin
result:='
';
if (fFilesCount>0)
and (
index>=0)
and (
index<=fFilesCount-1)
then
result:= fFiles[
index].Filename;
end;
// get the filestream by index
function TClpBrdFiles.getFileStreamByIndex(
Index: integer): TStream;
begin
result:=nil;
if (fFilesCount>0)
and (
index>=0)
and (
index<=fFilesCount-1)
then
result:= fFiles[
index].FileStream;
end;
// get the count of files and fill the list
function TClpBrdFiles.GetMessageCount(
const dataObj: IDataObject): integer;
var
ClipboardFile : TClipboardFile;
FormatETC : TFORMATETC;
STGMedium : TSTGMEDIUM;
FileGroupDescriptor : ^TFileGroupDescriptor;
FileDescriptor : TFileDescriptor;
I : integer;
begin
FormatETC.cfFormat := CF_FileGroupDescriptorW;
FormatETC.dwAspect := DVASPECT_CONTENT;
FormatETC.lindex := -1;
FormatETC.ptd :=
nil;
FormatETC.TYMED := TYMED_HGLOBAL;
if dataObj.QueryGetData(FormatETC) <> S_OK
then
FormatETC.cfFormat := CF_FileGroupDescriptor;
if dataObj.GetData(FormatETC, STGMedium) = S_OK
then
begin
FileGroupDescriptor:= GlobalLock(STGMedium.hGlobal);
result:=FileGroupDescriptor.cItems;
for I := 0
to FileGroupDescriptor.cItems-1
do
begin
FileDescriptor := FileGroupDescriptor.fgd[i];
ClipboardFile.Filename:=FileDescriptor.cFileName;
ClipboardFile.FileStream:= TMemoryStream.Create;
fFiles.Add(ClipboardFile);
end;
GlobalUnlock(STGMedium.hGlobal);
ReleaseStgMedium(STGMedium);
end;
for I := 0
to fFiles.Count-1
do
SaveMessage(dataObj,fFiles[i].FileStream,I);
end;
// store the filestream into the list
procedure TClpBrdFiles.SaveMessage(
const dataObj: IDataObject;
Stream: TMemoryStream;
Index: Integer);
var
FormatETC: TFORMATETC;
Medium : TSTGMEDIUM;
OleStream: TOleStream;
begin
FillChar(FormatETC,sizeOf(FormatETC),0);
FillChar(Medium,sizeOf(Medium),0);
FormatETC.cfFormat := CF_FileContents;
FormatETC.dwAspect := DVASPECT_CONTENT;
FormatETC.lindex :=
Index;
FormatETC.ptd :=
nil;
FormatETC.TYMED := TYMED_ISTREAM ;
//Or TYMED_ISTORAGE; not used
if dataObj.GetData(FormatETC, Medium) = S_OK
then
begin
case Medium.tymed
of
TYMED_HGLOBAL:
{not used};
TYMED_ISTREAM:
begin
OleStream:=TOleStream.Create(ISTREAM(Medium.stm));
try
Stream.CopyFrom(OleStream,OleStream.Size);
finally
OleStream.Free;
end;
end;
end;
end;
end;
// standard event - send the message WM_CHANGECBCHAIN to the next window
procedure TClpBrdFiles.WMCHANGECBCHAIN(Msg: TMessage);
begin
if HWND(Msg.WParam) = NextWnd
then
NextWnd := HWND(Msg.LParam)
else
if NextWnd <> 0
then
SendMessage(NextWnd, WM_CHANGECBCHAIN, Msg.WParam, Msg.LParam);
end;
// standard event - read the clipboard and send the message to next window
procedure TClpBrdFiles.WMDRAWCLIPBOARD(Msg: TMessage);
var
DataObject: IDataObject;
ClipboardFile:TClipboardFile;
begin
if clipboard.HasFormat(CF_FILECONTENTS)
then
begin
if OleGetClipboard(DataObject)=S_OK
then
begin
EmptyList;
fFilesCount:= GetMessageCount(DataObject);
// Call other Procedure if available
if assigned(fNotifyClipboardEvent)
then
fNotifyClipboardEvent();
end;
end;
if NextWnd <> 0
then
SendMessage(NextWnd, WM_DRAWCLIPBOARD, Msg.WParam, Msg.LParam);
end;
procedure TClpBrdFiles.WndMethod(
var Msg: TMessage);
var
Handled: Boolean;
begin
Handled := True;
case Msg.Msg
of
WM_CHANGECBCHAIN:WMCHANGECBCHAIN(Msg);
WM_DRAWCLIPBOARD:WMDRAWCLIPBOARD(Msg);
else
Handled := False;
end;
if Handled
then
Msg.Result := 0
else
Msg.Result := DefWindowProc(fHWnd, Msg.Msg,Msg.WParam, Msg.LParam);
end;
initialization
OleInitialize(
nil);
finalization
OleUninitialize;
end.
Antwort
17. Dez 2012, 18:01
Msch
Zitat
Linear-Darstellung
