1 | unit fBase508Form;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
---|
7 | Dialogs, StdCtrls, ExtCtrls, VA508AccessibilityManager, OR2006Compatibility, uConst;
|
---|
8 |
|
---|
9 | type
|
---|
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 |
|
---|
41 | var
|
---|
42 | Last508KeyCode: LongInt = 0;
|
---|
43 |
|
---|
44 | procedure UnfocusableControlEnter(Self, Sender: TObject);
|
---|
45 |
|
---|
46 | implementation
|
---|
47 |
|
---|
48 | uses ORFn, VA508AccessibilityRouter, VAUtils;
|
---|
49 |
|
---|
50 | {$R *.dfm}
|
---|
51 |
|
---|
52 | const
|
---|
53 | MSG_508_CODE_TITLE_BAR = 1;
|
---|
54 |
|
---|
55 | type
|
---|
56 | TFriendWinControl = class(TWinControl);
|
---|
57 |
|
---|
58 | procedure UnfocusableControlEnter(Self, Sender: TObject);
|
---|
59 | var
|
---|
60 | ctrl: TWinControl;
|
---|
61 | begin
|
---|
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;
|
---|
77 | end;
|
---|
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.
|
---|
83 | procedure TfrmBase508Form.Activate;
|
---|
84 | begin
|
---|
85 | Last508KeyCode := 0;
|
---|
86 | inherited;
|
---|
87 | end;
|
---|
88 |
|
---|
89 | procedure TfrmBase508Form.AdjustForTitleBarHeightChanges;
|
---|
90 | var
|
---|
91 | OldResize: TNotifyEvent;
|
---|
92 | begin
|
---|
93 | if parent <> nil then exit;
|
---|
94 | OldResize := OnResize;
|
---|
95 | try
|
---|
96 | OnResize := nil;
|
---|
97 | AdjustForWindowsXPStyleTitleBar(Self);
|
---|
98 | finally
|
---|
99 | OnResize := OldResize;
|
---|
100 | end;
|
---|
101 | end;
|
---|
102 |
|
---|
103 | procedure TfrmBase508Form.FormKeyDown(Sender: TObject; var Key: Word;
|
---|
104 | Shift: TShiftState);
|
---|
105 | begin
|
---|
106 | if (Key = VK_RETURN) and (ssCtrl in Shift) then begin
|
---|
107 | ClickDefaultButton;
|
---|
108 | Key := 0;
|
---|
109 | end;
|
---|
110 | end;
|
---|
111 |
|
---|
112 | procedure TfrmBase508Form.Notification(AComponent: TComponent;
|
---|
113 | Operation: TOperation);
|
---|
114 | begin
|
---|
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;
|
---|
120 | end;
|
---|
121 |
|
---|
122 | function TfrmBase508Form.GetDefaultButton(ownerComponent: TComponent): TButton;
|
---|
123 | var
|
---|
124 | i : integer;
|
---|
125 | begin
|
---|
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;
|
---|
139 | end;
|
---|
140 |
|
---|
141 | procedure TfrmBase508Form.Loaded;
|
---|
142 | begin
|
---|
143 | inherited Loaded;
|
---|
144 | FLoadedCalled := TRUE;
|
---|
145 | end;
|
---|
146 |
|
---|
147 | procedure TfrmBase508Form.ModifyUnfocusableControl(Control: TWinControl; Attach: boolean);
|
---|
148 | var
|
---|
149 | wc: TFriendWinControl;
|
---|
150 | begin
|
---|
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;
|
---|
168 | end;
|
---|
169 |
|
---|
170 | procedure TfrmBase508Form.SetDefaultButton(const Value: TButton);
|
---|
171 | begin
|
---|
172 | FDefaultButton := Value;
|
---|
173 | end;
|
---|
174 |
|
---|
175 | procedure TfrmBase508Form.SetParent(AParent: TWinControl);
|
---|
176 | begin
|
---|
177 | inherited SetParent(AParent);
|
---|
178 | if assigned(AParent) then
|
---|
179 | AutoScroll := False;
|
---|
180 | end;
|
---|
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.
|
---|
184 | procedure TfrmBase508Form.UM508(var Message: TMessage);
|
---|
185 | begin
|
---|
186 | case Message.WParam of
|
---|
187 | MSG_508_CODE_TITLE_BAR: AdjustForTitleBarHeightChanges;
|
---|
188 | end;
|
---|
189 | end;
|
---|
190 |
|
---|
191 | procedure TfrmBase508Form.UpdateAccessabilityActions(var Actions: TAccessibilityActions);
|
---|
192 | begin
|
---|
193 | end;
|
---|
194 |
|
---|
195 | type
|
---|
196 | TExposedBtn = class(TButton);
|
---|
197 |
|
---|
198 | procedure TfrmBase508Form.ClickDefaultButton;
|
---|
199 | var
|
---|
200 | tempDefaultBtn: TButton;
|
---|
201 | begin
|
---|
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;
|
---|
209 | end;
|
---|
210 |
|
---|
211 | constructor 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 |
|
---|
230 | begin
|
---|
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;
|
---|
249 | end;
|
---|
250 |
|
---|
251 | const
|
---|
252 | KEY_MASK = $20000000; // ignore Alt keys
|
---|
253 | var
|
---|
254 | KeyMonitorHook: HHOOK;
|
---|
255 | MouseMonitorHook: HHOOK;
|
---|
256 |
|
---|
257 | function KeyMonitorProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
|
---|
258 | begin
|
---|
259 | if (code = HC_ACTION) and ((lParam and KEY_MASK) = 0) then
|
---|
260 | Last508KeyCode := wParam;
|
---|
261 | Result := CallNextHookEx(KeyMonitorHook, Code, wParam, lParam);
|
---|
262 | end;
|
---|
263 |
|
---|
264 | // if mouse click clear last key code
|
---|
265 | function MouseMonitorProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
|
---|
266 | begin
|
---|
267 | if (Code = HC_ACTION) and (wParam > WM_MOUSEFIRST) and (wParam <= WM_MOUSELAST) then
|
---|
268 | Last508KeyCode := 0;
|
---|
269 | Result := CallNextHookEx(MouseMonitorHook, Code, wParam, lParam);
|
---|
270 | end;
|
---|
271 |
|
---|
272 | initialization
|
---|
273 | KeyMonitorHook := SetWindowsHookEx(WH_KEYBOARD, KeyMonitorProc, 0, GetCurrentThreadID);
|
---|
274 | MouseMonitorHook := SetWindowsHookEx(WH_MOUSE, MouseMonitorProc, 0, GetCurrentThreadID);
|
---|
275 |
|
---|
276 | SpecifyFormIsNotADialog(TfrmBase508Form);
|
---|
277 | SpecifyFormIsNotADialog(Tfrm2006Compatibility);
|
---|
278 |
|
---|
279 | finalization
|
---|
280 | UnhookWindowsHookEx(KeyMonitorHook);
|
---|
281 | UnhookWindowsHookEx(MouseMonitorHook);
|
---|
282 |
|
---|
283 | end.
|
---|