source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/EwbMouseHook.pas@ 1802

Last change on this file since 1802 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 7.8 KB
Line 
1//***********************************************************
2// EwbMouseHook unit *
3// *
4// For Delphi 5 to 2009 *
5// Freeware Component *
6// by *
7// (smot) *
8// *
9// Documentation and updated versions: *
10// *
11// http://www.bsalsa.com *
12//***********************************************************
13{*******************************************************************************}
14{LICENSE:
15THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
16EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
17WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
18YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
19AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
20AND DOCUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
21OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
22OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
23INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
24OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
25AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. BSALSA PRODUCTIONS SPECIFICALLY
26DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
27
28You may use, change or modify the component under 4 conditions:
291. In your website, add a link to "http://www.bsalsa.com"
302. In your application, add credits to "Embedded Web Browser"
313. Mail me (bsalsa@gmail.com) any code change in the unit
32 for the benefit of the other users.
334. Please, consider donation in our web site!
34{*******************************************************************************}
35
36unit EwbMouseHook;
37
38interface
39
40{$I EWB.inc}
41
42uses
43 Windows, Messages, Classes, Forms, Controls;
44
45// -- TEWBMouseHook ------------------------------------------------------------
46
47type
48 TFNMouseProc = function(nCode: Integer; wp: WPARAM; lp: WParam): LRESULT
49 stdcall;
50 TFNMouseMethod = function(nCode: Integer; wp: WPARAM; lp: WParam): LRESULT
51 stdcall of object;
52 TMouseWheelEvent = procedure(Point: TPoint; hwndFromPoint: HWND; lp: LPARAM;
53 var Handled: Boolean) of object;
54
55type
56 TEWBMouseHook = class(TObject)
57 private
58 FMouseHook: HHOOK;
59 FMouseHookProc: TFNMouseProc;
60 FMouseHookMethod: TFNMouseMethod;
61 function LocalMouseProc(nCode: Integer; wp: WPARAM; lp: LPARAM): LRESULT
62 stdcall;
63 public
64 OnMouseWheel: TMouseWheelEvent;
65 FActiveFormOnly: Boolean;
66 class function NewInstance: TObject; override;
67 procedure FreeInstance; override;
68 constructor Create;
69 destructor Destroy; override;
70 procedure Activate;
71 procedure Deactivate;
72 end;
73
74var
75 EWBEnableMouseWheelFix: Boolean = True; // DO NOT CHANGE HERE
76
77implementation
78
79uses
80 EWBCoreTools;
81
82{$IFDEF DELPHI5}
83type
84 TMethod = record
85 Code, Data: Pointer;
86 end;
87{$ENDIF}
88
89var
90 GEWBMouseHook: TEWBMouseHook = nil;
91 GRefCount: Integer = 0;
92
93 // MakeStdcallCallback (thunk to use stdcall method as static callback)
94
95function MakeStdcallCallback(const Method: TMethod): Pointer;
96type
97 PCallbackCode = ^TCallbackCode;
98 TCallbackCode = packed record
99 Ops1: array[0..2] of Longword;
100 Val1: Pointer;
101 Ops2: array[0..1] of Longword;
102 Val2: Pointer;
103 end;
104begin
105 Result := VirtualAlloc(nil, $100, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
106 if Assigned(Result) then
107 try
108 with PCallbackCode(Result)^ do
109 begin
110 Ops1[0] := $448B5050;
111 Ops1[1] := $44890824;
112 Ops1[2] := $058B0424;
113 Val1 := Addr(Method.Data);
114 Ops2[0] := $08244489;
115 Ops2[1] := $25FF9058;
116 Val2 := Addr(Method.Code);
117 end;
118 except
119 VirtualFree(Result, 0, MEM_RELEASE);
120 Result := nil;
121 end;
122end;
123
124procedure FreeCallback(Callback: Pointer);
125begin
126 if Assigned(Callback) then
127 VirtualFree(Callback, 0, MEM_RELEASE);
128end;
129
130function TEWBMouseHook.LocalMouseProc(nCode: Integer; wp: WPARAM; lp: LPARAM):
131 LRESULT stdcall;
132var
133 bHandled, bCancel: Boolean;
134 mhs: TMouseHookStruct;
135 hwndCurrentFocus: HWND;
136 P: TPoint;
137 hwndFromPoint, hwndFocusShellEmbedding, hwndWFPShellEmbedding: HWND;
138 WinControl: TWinControl;
139 ParentForm: TCustomForm;
140begin
141 if nCode < 0 then
142 Result := CallNextHookEx(FMouseHook, nCode, wp, LPARAM(lp))
143 else
144 begin
145 bHandled := False;
146 if (wp = WM_MOUSEWHEEL) and (nCode = HC_ACTION) then
147 begin
148 mhs := PMouseHookStruct(lp)^;
149 P := Point(mhs.pt.X, mhs.pt.Y);
150 hwndFromPoint := WindowFromPoint(P);
151 // Handle OnMouseWheel
152 bCancel := False;
153 if Assigned(OnMouseWheel) then
154 OnMouseWheel(P, hwndFromPoint, lp, bCancel);
155 // Handle ActiveFormOnly
156 if FActiveFormOnly then
157 begin
158 WinControl := FindVCLWindow(P);
159 if Assigned(WinControl) then
160 begin
161 ParentForm := GetParentForm(WinControl);
162 if Assigned(ParentForm) then
163 bCancel := ParentForm <> Screen.ActiveForm;
164 end;
165 end;
166
167 if not bCancel then
168 if hwndFromPoint <> 0 then
169 begin
170 hwndCurrentFocus := GetFocus;
171 if hwndCurrentFocus <> 0 then
172 begin
173 hwndWFPShellEmbedding := GetParentWinByClass(hwndFromPoint,
174 'Shell Embedding');
175 if (hwndWFPShellEmbedding <> 0) then
176 // Parent of WindowFromPoint is WB
177 begin
178 hwndFocusShellEmbedding :=
179 GetParentWinByClass(hwndCurrentFocus,
180 'Shell Embedding');
181 if (hwndWFPShellEmbedding <> hwndFocusShellEmbedding) or
182 (GetWinClass(hwndCurrentFocus) =
183 'Shell DocObject View') then
184 // Only handle if WB has not the focus or other WB has the focus
185 begin
186 bHandled := True;
187 Windows.SetFocus(hwndFromPoint);
188 end;
189 end;
190 end;
191 end;
192 end;
193 if bHandled then
194 Result := HC_SKIP
195 else
196 Result := CallNextHookEx(FMouseHook, nCode, wp, lp);
197 end;
198end;
199
200class function TEWBMouseHook.NewInstance: TObject;
201begin
202 if not Assigned(GEWBMouseHook) then
203 begin
204 GEWBMouseHook := TEWBMouseHook(inherited NewInstance);
205 GEWBMouseHook.FActiveFormOnly := False;
206 end;
207 Result := GEWBMouseHook;
208 Inc(GRefCount);
209end;
210
211procedure TEWBMouseHook.FreeInstance;
212begin
213 Dec(GRefCount);
214 if GRefCount = 0 then
215 begin
216 GEWBMouseHook := nil;
217 inherited FreeInstance;
218 end;
219end;
220
221procedure TEWBMouseHook.Activate;
222begin
223 if (FMouseHook = 0) and EWBEnableMouseWheelFix then
224 begin
225 FMouseHookMethod := LocalMouseProc;
226 FMouseHookProc :=
227 TFNMouseProc(MakeStdcallCallback(TMethod(FMouseHookMethod)));
228 FMouseHook := SetWindowsHookEx(WH_MOUSE, TFNHookProc(FMouseHookProc), 0,
229 GetCurrentThreadID);
230 end;
231end;
232
233procedure TEWBMouseHook.Deactivate;
234begin
235 if FMouseHook <> 0 then
236 begin
237 if UnhookWindowsHookEx(FMouseHook) then
238 FMouseHook := 0;
239 end;
240 if Assigned(FMouseHookProc) then
241 begin
242 FreeCallback(Addr(FMouseHookProc));
243 FMouseHookProc := nil;
244 end;
245end;
246
247constructor TEWBMouseHook.Create;
248begin
249 inherited;
250 // if (GRefCount = 1) then
251end;
252
253destructor TEWBMouseHook.Destroy;
254begin
255 inherited;
256 // if ((GRefCount <= 1)) then
257end;
258
259end.
Note: See TracBrowser for help on using the repository browser.