source: cprs/branches/tmg-cprs/CPRS-Chart/uAccessibleStringGrid.pas@ 1620

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

Initial upload of TMG-CPRS 1.0.26.69

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