home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue33 / system / MouseWheel.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-04-06  |  6.6 KB  |  181 lines
  1. unit MouseWheel;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  7.  
  8. type
  9.     TOnWheelSpin = procedure (Count: Integer) of Object;
  10.  
  11.     TMouseWheel = class(TObject)
  12.     private
  13.         { Private declarations }
  14.         fNative: Boolean;
  15.         fWheelPresent: Boolean;
  16.         fScrollLines: Integer;
  17.         fWheelMessage: UINT;
  18.         fActiveForm: TForm;
  19.         fDelta: SmallInt;
  20.         fOnWheelSpin: TOnWheelSpin;
  21.         fOldWndProc: Integer;
  22.         constructor Create;
  23.         destructor Destroy; override;
  24.         procedure SetActiveForm (Value: TForm);
  25.         function NativeMouseWheelSupport: Boolean;
  26.         procedure SetOnWheelSpin (Value: TOnWheelSpin);
  27.     protected
  28.         { Protected declarations }
  29.         procedure NewWindowProc (var Message: TMessage);
  30.         function ProcessWheelMessage (Wnd: hWnd; var Message: TMessage): LongInt;
  31.     public
  32.         { Public declarations }
  33.         property Native: Boolean read fNative;
  34.         property WheelPresent: Boolean read fWheelPresent;
  35.         property WheelMessage: UINT read fWheelMessage;
  36.         property ScrollLines: Integer read fScrollLines;
  37.         property ActiveForm: TForm read fActiveForm write SetActiveForm;
  38.         property OnWheelSpin: TOnWheelSpin read fOnWheelSpin write SetOnWheelSpin;
  39.     published
  40.         { Published declarations }
  41.     end;
  42.  
  43. var
  44.     Wheel: TMouseWheel;
  45.  
  46. implementation
  47.  
  48. constructor TMouseWheel.Create;
  49. var
  50.     hWndMouse: hWnd;
  51.     mQueryScrollLines: UINT;
  52. begin
  53.     Inherited Create;
  54.     if NativeMouseWheelSupport then begin
  55.         fNative := True;
  56.         fWheelPresent := Boolean (GetSystemMetrics (sm_MouseWheelPresent));
  57.         SystemParametersInfo (spi_GetWheelScrollLines, 0, @fScrollLines, 0);
  58.         fWheelMessage := wm_MouseWheel;
  59.     end else begin
  60.         fNative := False;
  61.         { Look for hidden mouse window }
  62.         hWndMouse := FindWindow ('MouseZ', 'Magellan MSWHEEL');
  63.         if hWndMouse <> 0 then begin
  64.        { We're in business - get the scroll line info }
  65.        fWheelPresent := True;
  66.            mQueryScrollLines := RegisterWindowMessage ('MSH_SCROLL_LINES_MSG');
  67.            fScrollLines := SendMessage (hWndMouse, mQueryScrollLines, 0, 0);
  68.            { Finally, get the custom mouse message as well }
  69.            fWheelMessage := RegisterWindowMessage ('MSWHEEL_ROLLMSG');
  70.         end;
  71.     end;
  72.  
  73.     if (fScrollLines < 0) or (fScrollLines > 100) then fScrollLines := 3;
  74. end;
  75.  
  76. destructor TMouseWheel.Destroy;
  77. begin
  78.     SetActiveForm (Nil);
  79.     Inherited Destroy;
  80. end;
  81.  
  82. function TMouseWheel.NativeMouseWheelSupport: Boolean;
  83. var
  84.     ver: TOSVersionInfo;
  85. begin
  86.     Result := False;
  87.     ver.dwOSVersionInfoSize := sizeof (ver);
  88.     // For Windows 98, assume dwMajorVersion = 5 (It's 4 for W95)
  89.     // For NT, we need 4.0 or better.
  90.     if GetVersionEx (ver) then case ver.dwPlatformID of
  91.         ver_Platform_Win32_Windows: Result := ver.dwMajorVersion >= 5;
  92.         ver_Platform_Win32_NT:      Result := ver.dwMajorVersion >= 4;
  93.     end;
  94.  
  95.     { Quick and dirty temporary hack for Windows 98 beta 3 }
  96.     if (Result = False) and (ver.szCSDVersion = ' Beta 3') then Result := True;
  97. end;
  98.  
  99. procedure TMouseWheel.SetOnWheelSpin (Value: TOnWheelSpin);
  100. begin
  101.     if fWheelPresent then fOnWheelSpin := Value;
  102. end;
  103.  
  104. procedure TMouseWheel.SetActiveForm (Value: TForm);
  105. begin
  106.     if fWheelPresent and (Value <> fActiveForm) then begin
  107.         { Unsubclass the current form }
  108.         if (fActiveForm <> Nil) and IsWindow (fActiveForm.Handle) then begin
  109.             SetWindowLong (fActiveForm.Handle, gwl_WndProc, fOldWndProc);
  110.             RemoveProp (fActiveForm.Handle, 'MouseWheelProp');
  111.         end;
  112.  
  113.         { Subclass the current form }
  114.         fActiveForm := Value;  fDelta := 0;
  115.         if (fActiveForm <> Nil) and IsWindow (fActiveForm.Handle) then begin
  116.             fOldWndProc := SetWindowLong (fActiveForm.Handle, gwl_WndProc, LongInt (MakeObjectInstance (NewWindowProc)));
  117.             SetProp (fActiveForm.Handle, 'MouseWheelProp', Integer(Self));
  118.         end;
  119.     end;
  120. end;
  121.  
  122. procedure TMouseWheel.NewWindowProc (var Message: TMessage);
  123. var
  124.     Hackomatic: TOnWheelSpin;
  125.     HackomaticAlias: TPoint absolute Hackomatic;
  126. begin
  127.     if (Message.Msg = fWheelMessage) or (Message.Msg = wm_MouseWheel) then Message.Result := ProcessWheelMessage (fActiveForm.Handle, Message)
  128.     else Message.Result := CallWindowProc (Pointer(fOldWndProc), fActiveForm.Handle, Message.Msg, Message.WParam, Message.lParam);
  129.     { Check if it's time to abandon ship....window handle still valid until after wm_NCDestroy }
  130.     if Message.Msg = wm_Destroy then begin
  131.         { Special check - is fOnWheelSpin  a method of form being destroyed ? }
  132.         Hackomatic := fOnWheelSpin;
  133.         if Assigned (fOnWheelSpin) and
  134.            (TObject (HackomaticAlias.y) is TForm) and
  135.            (TForm (HackomaticAlias.y).Handle = fActiveForm.Handle) then fOnWheelSpin := Nil;
  136.         SetActiveForm (Nil);
  137.     end;
  138. end;
  139.  
  140. function TMouseWheel.ProcessWheelMessage (Wnd: hWnd; var Message: TMessage): LongInt;
  141. var
  142.     Idx: Integer;
  143.  
  144.     function GetShiftState: Integer;
  145.     begin
  146.         Result := 0;
  147.         if GetAsyncKeyState (vk_Shift)   < 0 then Result := Result or mk_Shift;
  148.         if GetAsyncKeyState (vk_Control) < 0 then Result := Result or mk_Control;
  149.         if GetAsyncKeyState (vk_LButton) < 0 then Result := Result or mk_LButton;
  150.         if GetAsyncKeyState (vk_RButton) < 0 then Result := Result or mk_RButton;
  151.         if GetAsyncKeyState (vk_MButton) < 0 then Result := Result or mk_MButton;
  152.     end;
  153.  
  154. begin
  155.     Result := 0;
  156.     if not IsWindow (Wnd) then Exit; { Just in case.... }
  157.  
  158.     { Is this a non-native call?  If so, convert to native and repost }
  159.     if Message.Msg <> wm_MouseWheel then PostMessage (Wnd, wm_MouseWheel, MakeLong (GetShiftState, Message.wParam), Message.lParam)
  160.     else begin
  161.         fDelta := fDelta + HiWord (Message.wParam);
  162.         while Abs(fDelta) >= 120 do begin
  163.             if fDelta < 0 then begin
  164.                 if Assigned (fOnWheelSpin) then fOnWheelSpin (fScrollLines) else
  165.                     for Idx := 0 to fScrollLines - 1 do PostMessage (Wnd, wm_VScroll, MakeLong (sb_LineDown, 0), 0);
  166.                 fDelta := fDelta + 120;
  167.             end else begin
  168.                 if Assigned (fOnWheelSpin) then fOnWheelSpin (-fScrollLines) else
  169.                     for Idx := 0 to fScrollLines - 1 do PostMessage (Wnd, wm_VScroll, MakeLong (sb_LineUp, 0), 0);
  170.                 fDelta := fDelta - 120;
  171.             end;
  172.         end;
  173.     end;
  174. end;
  175.  
  176. initialization
  177.     Wheel := TMouseWheel.Create;
  178. finalization
  179.     Wheel.Free;
  180. end.
  181.