source: cprs/trunk/CPRS-Chart/uAccessibleStringGrid.pas@ 600

Last change on this file since 600 was 456, checked in by Kevin Toppenberg, 16 years ago

Initial Upload of Official WV CPRS 1.0.26.76

File size: 12.8 KB
Line 
1unit uAccessibleStringGrid;
2
3interface
4
5uses
6 ComObj, ActiveX, AxCtrls, Classes, CPRSChart_TLB, StdVcl, Accessibility_TLB,
7 ORCtrls, Variants;
8
9type
10 TChildType = (ctInvalid, ctNoChild, ctChild);
11
12 TAccessibleStringGrid = class(TAutoObject, IAccessibleStringGrid, IAccessible)
13 private
14 FDefaultObject: IAccessible;
15 FDefaultObjectLoaded: boolean;
16 FControl: TCaptionStringGrid;
17 function GetDefaultObject: IAccessible;
18 protected {IAccessible}
19 function accHitTest(xLeft, yTop: Integer): OleVariant; safecall;
20 function accNavigate(navDir: Integer; varStart: OleVariant): OleVariant;
21 safecall;
22 function Get_accChild(varChild: OleVariant): IDispatch; safecall;
23 function Get_accChildCount: Integer; safecall;
24 function Get_accDefaultAction(varChild: OleVariant): WideString; safecall;
25 function Get_accDescription(varChild: OleVariant): WideString; safecall;
26 function Get_accFocus: OleVariant; safecall;
27 function Get_accHelp(varChild: OleVariant): WideString; safecall;
28 function Get_accHelpTopic(out pszHelpFile: WideString;
29 varChild: OleVariant): Integer; safecall;
30 function Get_accKeyboardShortcut(varChild: OleVariant): WideString;
31 safecall;
32 function Get_accName(varChild: OleVariant): WideString; safecall;
33 function Get_accParent: IDispatch; safecall;
34 function Get_accRole(varChild: OleVariant): OleVariant; safecall;
35 function Get_accSelection: OleVariant; safecall;
36 function Get_accState(varChild: OleVariant): OleVariant; safecall;
37 function Get_accValue(varChild: OleVariant): WideString; safecall;
38 procedure accDoDefaultAction(varChild: OleVariant); safecall;
39 procedure accLocation(out pxLeft, pyTop, pcxWidth, pcyHeight: Integer;
40 varChild: OleVariant); safecall;
41 procedure accSelect(flagsSelect: Integer; varChild: OleVariant); safecall;
42 procedure Set_accName(varChild: OleVariant; const pszName: WideString);
43 safecall;
44 procedure Set_accValue(varChild: OleVariant; const pszValue: WideString);
45 safecall;
46 protected
47 property DefaultObject: IAccessible read GetDefaultObject write FDefaultObject;
48 public
49 property Control: TCaptionStringGrid read FControl write FControl;
50 function ChildType( varChild: OleVariant): TChildType;
51 class procedure WrapControl( Control: TCaptionStringGrid);
52 class procedure UnwrapControl( Control: TCaptionStringGrid);
53 public {but it wouldn't be in a perfect world}
54 function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
55 end;
56
57implementation
58
59uses uComServ, SysUtils, uAccessAPI, Windows, Controls;
60
61var
62 UserIsRestricted: boolean = False;
63
64function TAccessibleStringGrid.accHitTest(xLeft,
65 yTop: Integer): OleVariant;
66var
67 ACol: integer;
68 ARow: integer;
69 P: TPoint;
70begin
71 result := Null;
72 if Assigned(FControl) then
73 begin
74 P.X := xLeft;
75 P.Y := yTop;
76 P := FControl.ScreenToClient(P);
77 FControl.MouseToCell(P.X, P.Y, ACol, ARow);
78 if (ACol = -1) or (ARow = -1) then
79 result := NULL
80 else
81 result := FControl.ColRowToIndex( ACol, ARow);
82 end
83 else
84 result := CHILDID_SELF;
85end;
86
87function TAccessibleStringGrid.accNavigate(navDir: Integer;
88 varStart: OleVariant): OleVariant;
89begin
90 result := Null;
91 if Assigned(FControl) then
92 begin
93 case ChildType(varStart) of
94 ctNoChild:
95 case navDir of
96 NAVDIR_FIRSTCHILD:
97 result := 1;
98 NAVDIR_LASTCHILD:
99 result := Get_AccChildCount;
100 NAVDIR_DOWN,
101 NAVDIR_LEFT,
102 NAVDIR_NEXT,
103 NAVDIR_PREVIOUS,
104 NAVDIR_RIGHT,
105 NAVDIR_UP:
106 result := varStart;
107 end;
108 ctChild:
109 case NavDir of
110 NAVDIR_FIRSTCHILD,
111 NAVDIR_LASTCHILD:
112 result := varStart;
113 NAVDIR_DOWN:
114 result := varStart + (FControl.ColCount - FControl.FixedCols);
115 NAVDIR_LEFT,
116 NAVDIR_NEXT:
117 result := varStart + 1;
118 NAVDIR_PREVIOUS,
119 NAVDIR_RIGHT:
120 result := varStart - 1;
121 NAVDIR_UP:
122 result := varStart - (FControl.ColCount - FControl.FixedCols);
123 end;
124 end;
125 //revert if index is invalid
126 if ChildType(result) = ctChild then
127 begin
128 if (result > Get_AccChildCount) or (result < 1) then
129 result := varStart;
130 end;
131 end;
132end;
133
134function TAccessibleStringGrid.Get_accChild(
135 varChild: OleVariant): IDispatch;
136begin
137 result := nil;
138 OleError(S_FALSE);
139end;
140
141function TAccessibleStringGrid.Get_accChildCount: Integer;
142begin
143 if Assigned(FControl) then
144 result := (FControl.RowCount - FControl.FixedRows) * (FControl.ColCount - FControl.FixedCols)
145 else
146 result := 0;
147end;
148
149function TAccessibleStringGrid.Get_accDefaultAction(
150 varChild: OleVariant): WideString;
151begin
152 result := '';
153 if Assigned(DefaultObject) then
154 result := DefaultObject.Get_accDefaultAction(varChild);
155end;
156
157function TAccessibleStringGrid.Get_accDescription(
158 varChild: OleVariant): WideString;
159begin
160 result := '';
161 if Assigned(DefaultObject) then
162 result := DefaultObject.Get_accDescription(varChild);
163end;
164
165function TAccessibleStringGrid.Get_accFocus: OleVariant;
166begin
167 if Assigned(FControl) and FControl.Focused then
168 result := FControl.ColRowToIndex(FControl.Col, FControl.Row)
169 else
170 result := NULL;
171end;
172
173function TAccessibleStringGrid.Get_accHelp(
174 varChild: OleVariant): WideString;
175begin
176 result := '';
177 if Assigned(DefaultObject) then
178 result := DefaultObject.Get_accHelp(varChild);
179end;
180
181function TAccessibleStringGrid.Get_accHelpTopic(
182 out pszHelpFile: WideString; varChild: OleVariant): Integer;
183begin
184 result := 0;
185 if Assigned(DefaultObject) then
186 result := DefaultObject.Get_accHelpTopic(pszHelpFile, varChild);
187end;
188
189function TAccessibleStringGrid.Get_accKeyboardShortcut(
190 varChild: OleVariant): WideString;
191begin
192 result := '';
193 if Assigned(DefaultObject) then
194 result := DefaultObject.Get_accKeyboardShortcut(varChild);
195end;
196
197function TAccessibleStringGrid.Get_accName(
198 varChild: OleVariant): WideString;
199var
200 Row,Col: integer;
201 ColumnName: string;
202 RowName: string;
203begin
204 case ChildType(varChild) of
205 ctNoChild:
206 result := FControl.Caption;
207 ctChild:
208 begin
209 if Assigned(FControl) then
210 begin
211 FControl.IndexToColRow(varChild,Col,Row);
212 if (FControl.FixedRows = 1) and (FControl.Cells[Col,0] <> '') then
213 ColumnName := FControl.Cells[Col,0]
214 else
215 ColumnName := IntToStr(Col-FControl.FixedCols+1);
216 if (FControl.FixedCols = 1) and ((FControl.Cells[0,Row] <> '')) then
217 RowName := FControl.Cells[0,Row]
218 else
219 RowName := IntToStr(Row-FControl.FixedRows+1) + ' of ' +
220 IntToStr(FControl.RowCount - FControl.FixedRows);
221 result := 'Column ' + ColumnName + ', Row ' + RowName;
222 end
223 else
224 result := 'Unknown Property';
225 end;
226 else
227 result := 'Unknown Property';
228 end;
229end;
230
231function TAccessibleStringGrid.Get_accParent: IDispatch;
232begin
233 result := nil;
234 if Assigned(DefaultObject) then
235 result := DefaultObject.Get_accParent;
236end;
237
238function TAccessibleStringGrid.Get_accRole(
239 varChild: OleVariant): OleVariant;
240begin
241 case ChildType(varChild) of
242 ctNoChild:
243 result := ROLE_SYSTEM_LIST;
244 ctChild:
245 result := ROLE_SYSTEM_LISTITEM;
246 else
247 result := ROLE_SYSTEM_CLIENT;
248 end;
249end;
250
251function TAccessibleStringGrid.Get_accSelection: OleVariant;
252begin
253 //We are assuming single-selection for this control
254 if Assigned(FControl) then
255 result := FControl.ColRowToIndex(FControl.Col, FControl.Row)
256 else
257 result := NULL;
258end;
259
260function TAccessibleStringGrid.Get_accState(
261 varChild: OleVariant): OleVariant;
262begin
263 if Assigned(FControl) then
264 begin
265 result := STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_READONLY or STATE_SYSTEM_SELECTABLE;
266 case ChildType(varChild) of
267 ctNoChild:
268 if FControl.Focused then
269 result := result or STATE_SYSTEM_FOCUSED;
270 ctChild:
271 begin
272 if FControl.ColRowToIndex(FControl.Col, FControl.Row) = varChild then
273 begin
274 result := result or STATE_SYSTEM_SELECTED;
275 if FControl.Focused then
276 result := result or STATE_SYSTEM_FOCUSED;
277 end;
278 end;
279 end;
280 if ([csCreating,csDestroyingHandle] * FControl.ControlState <> []) or
281 ([csDestroying,csFreeNotification,csLoading,csWriting] * FControl.ComponentState <> []) then
282 result := result or STATE_SYSTEM_UNAVAILABLE;
283 end
284 else
285 result := STATE_SYSTEM_UNAVAILABLE;
286end;
287
288function TAccessibleStringGrid.Get_accValue(
289 varChild: OleVariant): WideString;
290var
291 Row,Col: integer;
292begin
293 case ChildType(varChild) of
294 ctNoChild:
295 result := '';
296 ctChild:
297 begin
298 if Assigned(FControl) then
299 begin
300 FControl.IndexToColRow(varChild,Col,Row);
301 result := FControl.Cells[Col,Row];
302 if FControl.JustToTab then
303 result := Copy(result, 1, pos(#9{Tab},Result) -1);
304 end
305 else
306 result := 'Unknown Property';
307 end;
308 else
309 result := 'Unknown Property';
310 end;
311end;
312
313procedure TAccessibleStringGrid.accDoDefaultAction(varChild: OleVariant);
314begin
315 if Assigned(DefaultObject) then
316 DefaultObject.accDoDefaultAction(varChild);
317end;
318
319procedure TAccessibleStringGrid.accLocation(out pxLeft, pyTop, pcxWidth,
320 pcyHeight: Integer; varChild: OleVariant);
321var
322 P: TPoint;
323 R: TRect;
324begin
325 if Assigned(FControl) then
326 begin
327 case ChildType(varChild) of
328 ctNoChild:
329 begin
330 P.X := 0;
331 P.Y := 0;
332 with FControl.ClientToScreen(P) do begin
333 pxLeft := X;
334 pyTop := Y;
335 end;
336 pcxWidth := FControl.Width;
337 pcyHeight := FControl.Height;
338 end;
339 ctChild:
340 begin
341 R := FControl.CellRect(FControl.Col,FControl.Row);
342 with FControl.ClientToScreen(R.TopLeft) do begin
343 pxLeft := X;
344 pyTop := Y;
345 end;
346 pcxWidth := R.Right - R.Left;
347 pcyHeight := R.Bottom - R.Top;
348 end;
349 else
350 begin
351 pxLeft := 0;
352 pyTop := 0;
353 pcxWidth := 0;
354 pcyHeight := 0;
355 end;
356 end;
357 end;
358end;
359
360procedure TAccessibleStringGrid.accSelect(flagsSelect: Integer;
361 varChild: OleVariant);
362begin
363 if Assigned(DefaultObject) then
364 DefaultObject.accSelect(flagsSelect, varChild);
365end;
366
367procedure TAccessibleStringGrid.Set_accName(varChild: OleVariant;
368 const pszName: WideString);
369begin
370 if Assigned(DefaultObject) then
371 DefaultObject.Set_accName(varChild, pszName);
372end;
373
374procedure TAccessibleStringGrid.Set_accValue(varChild: OleVariant;
375 const pszValue: WideString);
376var
377 Row,Col: integer;
378begin
379 case ChildType(varChild) of
380 ctChild:
381 begin
382 if Assigned(FControl) then
383 begin
384 FControl.IndexToColRow(varChild,Col,Row);
385 FControl.Cells[Col,Row] := pszValue;
386 end;
387 end;
388 end;
389end;
390
391function TAccessibleStringGrid.ChildType(varChild: OleVariant): TChildType;
392begin
393 if VarType(varChild) <> varInteger then
394 result := ctInvalid
395 else if varChild = CHILDID_SELF then
396 result := ctNoChild
397 else
398 result := ctChild;
399end;
400
401function TAccessibleStringGrid.GetDefaultObject: IAccessible;
402begin
403 if Assigned(FControl) and not FDefaultObjectLoaded then begin
404 FDefaultObject := uAccessAPI.GetDefaultObject(FControl);
405 FDefaultObjectLoaded := True;
406 end;
407 Result := FDefaultObject;
408end;
409
410function TAccessibleStringGrid.SafeCallException(ExceptObject: TObject;
411 ExceptAddr: Pointer): HResult;
412begin
413 if (ExceptObject is EOleSysError) then
414 result := EOleSysError(ExceptObject).ErrorCode
415 else
416 result := inherited SafeCallException(ExceptObject, ExceptAddr);
417end;
418
419class procedure TAccessibleStringGrid.UnwrapControl(
420 Control: TCaptionStringGrid);
421begin
422 if not UserIsRestricted then
423 Control.MakeAccessible(nil);
424end;
425
426class procedure TAccessibleStringGrid.WrapControl(
427 Control: TCaptionStringGrid);
428var
429 AccessibleStringGrid: TAccessibleStringGrid;
430 {Using Accessible here is probably just interface reference count paranoia}
431 Accessible: IAccessible;
432begin
433 if not UserIsRestricted then
434 begin
435 AccessibleStringGrid := TAccessibleStringGrid.Create;
436 Accessible := AccessibleStringGrid;
437 AccessibleStringGrid.Control := Control;
438 Control.MakeAccessible(Accessible);
439 end;
440end;
441
442initialization
443 try
444 TAutoObjectFactory.Create(ComServer, TAccessibleStringGrid, Class_AccessibleStringGrid,
445 ciMultiInstance, tmApartment);
446 except
447 {Let the poor restricted users pass!}
448 UserIsRestricted := True;
449 end;
450end.
Note: See TracBrowser for help on using the repository browser.