source: cprs/trunk/CPRS-Chart/fBase508Form.pas@ 842

Last change on this file since 842 was 830, checked in by Kevin Toppenberg, 14 years ago

Upgrading to version 27

File size: 7.9 KB
Line 
1unit fBase508Form;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 Dialogs, StdCtrls, ExtCtrls, VA508AccessibilityManager, OR2006Compatibility, uConst;
8
9type
10 TAccessibilityAction = (aaColorConversion, aaTitleBarHeightAdjustment,
11 aaFixTabStopArrowNavigationBug);
12 TAccessibilityActions = set of TAccessibilityAction;
13
14 TfrmBase508Form = class(Tfrm2006Compatibility)
15 amgrMain: TVA508AccessibilityManager;
16 procedure FormKeyDown(Sender: TObject; var Key: Word;
17 Shift: TShiftState);
18 private
19 FLoadedCalled: boolean;
20 FDefaultButton: TButton;
21 FActions: TAccessibilityActions;
22 FUnfocusableControlPtr: TMethod;
23 procedure AdjustForTitleBarHeightChanges;
24 function GetDefaultButton(OwnerComponent: TComponent) : TButton;
25 procedure ClickDefaultButton;
26 procedure SetDefaultButton(const Value: TButton);
27 procedure ModifyUnfocusableControl(Control: TWinControl; Attach: boolean);
28 procedure UM508(var Message: TMessage); message UM_508;
29 protected
30 procedure Activate; override;
31 procedure Loaded; override;
32 procedure SetParent(AParent: TWinControl); override;
33 procedure Notification(AComponent: TComponent;
34 Operation: TOperation); override;
35 procedure UpdateAccessabilityActions(var Actions: TAccessibilityActions); virtual;
36 public
37 constructor Create(AOwner: TComponent); override;
38 property DefaultButton : TButton read FDefaultButton write SetDefaultButton;
39 end;
40
41var
42 Last508KeyCode: LongInt = 0;
43
44procedure UnfocusableControlEnter(Self, Sender: TObject);
45
46implementation
47
48uses ORFn, VA508AccessibilityRouter, VAUtils;
49
50{$R *.dfm}
51
52const
53 MSG_508_CODE_TITLE_BAR = 1;
54
55type
56 TFriendWinControl = class(TWinControl);
57
58procedure UnfocusableControlEnter(Self, Sender: TObject);
59var
60 ctrl: TWinControl;
61begin
62 if (Last508KeyCode = VK_UP) or (Last508KeyCode = VK_LEFT) then
63 begin
64 ctrl := TWinControl(Sender);
65 ctrl := TFriendWinControl(ctrl.Parent).FindNextControl(ctrl, FALSE, TRUE, FALSE);
66 if assigned(ctrl) and (ctrl <> Sender) then
67 ctrl.SetFocus;
68 Last508KeyCode := 0;
69 end
70 else
71 if (Last508KeyCode = VK_DOWN) or (Last508KeyCode = VK_RIGHT) then
72 begin
73 keybd_event(VK_TAB,0,0,0);
74 keybd_event(VK_TAB,0,KEYEVENTF_KEYUP,0);
75 Last508KeyCode := 0;
76 end;
77end;
78
79{ TfrmBase508Form }
80
81// All forms in CPRS should be a descendant of this form, even those that are programatically
82// made children of other forms.
83procedure TfrmBase508Form.Activate;
84begin
85 Last508KeyCode := 0;
86 inherited;
87end;
88
89procedure TfrmBase508Form.AdjustForTitleBarHeightChanges;
90var
91 OldResize: TNotifyEvent;
92begin
93 if parent <> nil then exit;
94 OldResize := OnResize;
95 try
96 OnResize := nil;
97 AdjustForWindowsXPStyleTitleBar(Self);
98 finally
99 OnResize := OldResize;
100 end;
101end;
102
103procedure TfrmBase508Form.FormKeyDown(Sender: TObject; var Key: Word;
104 Shift: TShiftState);
105begin
106 if (Key = VK_RETURN) and (ssCtrl in Shift) then begin
107 ClickDefaultButton;
108 Key := 0;
109 end;
110end;
111
112procedure TfrmBase508Form.Notification(AComponent: TComponent;
113 Operation: TOperation);
114begin
115 inherited Notification(AComponent, Operation);
116 if FLoadedCalled and (aaFixTabStopArrowNavigationBug in FActions) and (AComponent is TWinControl) then
117 begin
118 ModifyUnfocusableControl(TWinControl(AComponent), Operation = opInsert);
119 end;
120end;
121
122function TfrmBase508Form.GetDefaultButton(ownerComponent: TComponent): TButton;
123var
124 i : integer;
125begin
126 Result := nil;
127 with ownerComponent do begin
128 for i := 0 to ComponentCount - 1 do begin
129 if Components[i] is TButton then begin
130 if TButton(Components[i]).Default then
131 Result := TButton(Components[i]);
132 end
133 else if Components[i] is TFrame then
134 Result := GetDefaultButton(Components[i]);
135 if Assigned(Result) then
136 Break;
137 end;
138 end;
139end;
140
141procedure TfrmBase508Form.Loaded;
142begin
143 inherited Loaded;
144 FLoadedCalled := TRUE;
145end;
146
147procedure TfrmBase508Form.ModifyUnfocusableControl(Control: TWinControl; Attach: boolean);
148var
149 wc: TFriendWinControl;
150begin
151 if (Control is TPanel) or (Control is TCustomGroupBox) then
152 begin
153 wc := TFriendWinControl(Control);
154 if not wc.TabStop then
155 begin
156 if not assigned(wc.OnEnter) then
157 begin
158 if Attach then
159 wc.OnEnter := TNotifyEvent(FUnfocusableControlPtr);
160 end
161 else
162 begin
163 if (not Attach) and (TMethod(wc.OnEnter).Code = FUnfocusableControlPtr.Code) then
164 wc.OnEnter := nil;
165 end;
166 end;
167 end;
168end;
169
170procedure TfrmBase508Form.SetDefaultButton(const Value: TButton);
171begin
172 FDefaultButton := Value;
173end;
174
175procedure TfrmBase508Form.SetParent(AParent: TWinControl);
176begin
177 inherited SetParent(AParent);
178 if assigned(AParent) then
179 AutoScroll := False;
180end;
181
182// to prevent a 508 feature from taking place, remove that feature's flag form the Actions set
183// in an override of the UpdateAccessabilityActions proc.
184procedure TfrmBase508Form.UM508(var Message: TMessage);
185begin
186 case Message.WParam of
187 MSG_508_CODE_TITLE_BAR: AdjustForTitleBarHeightChanges;
188 end;
189end;
190
191procedure TfrmBase508Form.UpdateAccessabilityActions(var Actions: TAccessibilityActions);
192begin
193end;
194
195type
196 TExposedBtn = class(TButton);
197
198procedure TfrmBase508Form.ClickDefaultButton;
199var
200 tempDefaultBtn: TButton;
201begin
202 if Assigned(DefaultButton) then
203 tempDefaultBtn := DefaultButton
204 else
205 tempDefaultBtn := GetDefaultButton(Self);
206 if Assigned(tempDefaultBtn) then
207 if tempDefaultBtn.Visible then
208 TExposedBtn(tempDefaultBtn).Click;
209end;
210
211constructor TfrmBase508Form.Create(AOwner: TComponent);
212
213 procedure AdjustControls(Control: TWinControl);
214 var
215 i: integer;
216 wc: TWinControl;
217 begin
218 for I := 0 to Control.ControlCount-1 do
219 begin
220 if Control.Controls[i] is TWinControl then
221 begin
222 wc := TWinControl(Control.Controls[i]);
223 if not wc.TabStop then
224 ModifyUnfocusableControl(wc, TRUE);
225 AdjustControls(wc);
226 end;
227 end;
228 end;
229
230begin
231 inherited Create(AOwner);
232 if not assigned(Parent) then
233 AutoScroll := True;
234 FActions := [aaColorConversion, aaTitleBarHeightAdjustment, aaFixTabStopArrowNavigationBug];
235 UpdateAccessabilityActions(FActions);
236 if aaColorConversion in FActions then
237 UpdateColorsFor508Compliance(Self);
238
239 if aaTitleBarHeightAdjustment in FActions then
240 PostMessage(Handle, UM_508, MSG_508_CODE_TITLE_BAR, 0);
241
242 if aaFixTabStopArrowNavigationBug in FActions then
243 begin
244 FUnfocusableControlPtr.Code := @UnfocusableControlEnter;
245 FUnfocusableControlPtr.Data := nil;
246 AdjustControls(Self);
247 end;
248 Last508KeyCode := 0;
249end;
250
251const
252 KEY_MASK = $20000000; // ignore Alt keys
253var
254 KeyMonitorHook: HHOOK;
255 MouseMonitorHook: HHOOK;
256
257function KeyMonitorProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
258begin
259 if (code = HC_ACTION) and ((lParam and KEY_MASK) = 0) then
260 Last508KeyCode := wParam;
261 Result := CallNextHookEx(KeyMonitorHook, Code, wParam, lParam);
262end;
263
264// if mouse click clear last key code
265function MouseMonitorProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
266begin
267 if (Code = HC_ACTION) and (wParam > WM_MOUSEFIRST) and (wParam <= WM_MOUSELAST) then
268 Last508KeyCode := 0;
269 Result := CallNextHookEx(MouseMonitorHook, Code, wParam, lParam);
270end;
271
272initialization
273 KeyMonitorHook := SetWindowsHookEx(WH_KEYBOARD, KeyMonitorProc, 0, GetCurrentThreadID);
274 MouseMonitorHook := SetWindowsHookEx(WH_MOUSE, MouseMonitorProc, 0, GetCurrentThreadID);
275
276 SpecifyFormIsNotADialog(TfrmBase508Form);
277 SpecifyFormIsNotADialog(Tfrm2006Compatibility);
278
279finalization
280 UnhookWindowsHookEx(KeyMonitorHook);
281 UnhookWindowsHookEx(MouseMonitorHook);
282
283end.
Note: See TracBrowser for help on using the repository browser.