home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d23456 / TB97.ZIP / Source / TB97Cmn.pas < prev    next >
Pascal/Delphi Source File  |  2001-01-05  |  14KB  |  453 lines
  1. unit TB97Cmn;
  2.  
  3. {
  4.   Toolbar97
  5.   Copyright (C) 1998-2001 by Jordan Russell
  6.   For conditions of distribution and use, see LICENSE.TXT.
  7.  
  8.   Internal common functions
  9.  
  10.   $Id: TB97Cmn.pas,v 1.2 2001/01/04 04:17:14 jr Exp $
  11. }
  12.  
  13. interface
  14.  
  15. {$I TB97Ver.inc}
  16.  
  17. uses
  18.   Windows, Classes, Messages, Controls;
  19.  
  20. type
  21.   THookProcCode = (hpSendActivateApp, hpSendWindowPosChanged, hpPreDestroy,
  22.     hpPostMouseMove);
  23.   THookProcCodes = set of THookProcCode;
  24.   THookProc = procedure(Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM);
  25.   TListSortExCompare = function(const Item1, Item2, ExtraData: Pointer): Integer;
  26.   THandleWMPrintNCPaintProc = procedure(Wnd: HWND; DC: HDC; AppData: Longint);
  27.   TGetToolbarDockPosType = (gtpTop, gtpBottom, gtpLeft, gtpRight, gtpNone);
  28.  
  29. var
  30.   GetToolbarDockPosProc: function(Ctl: TControl): TGetToolbarDockPosType = nil;
  31.  
  32. function ApplicationIsActive: Boolean;
  33. procedure InstallHookProc (AProc: THookProc; ACodes: THookProcCodes;
  34.   OnlyIncrementCount: Boolean);
  35. procedure UninstallHookProc (AProc: THookProc);
  36. procedure ListSortEx (const List: TList; const Compare: TListSortExCompare;
  37.   const ExtraData: Pointer);
  38. procedure SelectNCUpdateRgn (Wnd: HWND; DC: HDC; Rgn: HRGN);
  39. procedure HandleWMPrint (const Wnd: HWND; var Message: TMessage;
  40.   const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: Longint);
  41. procedure HandleWMPrintClient (const Control: TWinControl;
  42.   var Message: TMessage);
  43.  
  44. {$IFNDEF TB97D3}
  45. type
  46.   PMaxLogPalette = ^TMaxLogPalette;
  47.   TMaxLogPalette = packed record
  48.     palVersion: Word;
  49.     palNumEntries: Word;
  50.     palPalEntry: array[Byte] of TPaletteEntry;
  51.   end;
  52. function CopyPalette (Palette: HPALETTE): HPALETTE;
  53. {$ENDIF}
  54.  
  55. implementation
  56.  
  57. uses
  58.   Forms;
  59.  
  60. type
  61.   PHookProcData = ^THookProcData;
  62.   THookProcData = record
  63.     Proc: THookProc;
  64.     RefCount: Longint;
  65.     Codes: THookProcCodes;
  66.   end;
  67.   THookType = (htCallWndProc, htCBT, htGetMessage);
  68.   THookTypes = set of THookType;
  69.  
  70. var
  71.   HookHandles: array[THookType] of HHOOK;
  72.   HookProcList: TList = nil;
  73.   HookCounts: array[THookType] of Longint;
  74.  
  75.  
  76. function CallWndProcHook (Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT;
  77. stdcall;
  78. type
  79.   THookProcCodeMsgs = hpSendActivateApp..hpSendWindowPosChanged;
  80. const
  81.   MsgMap: array[THookProcCodeMsgs] of UINT =
  82.     (WM_ACTIVATEAPP, WM_WINDOWPOSCHANGED);
  83. var
  84.   J: THookProcCodeMsgs;
  85.   I: Integer;
  86. begin
  87.   if Assigned(HookProcList) and (Code = HC_ACTION) then
  88.     with PCWPStruct(LParam)^ do begin
  89.       for J := Low(J) to High(J) do
  90.         if Message = MsgMap[J] then begin
  91.           for I := 0 to HookProcList.Count-1 do
  92.             try
  93.               with PHookProcData(HookProcList.List[I])^ do
  94.                 if J in Codes then
  95.                   Proc (J, hwnd, WParam, LParam);
  96.             except
  97.             end;
  98.           Break;
  99.         end;
  100.     end;
  101.   Result := CallNextHookEx(HookHandles[htCallWndProc], Code, WParam, LParam);
  102. end;
  103.  
  104. function CBTHook (Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT;
  105. stdcall;
  106. var
  107.   I: Integer;
  108. begin
  109.   if Assigned(HookProcList) and (Code = HCBT_DESTROYWND) then
  110.     for I := 0 to HookProcList.Count-1 do
  111.       try
  112.         with PHookProcData(HookProcList.List[I])^ do
  113.           if hpPreDestroy in Codes then
  114.             Proc (hpPreDestroy, HWND(WParam), 0, 0);
  115.       except
  116.       end;
  117.   Result := CallNextHookEx(HookHandles[htCBT], Code, WParam, LParam);
  118. end;
  119.  
  120. function GetMessageHook (Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT;
  121. stdcall;
  122. var
  123.   I: Integer;
  124. begin
  125.   if Assigned(HookProcList) and (Code = HC_ACTION) and
  126.      (PMsg(LParam).message = WM_MOUSEMOVE) then
  127.     for I := 0 to HookProcList.Count-1 do
  128.       try
  129.         with PHookProcData(HookProcList.List[I])^, PMsg(LParam)^ do
  130.           if hpPostMouseMove in Codes then
  131.             Proc (hpPostMouseMove, hwnd, wParam, lParam);
  132.       except
  133.       end;
  134.   Result := CallNextHookEx(HookHandles[htGetMessage], Code, WParam, LParam);
  135. end;
  136.  
  137. function HookCodesToTypes (Codes: THookProcCodes): THookTypes;
  138. const
  139.   HookCodeToType: array[THookProcCode] of THookType =
  140.     (htCallWndProc, htCallWndProc, htCBT, htGetMessage);
  141. var
  142.   J: THookProcCode;
  143. begin
  144.   Result := [];
  145.   for J := Low(J) to High(J) do
  146.     if J in Codes then
  147.       Include (Result, HookCodeToType[J]);
  148. end;
  149.  
  150. const
  151.   HookProcs: array[THookType] of TFNHookProc =
  152.     (CallWndProcHook, CBTHook, GetMessageHook);
  153.   HookIDs: array[THookType] of Integer =
  154.     (WH_CALLWNDPROC, WH_CBT, WH_GETMESSAGE);
  155.  
  156. procedure InstallHooks (ATypes: THookTypes);
  157. var
  158.   T: THookType;
  159. begin
  160.   for T := Low(T) to High(T) do
  161.     if T in ATypes then begin
  162.       Inc (HookCounts[T]);
  163.       if HookHandles[T] = 0 then
  164.         HookHandles[T] := SetWindowsHookEx(HookIDs[T], HookProcs[T],
  165.           0, GetCurrentThreadId);
  166.     end;
  167. end;
  168.  
  169. procedure UninstallHooks (const ATypes: THookTypes; const Force: Boolean);
  170. var
  171.   T: THookType;
  172. begin
  173.   for T := Low(T) to High(T) do
  174.     if T in ATypes then begin
  175.       if HookCounts[T] > 0 then
  176.         Dec (HookCounts[T]);
  177.       if (Force or (HookCounts[T] = 0)) and (HookHandles[T] <> 0) then begin
  178.         UnhookWindowsHookEx (HookHandles[T]);
  179.         HookHandles[T] := 0;
  180.       end;
  181.     end;
  182. end;
  183.  
  184. procedure InstallHookProc (AProc: THookProc; ACodes: THookProcCodes;
  185.   OnlyIncrementCount: Boolean);
  186. var
  187.   Found: Boolean;
  188.   I: Integer;
  189.   Data: PHookProcData;
  190. begin
  191.   if HookProcList = nil then
  192.     HookProcList := TList.Create;
  193.   Found := False;
  194.   for I := 0 to HookProcList.Count-1 do
  195.     with PHookProcData(HookProcList[I])^ do
  196.       if @Proc = @AProc then begin
  197.         Inc (RefCount);
  198.         Found := True;
  199.         Break;
  200.       end;
  201.   if not Found then begin
  202.     New (Data);
  203.     with Data^ do begin
  204.       Proc := AProc;
  205.       RefCount := 1;
  206.       Codes := ACodes;
  207.     end;
  208.     HookProcList.Add (Data);
  209.   end;
  210.   if not OnlyIncrementCount then
  211.     InstallHooks (HookCodesToTypes(ACodes));
  212. end;
  213.  
  214. procedure UninstallHookProc (AProc: THookProc);
  215. var
  216.   I: Integer;
  217.   Data: PHookProcData;
  218.   T: THookTypes;
  219. begin
  220.   if HookProcList = nil then Exit;
  221.   for I := 0 to HookProcList.Count-1 do begin
  222.     Data := PHookProcData(HookProcList[I]);
  223.     if @Data.Proc = @AProc then begin
  224.       T := HookCodesToTypes(Data.Codes);
  225.       Dec (Data.RefCount);
  226.       if Data.RefCount = 0 then begin
  227.         HookProcList.Delete (I);
  228.         Dispose (Data);
  229.       end;
  230.       UninstallHooks (T, False);
  231.       Break;
  232.     end;
  233.   end;
  234.   if HookProcList.Count = 0 then begin
  235.     HookProcList.Free;
  236.     HookProcList := nil;
  237.   end;
  238. end;
  239.  
  240. function ApplicationIsActive: Boolean;
  241. { Returns True if the application is in the foreground }
  242. begin
  243.   Result := GetActiveWindow <> 0;
  244. end;
  245.  
  246. {$IFNDEF TB97D3}
  247. function CopyPalette (Palette: HPALETTE): HPALETTE;
  248. var
  249.   PaletteSize: Integer;
  250.   LogPal: TMaxLogPalette;
  251. begin
  252.   Result := 0;
  253.   if Palette = 0 then Exit;
  254.   PaletteSize := 0;
  255.   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  256.   if PaletteSize = 0 then Exit;
  257.   with LogPal do begin
  258.     palVersion := $0300;
  259.     palNumEntries := PaletteSize;
  260.     GetPaletteEntries (Palette, 0, PaletteSize, palPalEntry);
  261.   end;
  262.   Result := CreatePalette(PLogPalette(@LogPal)^);
  263. end;
  264. {$ENDIF}
  265.  
  266. procedure ListSortEx (const List: TList; const Compare: TListSortExCompare;
  267.   const ExtraData: Pointer);
  268. { Similar to TList.Sort, but lets you pass a user-defined ExtraData pointer }
  269.   procedure QuickSortEx (L: Integer; const R: Integer);
  270.   var
  271.     I, J: Integer;
  272.     P: Pointer;
  273.   begin
  274.     repeat
  275.       I := L;
  276.       J := R;
  277.       P := List[(L + R) shr 1];
  278.       repeat
  279.         while Compare(List[I], P, ExtraData) < 0 do Inc(I);
  280.         while Compare(List[J], P, ExtraData) > 0 do Dec(J);
  281.         if I <= J then
  282.         begin
  283.           List.Exchange (I, J);
  284.           Inc (I);
  285.           Dec (J);
  286.         end;
  287.       until I > J;
  288.       if L < J then QuickSortEx (L, J);
  289.       L := I;
  290.     until I >= R;
  291.   end;
  292. begin
  293.   if List.Count > 1 then
  294.     QuickSortEx (0, List.Count-1);
  295. end;
  296.  
  297. procedure SelectNCUpdateRgn (Wnd: HWND; DC: HDC; Rgn: HRGN);
  298. var
  299.   R: TRect;
  300.   NewClipRgn: HRGN;
  301. begin
  302.   if (Rgn <> 0) and (Rgn <> 1) then begin
  303.     GetWindowRect (Wnd, R);
  304.     if SelectClipRgn(DC, Rgn) = ERROR then begin
  305.       NewClipRgn := CreateRectRgnIndirect(R);
  306.       SelectClipRgn (DC, NewClipRgn);
  307.       DeleteObject (NewClipRgn);
  308.     end;
  309.     OffsetClipRgn (DC, -R.Left, -R.Top);
  310.   end;
  311. end;
  312.  
  313. type
  314.   PPrintEnumProcData = ^TPrintEnumProcData;
  315.   TPrintEnumProcData = record
  316.     PrintChildren: Boolean;
  317.     ParentWnd: HWND;
  318.     DC: HDC;
  319.     PrintFlags: LPARAM;
  320.   end;
  321.  
  322. function PrintEnumProc (Wnd: HWND; LParam: LPARAM): BOOL; stdcall;
  323. var
  324.   R: TRect;
  325.   SaveIndex: Integer;
  326. begin
  327.   Result := True;  { continue enumerating }
  328.   with PPrintEnumProcData(LParam)^ do begin
  329.     { Skip window if it isn't a child/owned window of ParentWnd or isn't visible }
  330.     if (HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) <> ParentWnd) or
  331.        (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then
  332.          { ^ don't use IsWindowVisible since it returns False if the window's
  333.            parent window is not visible }
  334.       Exit;
  335.     GetWindowRect (Wnd, R);
  336.     MapWindowPoints (0, ParentWnd, R, 2);
  337.     SaveIndex := SaveDC(DC);
  338.     { Like Windows, offset the window origin to the top-left coordinates of
  339.       the child/owned window }
  340.     MoveWindowOrg (DC, R.Left, R.Top);
  341.     { Like Windows, intersect the clipping region with the entire rectangle of
  342.       the child/owned window }
  343.     OffsetRect (R, -R.Left, -R.Top);
  344.     IntersectClipRect (DC, R.Left, R.Top, R.Right, R.Bottom);
  345.     { Send a WM_PRINT message to the child/owned window }
  346.     SendMessage (Wnd, WM_PRINT, WPARAM(DC), PrintFlags);
  347.     { Restore the DC's state, in case the WM_PRINT handler didn't put things
  348.       back the way it found them }
  349.     RestoreDC (DC, SaveIndex);
  350.   end;
  351. end;
  352.  
  353. procedure HandleWMPrint (const Wnd: HWND; var Message: TMessage;
  354.   const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: Longint);
  355. { note: AppData is an application-defined value which is passed to NCPaintFunc }
  356. var
  357.   DC: HDC;
  358.   SaveIndex, SaveIndex2: Integer;
  359.   R: TRect;
  360.   P: TPoint;
  361.   Data: TPrintEnumProcData;
  362. begin
  363.   if (Message.LParam and PRF_CHECKVISIBLE = 0) or IsWindowVisible(Wnd) then begin
  364.     DC := HDC(Message.WParam);
  365.     SaveIndex2 := SaveDC(DC);
  366.     try
  367.       if Message.LParam and PRF_NONCLIENT <> 0 then begin
  368.         SaveIndex := SaveDC(DC);
  369.         if Assigned(NCPaintFunc) then
  370.           NCPaintFunc (Wnd, DC, AppData);
  371.         RestoreDC (DC, SaveIndex);
  372.       end;
  373.       { Calculate the difference between the top-left corner of the window
  374.         and the top-left corner of its client area }
  375.       GetWindowRect (Wnd, R);
  376.       P.X := 0;  P.Y := 0;
  377.       ClientToScreen (Wnd, P);
  378.       Dec (P.X, R.Left);  Dec (P.Y, R.Top);
  379.       if Message.LParam and PRF_CLIENT <> 0 then begin
  380.         { Like Windows, the flags PRF_ERASEBKGND, PRF_CHILDREN, and PRF_OWNED
  381.           are ignored if PRF_CLIENT isn't also specified }
  382.         if Message.LParam and PRF_ERASEBKGND <> 0 then begin
  383.           { Send WM_ERASEBKGND }
  384.           SaveIndex := SaveDC(DC);
  385.           if Message.LParam and PRF_NONCLIENT <> 0 then
  386.             MoveWindowOrg (DC, P.X, P.Y);
  387.           SendMessage (Wnd, WM_ERASEBKGND, Message.WParam, 0);
  388.           RestoreDC (DC, SaveIndex);
  389.         end;
  390.         { Send WM_PRINTCLIENT }
  391.         SaveIndex := SaveDC(DC);
  392.         if Message.LParam and PRF_NONCLIENT <> 0 then
  393.           MoveWindowOrg (DC, P.X, P.Y);
  394.         SendMessage (Wnd, WM_PRINTCLIENT, Message.WParam, 0);
  395.         RestoreDC (DC, SaveIndex);
  396.         { Like Windows, always offset child/owned windows by the size of the
  397.           client area even if PRF_NONCLIENT isn't specified (a bug?) }
  398.         MoveWindowOrg (DC, P.X, P.Y);
  399.         Data.ParentWnd := Wnd;
  400.         Data.DC := DC;
  401.         { Send WM_PRINT to child/owned windows }
  402.         if Message.LParam and PRF_CHILDREN <> 0 then begin
  403.           Data.PrintChildren := True;
  404.           Data.PrintFlags := PRF_NONCLIENT or PRF_CLIENT or PRF_ERASEBKGND or
  405.             PRF_CHILDREN;  { same flags as Windows passes to children }
  406.           EnumChildWindows (Wnd, @PrintEnumProc, LPARAM(@Data));
  407.         end;
  408.         if Message.LParam and PRF_OWNED <> 0 then begin
  409.           Data.PrintChildren := False;
  410.           Data.PrintFlags := Message.LParam;
  411.           EnumWindows (@PrintEnumProc, LPARAM(@Data));
  412.         end;
  413.       end;
  414.     finally
  415.       RestoreDC (DC, SaveIndex2);
  416.     end;
  417.   end;
  418.   { Windows' WM_PRINT returns 1. I'm not sure why. }
  419.   Message.Result := 1;
  420. end;
  421.  
  422. type
  423.   TWinControlAccess = class(TWinControl);
  424.  
  425. procedure HandleWMPrintClient (const Control: TWinControl; var Message: TMessage);
  426. var
  427.   Msg: TWMPaint;
  428.   SaveIndex: Integer;
  429. begin
  430.   Msg.Msg := WM_PAINT;
  431.   Msg.DC := HDC(Message.WParam);
  432.   Msg.Unused := 0;
  433.   Msg.Result := 0;
  434.   SaveIndex := SaveDC(HDC(Message.WParam));
  435.   try
  436.     TWinControlAccess(Control).PaintHandler (Msg);
  437.   finally
  438.     RestoreDC (HDC(Message.WParam), SaveIndex);
  439.   end;
  440. end;
  441.  
  442.  
  443. initialization
  444. finalization
  445.   UninstallHooks ([Low(THookType)..High(THookType)], True);
  446.   HookProcList.Free;
  447.   { Following line needed because, under certain circumstances, HookProcList
  448.     may be referenced after the 'finalization' section is processed. (This
  449.     can happen if a 'Halt' call is placed in the main form's OnCreate
  450.     handler, for example.) }
  451.   HookProcList := nil;
  452. end.
  453.