1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:

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.