1 unit JCFDropTarget;
2
3 { AFS 16 May 2K
4 Got this unit as freeware from www.undu.com October 1998 page
5 code by Thorsten Engler - Thorsten.Engler@gmx.net
6 Renamed to JCFDropTarget to avoid name conflicts (peter3)
7 }
8
9 {(*}
10 (*------------------------------------------------------------------------------
11 Delphi Code formatter source code
12
13 The Original Code is JCFDropTarget, released May 2003.
14 The Initial Developer of the Original Code is Anthony Steele.
15 Portions created by Anthony Steele are Copyright (C) 1999-2008 Anthony Steele.
16 All Rights Reserved.
17 Contributor(s): Anthony Steele.
18
19 The contents of this file are subject to the Mozilla Public License Version 1.1
20 (the "License"). you may not use this file except in compliance with the License.
21 You may obtain a copy of the License at http://www.mozilla.org/NPL/
22
23 Software distributed under the License is distributed on an "AS IS" basis,
24 WITHOUT WARRANTY OF ANY KIND, either express or implied.
25 See the License for the specific language governing rights and limitations
26 under the License.
27
28 Alternatively, the contents of this file may be used under the terms of
29 the GNU General Public License Version 2 or later (the "GPL")
30 See http://www.gnu.org/licenses/gpl.html
31 ------------------------------------------------------------------------------*)
32 {*)}
33
34 {$I JcfGlobal.inc}
35
36 interface
37
38 uses
39 Windows,
40 Classes,
41 ActiveX,
42 Controls;
43
44 type
45 TTeDropTarget = class;
46 TTeDropInterface = class;
47
48 TTeDropTargetLifeState = (lsStart, lsExists, lsLocked, lsRegd);
49
50 TTeDragOperation = (doNothing, doCopy, doMove, doLink);
51
52 TTeComDragObject = class(TDragObject)
53 private
54 FDropInterface: TTeDropInterface;
GetDataObjectnull55 function GetDataObject: IDataObject;
GetDragOperationnull56 function GetDragOperation: TTeDragOperation;
57 procedure SetDragOperation(Value: TTeDragOperation);
GetShiftStatenull58 function GetShiftState: TShiftState;
59 public
60 constructor Create(ADropInterface: TTeDropInterface); virtual;
61 property DataObject: IDataObject Read GetDataObject;
62 property DragOperation: TTeDragOperation Read GetDragOperation
63 Write SetDragOperation;
64 property ShiftState: TShiftState Read GetShiftState;
65 end;
66
67 TComDragObjectClass = class of TTeComDragObject;
68
69 TTeDropInterface = class
70 private
DoDragOvernull71 function DoDragOver(DragMsg: TDragMessage): boolean;
DragTonull72 function DragTo(const Pos: TPoint): boolean;
DragFindTargetnull73 function DragFindTarget(const Pos: TPoint; var Handle: HWND): Pointer;
74 protected
75 FDropTarget: TTeDropTarget;
76 FWinControl: TWinControl;
77 FDataObject: IDataObject;
78 FDragOperation: TTeDragOperation;
79 FShiftState: TShiftState;
80 FDragObject: TTeComDragObject;
81 public
82 property CFDropTarget: TTeDropTarget Read FDropTarget;
83
84 constructor Create(AWinControl: TWinControl); virtual;
85 destructor Destroy; override;
86 procedure BeforeDestruction; override;
87
DropTarget_Createnull88 function DropTarget_Create: HResult;
DropTarget_Destroynull89 function DropTarget_Destroy: HResult;
DropTarget_Existsnull90 function DropTarget_Exists: boolean;
91 protected
92 procedure DropTarget_Forget;
93 public
DropTarget_LifeStatenull94 function DropTarget_LifeState: TTeDropTargetLifeState;
95
DragEnternull96 function DragEnter(const dataObj: IDataObject; grfKeyState: longint;
97 pt: TPoint; var dwEffect: longint): HResult; virtual;
DragOvernull98 function DragOver(grfKeyState: longint; pt: TPoint;
99 var dwEffect: longint): HResult; virtual;
DragLeavenull100 function DragLeave: HResult; virtual;
Dropnull101 function Drop(const dataObj: IDataObject; grfKeyState: longint;
102 pt: TPoint; var dwEffect: longint): HResult; virtual;
103
104 property DataObject: IDataObject Read FDataObject;
105 property DragOperation: TTeDragOperation Read FDragOperation Write FDragOperation;
106 property ShiftState: TShiftState Read FShiftState;
107 end;
108
109 TTeDropTarget = class(TInterfacedObject, IDropTarget)
110 private
111 FDropHWND: HWND;
112 FDropWinControl: TWinControl;
113
114 FDropInterface: TTeDropInterface;
115 FLifeState: TTeDropTargetLifeState;
116
117 procedure SetLifeState(Value: TTeDropTargetLifeState);
118 public
119 property DropHWND: HWND Read FDropHWnd;
120 property DropWinControl: TWinControl Read FDropWinControl;
121 property LifeState: TTeDropTargetLifeState Read FLifeState Write SetLifeState;
122
123 constructor Create(AWinControl: TWinControl;
124 ADropInterface: TTeDropInterface); virtual;
125 procedure BeforeDestruction; override;
126
ToState_Existsnull127 function ToState_Exists: HResult;
ToState_Lockednull128 function ToState_Locked: HResult;
ToState_Regdnull129 function ToState_Regd: HResult;
130 public
131 { IDropTarget }
DragEnternull132 function DragEnter(const dataObj: IDataObject; grfKeyState: longint;
133 pt: TPoint; var dwEffect: longint): HResult; stdcall;
DragOvernull134 function DragOver(grfKeyState: longint; pt: TPoint;
135 var dwEffect: longint): HResult; stdcall;
DragLeavenull136 function DragLeave: HResult; stdcall;
Dropnull137 function Drop(const dataObj: IDataObject; grfKeyState: longint;
138 pt: TPoint; var dwEffect: longint): HResult; stdcall;
139 end;
140
141 var
142 ComDragObjectClass: TComDragObjectClass;
143
144 const
145 Effects: array[TTeDragOperation] of integer =
146 (DROPEFFECT_NONE, DROPEFFECT_COPY, DROPEFFECT_MOVE, DROPEFFECT_LINK);
147
148 implementation
149
DragMessagenull150 function DragMessage(Handle: HWND; Msg: TDragMessage; Source: TDragObject;
151 Target: Pointer; const Pos: TPoint): longint;
152 var
153 DragRec: TDragRec;
154 begin
155 Result := 0;
156 if Handle <> 0 then
157 begin
158 DragRec.Pos := Pos;
159 DragRec.Target := Target;
160 DragRec.Source := Source;
161 DragRec.Docking := False;
162 Result := SendMessage(Handle, CM_DRAG, longint(Msg), longint( @DragRec));
163 end;
164 end;
165
DragFindWindownull166 function DragFindWindow(const Pos: TPoint): HWND;
167 begin
168 Result := WindowFromPoint(Pos);
169 while Result <> 0 do
170 if not Assigned(FindControl(Result)) then
171 Result := GetParent(Result)
172 else
173 Exit;
174 end;
175
TTeDropInterface.DragFindTargetnull176 function TTeDropInterface.DragFindTarget(const Pos: TPoint; var Handle: HWND): Pointer;
177 begin
178 Handle := DragFindWindow(Pos);
179 Result := Pointer(DragMessage(Handle, dmFindTarget, FDragObject, nil, Pos));
180 end;
181
TTeDropInterface.DoDragOvernull182 function TTeDropInterface.DoDragOver(DragMsg: TDragMessage): boolean;
183 begin
184 Result := False;
185 if FDragObject.DragTarget <> nil then
186 Result := longbool(DragMessage(FDragObject.DragHandle, DragMsg, FDragObject,
187 FDragObject.DragTarget, FDragObject.DragPos));
188 end;
189
TTeDropInterface.DragTonull190 function TTeDropInterface.DragTo(const Pos: TPoint): boolean;
191 var
192 Target: TControl;
193 TargetHandle: HWND;
194 begin
195 Target := DragFindTarget(Pos, TargetHandle);
196 if Target <> FDragObject.DragTarget then
197 begin
198 DoDragOver(dmDragLeave);
199 FDragObject.DragTarget := Target;
200 FDragObject.DragHandle := TargetHandle;
201 FDragObject.DragPos := Pos;
202 DoDragOver(dmDragEnter);
203 end;
204 FDragObject.DragPos := Pos;
205 if FDragObject.DragTarget <> nil then
206 FDragObject.DragTargetPos := TControl(FDragObject.DragTarget).ScreenToClient(Pos);
207 Result := DoDragOver(dmDragMove);
208 end;
209
210 constructor TTeDropInterface.Create(AWinControl: TWinControl);
211 begin
212 inherited Create;
213 FWinControl := AWinControl;
214 FDropTarget := nil;
215 FDragObject := ComDragObjectClass.Create(Self);
216 end;
217
218 procedure TTeDropInterface.BeforeDestruction;
219 begin
220 inherited;
221 if Assigned(FDragObject) then
222 FDragObject.FDropInterface := nil;
223 if Assigned(FDropTarget) then
224 FDropTarget.Free;
225 end;
226
DropTarget_Createnull227 function TTeDropInterface.DropTarget_Create: HResult;
228 begin
229 Result := E_UNEXPECTED;
230 try
231 if not Assigned(FDropTarget) then
232 FDropTarget := TTeDropTarget.Create(FWinControl, Self);
233 if Assigned(FDropTarget) then
234 Result := CFDropTarget.ToState_Regd;
235 except
236 Result := E_UNEXPECTED;
237 end;
238 end;
239
TTeDropInterface.DropTarget_Destroynull240 function TTeDropInterface.DropTarget_Destroy: HResult;
241 begin
242 Result := S_OK;
243 try
244 if Assigned(FDropTarget) then
245 Result := CFDropTarget.ToState_Locked;
246 except
247 Result := E_UNEXPECTED;
248 end;
249 end;
250
DropTarget_Existsnull251 function TTeDropInterface.DropTarget_Exists: boolean;
252 begin
253 Result := Assigned(FDropTarget);
254 end;
255
256 procedure TTeDropInterface.DropTarget_Forget;
257 begin
258 FDropTarget := nil;
259 end;
260
DropTarget_LifeStatenull261 function TTeDropInterface.DropTarget_LifeState: TTeDropTargetLifeState;
262 begin
263 if DropTarget_Exists then
264 Result := CFDropTarget.LifeState
265 else
266 Result := lsStart;
267 end;
268
CreateShiftStatenull269 function CreateShiftState(grfKeyState: longint): TShiftState;
270 begin
271 Result := [];
272 if (grfKeyState and MK_CONTROL) = MK_CONTROL then
273 Include(Result, ssCtrl);
274 if (grfKeyState and MK_SHIFT) = MK_SHIFT then
275 Include(Result, ssShift);
276 // if (grfKeyState and MK_ALT) = MK_ALT then Include (Result, ssAlt);
277 if (grfKeyState and MK_LBUTTON) = MK_LBUTTON then
278 Include(Result, ssLeft);
279 if (grfKeyState and MK_MBUTTON) = MK_MBUTTON then
280 Include(Result, ssMiddle);
281 if (grfKeyState and MK_RBUTTON) = MK_RBUTTON then
282 Include(Result, ssRight);
283 end;
284
CreateDragOperationnull285 function CreateDragOperation(ShiftState: TShiftState): TTeDragOperation;
286 begin
287 Result := doMove; // muss noch ge�ndert werden;
288 if ssCtrl in ShiftState then
289 Result := doCopy;
290 if ssShift in ShiftState then
291 Result := doMove;
292 if (ssCtrl in ShiftState) and (ssShift in ShiftState) then
293 Result := doLink;
294 end;
295
DragEnternull296 function TTeDropInterface.DragEnter(const dataObj: IDataObject;
297 grfKeyState: longint; pt: TPoint; var dwEffect: longint): HResult;
298 begin
299 Result := S_OK;
300 dwEffect := DROPEFFECT_NONE;
301 if not Assigned(FWinControl) then
302 exit;
303 if not Assigned(FDragObject) then
304 exit;
305 try
306 FShiftState := CreateShiftState(grfKeyState);
307 FDragOperation := CreateDragOperation(FShiftState);
308 FDataObject := dataObj;
309 if not DragTo(pt) then
310 FDragOperation := doNothing;
311 dwEffect := Effects[FDragOperation];
312 except
313 Result := E_UNEXPECTED;
314 end;
315 end;
316
TTeDropInterface.DragOvernull317 function TTeDropInterface.DragOver(grfKeyState: longint; pt: TPoint;
318 var dwEffect: longint): HResult;
319 begin
320 Result := S_OK;
321 dwEffect := DROPEFFECT_NONE;
322 if not Assigned(FWinControl) then
323 exit;
324 if not Assigned(FDragObject) then
325 exit;
326 try
327 FShiftState := CreateShiftState(grfKeyState);
328 FDragOperation := CreateDragOperation(FShiftState);
329 if not DragTo(pt) then
330 FDragOperation := doNothing;
331 dwEffect := Effects[FDragOperation];
332 except
333 Result := E_UNEXPECTED;
334 end;
335 end;
336
DragLeavenull337 function TTeDropInterface.DragLeave: HResult;
338 begin
339 Result := S_OK;
340 if not Assigned(FWinControl) then
341 exit;
342 if not Assigned(FDragObject) then
343 exit;
344 try
345 DoDragOver(dmDragLeave);
346 FDragObject.DragTarget := nil;
347 FDragObject.DragHandle := 0;
348 FDataObject := nil;
349 except
350 Result := E_UNEXPECTED;
351 end;
352 end;
353
TTeDropInterface.Dropnull354 function TTeDropInterface.Drop(const dataObj: IDataObject; grfKeyState: longint;
355 pt: TPoint; var dwEffect: longint): HResult;
356 begin
357 Result := S_OK;
358 dwEffect := DROPEFFECT_NONE;
359 if not Assigned(FWinControl) then
360 exit;
361 if not Assigned(FDragObject) then
362 exit;
363 try
364 FDataObject := dataObj;
365 try
366 FShiftState := CreateShiftState(grfKeyState);
367 FDragOperation := CreateDragOperation(FShiftState);
368 if not DragTo(pt) then
369 FDragOperation := doNothing;
370 dwEffect := Effects[FDragOperation];
371 if FDragOperation <> doNothing then
372 DoDragOver(dmDragDrop);
373 finally
374 FDataObject := nil;
375 end;
376 except
377 Result := E_UNEXPECTED;
378 end;
379 end;
380
381 constructor TTeDropTarget.Create(AWinControl: TWinControl;
382 ADropInterface: TTeDropInterface);
383 begin
384 inherited Create;
385 FDropWinControl := AWinControl;
386 FDropInterface := ADropInterface;
387 FLifeState := lsExists;
388 end;
389
390 procedure TTeDropTarget.BeforeDestruction;
391 begin
392 if Assigned(FDropInterface) then
393 FDropInterface.DropTarget_Forget;
394
395 if FLifeState > lsLocked then
396 begin
397 while RefCount < 2 do
398 _AddRef;
399 ActiveX.RevokeDragDrop(FDropHWND);
400 FDropHWND := 0;
401 FLifeState := lsLocked;
402 end;
403
404 if FLifeState > lsExists then
405 begin
406 while RefCount < 2 do
407 _AddRef;
408 ActiveX.CoLockObjectExternal(Self as IDropTarget, False, False);
409 FLifeState := lsExists;
410 end;
411 end;
412
ToState_Existsnull413 function TTeDropTarget.ToState_Exists: HResult;
414 begin
415 Result := S_OK;
416 if LifeState = lsRegd then
417 Result := ToState_Locked;
418
419 if LifeState = lsLocked then
420 begin
421 LifeState := lsExists;
422 Result := ActiveX.CoLockObjectExternal(Self as IDropTarget, False, True);
423 end;
424 end;
425
TTeDropTarget.ToState_Lockednull426 function TTeDropTarget.ToState_Locked: HResult;
427 begin
428 Result := S_OK;
429
430 if LifeState = lsExists then
431 begin
432 Result := ActiveX.CoLockObjectExternal(Self as IDropTarget, True, False);
433 if Result = S_OK then
434 LifeState := lsLocked;
435 end;
436
437 if LifeState = lsRegd then
438 begin
439 while RefCount < 2 do
440 _AddRef;
441 Result := ActiveX.RevokeDragDrop(FDropHWND);
442 FDropHWND := 0;
443 if Result = S_OK then
444 LifeState := lsLocked;
445 end;
446 end;
447
TTeDropTarget.ToState_Regdnull448 function TTeDropTarget.ToState_Regd: HResult;
449 begin
450 Result := S_OK;
451 if LifeState = lsExists then
452 Result := ToState_Locked;
453 if LifeState = lsLocked then
454 begin
455 FDropHWND := FDropWinControl.Handle;
456 Result := ActiveX.RegisterDragDrop(FDropHWND, Self as IDropTarget);
457 if Result = S_OK then
458 LifeState := lsRegd;
459 end;
460 end;
461
462 procedure TTeDropTarget.SetLifeState(Value: TTeDropTargetLifeState);
463 begin
464 FLifeState := Value;
465 end;
466
DragEnternull467 function TTeDropTarget.DragEnter(const dataObj: IDataObject;
468 grfKeyState: longint; pt: TPoint; var dwEffect: longint): HResult;
469 begin
470 if Assigned(FDropInterface) then
471 Result := FDropInterface.DragEnter(dataObj, grfKeyState, pt, dwEffect)
472 else
473 Result := E_UNEXPECTED;
474 end;
475
TTeDropTarget.DragOvernull476 function TTeDropTarget.DragOver(grfKeyState: longint; pt: TPoint;
477 var dwEffect: longint): HResult;
478 begin
479 if Assigned(FDropInterface) then
480 Result := FDropInterface.DragOver(grfKeyState, pt, dwEffect)
481 else
482 Result := E_UNEXPECTED;
483 end;
484
DragLeavenull485 function TTeDropTarget.DragLeave: HResult;
486 begin
487 if Assigned(FDropInterface) then
488 Result := FDropInterface.DragLeave
489 else
490 Result := E_UNEXPECTED;
491 end;
492
TTeDropTarget.Dropnull493 function TTeDropTarget.Drop(const dataObj: IDataObject; grfKeyState: longint;
494 pt: TPoint; var dwEffect: longint): HResult;
495 begin
496 if Assigned(FDropInterface) then
497 Result := FDropInterface.Drop(dataObj, grfKeyState, pt, dwEffect)
498 else
499 Result := E_UNEXPECTED;
500 end;
501
502 { TTeComDragObject }
503
504 constructor TTeComDragObject.Create(ADropInterface: TTeDropInterface);
505 begin
506 inherited Create;
507 FDropInterface := ADropInterface;
508 end;
509
GetDataObjectnull510 function TTeComDragObject.GetDataObject: IDataObject;
511 begin
512 if Assigned(FDropInterface) then
513 Result := FDropInterface.DataObject
514 else
515 Result := nil;
516 end;
517
GetDragOperationnull518 function TTeComDragObject.GetDragOperation: TTeDragOperation;
519 begin
520 if Assigned(FDropInterface) then
521 Result := FDropInterface.DragOperation
522 else
523 Result := doNothing;
524 end;
525
TTeComDragObject.GetShiftStatenull526 function TTeComDragObject.GetShiftState: TShiftState;
527 begin
528 if Assigned(FDropInterface) then
529 Result := FDropInterface.ShiftState
530 else
531 Result := [];
532 end;
533
534 procedure TTeComDragObject.SetDragOperation(Value: TTeDragOperation);
535 begin
536 if Assigned(FDropInterface) then
537 FDropInterface.DragOperation := Value;
538 end;
539
540 destructor TTeDropInterface.Destroy;
541 begin
542 if Assigned(FDragObject) then
543 begin
544 FDragObject.Free;
545 FDragObject := nil;
546 end;
547 inherited;
548 end;
549
550 initialization
551 ComDragObjectClass := TTeComDragObject;
552 OleInitialize(nil);
553
554 finalization
555 OleUninitialize;
556 end.
557