home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Calmira / Src / VCL / DROPSERV.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-02-15  |  7.8 KB  |  240 lines
  1. {*********************************************************}
  2. {                                                         }
  3. {    Calmira Visual Component Library 1.0                 }
  4. {    by Li-Hsin Huang,                                    }
  5. {    released into the public domain January 1997         }
  6. {                                                         }
  7. {*********************************************************}
  8.  
  9. unit DropServ;
  10.  
  11. { TDropServer component
  12.  
  13.   If you ever need to drop files into other programs, this component
  14.   can lend a hand, although it still requires some programming on your
  15.   part.  In a control's OnMouseMove handler, call CanDrop to determine
  16.   if if the cursor is over a suitable window.  In the OnEndDrag handler,
  17.   call the DragFinished method.  If a drop is allowed, the OnFileDrop
  18.   event is triggered which lets you assign the files to drop.
  19.  
  20.   AutoClear : Boolean (inherited)
  21.     If this is True, then the Files property is cleared after each
  22.     drop is completed.
  23.  
  24.   Files : TStrings (run-time only)
  25.     Contains a list of files to drop into another program
  26.  
  27.   InternalDrop : Boolean
  28.     If this is set to True, OnFileDrag events will occur when the
  29.     cursor is over a valid window belonging to your program.  If it is
  30.     False, OnFileDrag only occurs when the cursor is over another program.
  31.     Generally, you should use Delphi's own drag and drop handling and set
  32.     this to False.
  33.  
  34.   DesktopDrop : Boolean
  35.     If this is set to True, you will receive an OnDesktopDrop event when
  36.     the mouse is released over the desktop background or wallpaper.
  37.  
  38.   CanDrop: Boolean;
  39.      Returns True if the cursor is over something that can accept drops.
  40.      Call this inside an OnMouseMove handler.  If the cursor is currently
  41.      over a window, the call will trigger the OnFileDrag event to ask you
  42.      for confirmation of the drop. 
  43.  
  44.   procedure DragFinished;
  45.      Call this inside an OnEndDrag handler.  If the cursor is over a
  46.      suitable window and you have responded to the OnFileDrag event,
  47.      then an OnFileDrop is triggered to let you assign the filenames.
  48.  
  49.   procedure DropFiles(Wnd: HWnd; AMousePos: TPoint);
  50.      Encapsulates the WM_DROPFILES message and immediately causes a
  51.      drop into the given window.  The strings in the Files property are
  52.      contatenated into the required structure and a WM_DROPFILES message
  53.      is sent to the given window.  The TPoint parameter lets you control
  54.      the location of this forced drop.
  55.  
  56.   OnFileDrag
  57.      Occurs when you call CanDrop and the cursor is over a window that
  58.      accepts dropped files.  To permit the drop (if the user releases the
  59.      mouse button), set the Accept property to True.  The Target parameter
  60.      contains the handle of the window in question, and lets you perform
  61.      your own tests before accepting.
  62.  
  63.   OnFileDrop
  64.      Occurs when the user releases the mouse button over a window that
  65.      accepts files and you call DragFinished method.  During this event,
  66.      you must fill the Files property with the files you wish to drop
  67.      (one file per line).  The drop takes place as soon as your handler
  68.      finishes executing.
  69.  
  70.   OnDesktopDrop
  71.      Occurs when the user releases the mouse button over the desktop.
  72.      This is only a notification - TDropServer doesn't do anything
  73.      afterwards.  The Target parameter contains the window handle of
  74.      the desktop, in case you want to send any messages to it.
  75. }
  76.  
  77. interface
  78.  
  79. uses
  80.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  81.   Forms, Dialogs, DragDrop;
  82.  
  83. type
  84.   TFileDragEvent = procedure (Sender : TObject; X, Y: Integer;
  85.     Target : HWND; var Accept : Boolean) of object;
  86.  
  87.   TFileDropEvent = procedure (Sender : TObject; X, Y: Integer;
  88.     Target : HWND) of object;
  89.  
  90.   TDropServerError = class(Exception);
  91.  
  92.   TDropServer = class(TDragDrop)
  93.   private
  94.     { Private declarations }
  95.     DropPoint       : TPoint;
  96.     AllowDrop       : Boolean;
  97.     DropWindow      : HWND;
  98.     FInternalDrop   : Boolean;
  99.     FDesktopDrop    : Boolean;
  100.     FOnFileDrag     : TFileDragEvent;
  101.     FOnFileDrop     : TFileDropEvent;
  102.     FOnDeskDrop     : TFileDropEvent;
  103.   protected
  104.     { Protected declarations }
  105.   public
  106.     { Public declarations }
  107.     procedure DropFiles(Wnd: HWnd; AMousePos: TPoint);
  108.     function CanDrop: Boolean;
  109.     procedure DragFinished;
  110.   published
  111.     { Published declarations }
  112.     property InternalDrop : Boolean read FInternalDrop write FInternalDrop default False;
  113.     property DesktopDrop : Boolean read FDesktopDrop write FDesktopDrop default False;
  114.     property OnFileDrag : TFileDragEvent read FOnFileDrag write FOnFileDrag;
  115.     property OnFileDrop : TFileDropEvent read FOnFileDrop write FOnFileDrop;
  116.     property OnDeskDrop : TFileDropEvent read FOnDeskDrop write FOnDeskDrop;
  117.   end;
  118.  
  119. procedure Register;
  120.  
  121.  
  122. implementation
  123.  
  124. type
  125.   { Windows expects a WM_DROPFILES message to contain a memory
  126.     handle with this structure as a header }
  127.  
  128.   PDropFileRec = ^TDropFileRec;
  129.   TDropFileRec = record
  130.     Size: Word;
  131.     MousePos: TPoint;
  132.     InNonClientArea: Boolean;
  133.   end;
  134.  
  135. procedure TDropServer.DropFiles(Wnd: HWnd; AMousePos: TPoint);
  136. var
  137.   H: THandle;
  138.   p: PDropFileRec;
  139.   data : PChar;
  140.   size : Word;
  141.   i, count: Integer;
  142. begin
  143.   { Thanks to Brian Andersen for this procedure's algorithm (it doesn't
  144.     seem to be documented by Microsoft) }
  145.  
  146.   if GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_ACCEPTFILES = 0 then
  147.     raise TDropServerError.Create('This windows does not accept dropped files');
  148.  
  149.   WinProcs.ScreenToClient(Wnd, AMousePos);
  150.  
  151.   { Find the size of the buffer needed to hold the filenames }
  152.   size := SizeOf(TDropFileRec) + 1;
  153.   count := 0;
  154.   while (size < 65276) and (count < Files.Count) do begin
  155.     Inc(size, Length(Files[count]) + 1);
  156.     Inc(count);
  157.   end;
  158.  
  159.   { Allocate the buffer }
  160.   H := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT, size);
  161.  
  162.   if H = 0 then raise TDropServerError.Create('Unable to allocate file drop buffer.');
  163.  
  164.   p := GlobalLock(H);
  165.  
  166.   { Initialize the header info }
  167.   with p^ do begin
  168.     Size := SizeOf(TDropFileRec);
  169.     MousePos := AMousePos;
  170.     InNonClientArea := SendMessage(Wnd, WM_NCHITTEST, 0, Longint(AMousePos)) <> HTCLIENT;
  171.   end;
  172.  
  173.   { Append the filenames to the buffer after advancing the pointer
  174.     beyond the header }
  175.   data := PChar(p) + Sizeof(TDropFileRec);
  176.   for i := 0 to count-1 do begin
  177.      StrPCopy(data, Files[i]);
  178.      Inc(data, Length(Files[i]) + 1);
  179.   end;
  180.   GlobalUnlock(H);
  181.  
  182.   { Drop the files }
  183.   PostMessage(Wnd, WM_DROPFILES, H, 0);
  184.  
  185.   if AutoClear then Files.Clear;
  186. end;
  187.  
  188.  
  189. function TDropServer.CanDrop: Boolean;
  190. var
  191.   p: TPoint;
  192. begin
  193.   GetCursorPos(p);
  194.   AllowDrop := False;
  195.   DropWindow := WindowFromPoint(p);
  196.  
  197.   if ((DropWindow = GetDesktopWindow) and DesktopDrop) then begin
  198.     AllowDrop := True;
  199.     DropPoint := p;
  200.   end
  201.   else begin
  202.     if ((DropWindow <> 0) and
  203.       (InternalDrop or (GetWindowTask(DropWindow) <> GetCurrentTask)) and
  204.       (GetWindowLong(DropWindow, GWL_EXSTYLE) and WS_EX_ACCEPTFILES > 0)) then begin
  205.       AllowDrop := True;
  206.       DropPoint := p;
  207.       if Assigned(FOnFileDrag) then FOnFileDrag(self, p.x, p.y, DropWindow, AllowDrop);
  208.     end;
  209.   end;
  210.   Result := AllowDrop;
  211. end;
  212.  
  213.  
  214. procedure TDropServer.DragFinished;
  215. begin
  216.   if AllowDrop then begin
  217.     if DropWindow = GetDesktopWindow then begin
  218.       if Assigned(FOnDeskDrop) then
  219.         FOnDeskDrop(self, DropPoint.x, DropPoint.y, DropWindow);
  220.     end
  221.     else if Assigned(FOnFileDrop) then begin
  222.       FOnFileDrop(self, DropPoint.x, DropPoint.y, DropWindow);
  223.       DropFiles(DropWindow, DropPoint);
  224.     end;
  225.   end;
  226.   AllowDrop := False;
  227. end;
  228.  
  229.  
  230.  
  231. procedure Register;
  232. begin
  233.   RegisterComponents('Samples', [TDropServer]);
  234. end;
  235.  
  236.  
  237. end.
  238.  
  239.  
  240.