source: cprs/branches/foia-cprs/CPRS-Chart/uAccessibleRichEdit.pas@ 1452

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

Adding foia-cprs branch

File size: 8.7 KB
RevLine 
[459]1unit uAccessibleRichEdit;
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 TAccessibleRichEdit = class(TAutoObject, IAccessibleRichEdit, IAccessible)
13 private
14 FDefaultObject: IAccessible;
15 FDefaultObjectLoaded: boolean;
16 FControl: TCaptionRichEdit;
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: TCaptionRichEdit read FControl write FControl;
50 function ChildType( varChild: OleVariant): TChildType;
51 class procedure WrapControl( Control: TCaptionRichEdit);
52 class procedure UnwrapControl( Control: TCaptionRichEdit);
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 TAccessibleRichEdit.accHitTest(xLeft,
65 yTop: Integer): OleVariant;
66begin
67 result := Null;
68 if Assigned(DefaultObject) then
69 result := DefaultObject.accHitTest(xLeft,yTop);
70end;
71
72function TAccessibleRichEdit.accNavigate(navDir: Integer;
73 varStart: OleVariant): OleVariant;
74begin
75 result := Null;
76 if Assigned(DefaultObject) then
77 result := DefaultObject.accNavigate(navDir, varStart);
78end;
79
80function TAccessibleRichEdit.Get_accChild(
81 varChild: OleVariant): IDispatch;
82begin
83 result := nil;
84 if Assigned(DefaultObject) then
85 result := DefaultObject.Get_accChild(varChild);
86end;
87
88function TAccessibleRichEdit.Get_accChildCount: Integer;
89begin
90 result := 0;
91 if Assigned(DefaultObject) then
92 result := DefaultObject.Get_accChildCount;
93end;
94
95function TAccessibleRichEdit.Get_accDefaultAction(
96 varChild: OleVariant): WideString;
97begin
98 result := '';
99 if Assigned(DefaultObject) then
100 result := DefaultObject.Get_accDefaultAction(varChild);
101end;
102
103function TAccessibleRichEdit.Get_accDescription(
104 varChild: OleVariant): WideString;
105begin
106 result := '';
107 if Assigned(DefaultObject) then
108 result := DefaultObject.Get_accDescription(varChild);
109end;
110
111function TAccessibleRichEdit.Get_accFocus: OleVariant;
112begin
113 result := NULL;
114 if Assigned(DefaultObject) then
115 result := DefaultObject.Get_accFocus;
116end;
117
118function TAccessibleRichEdit.Get_accHelp(
119 varChild: OleVariant): WideString;
120begin
121 result := '';
122 if Assigned(DefaultObject) then
123 result := DefaultObject.Get_accHelp(varChild);
124end;
125
126function TAccessibleRichEdit.Get_accHelpTopic(
127 out pszHelpFile: WideString; varChild: OleVariant): Integer;
128begin
129 result := 0;
130 if Assigned(DefaultObject) then
131 result := DefaultObject.Get_accHelpTopic(pszHelpFile, varChild);
132end;
133
134function TAccessibleRichEdit.Get_accKeyboardShortcut(
135 varChild: OleVariant): WideString;
136begin
137 result := '';
138 if Assigned(DefaultObject) then
139 result := DefaultObject.Get_accKeyboardShortcut(varChild);
140end;
141
142function TAccessibleRichEdit.Get_accName(
143 varChild: OleVariant): WideString;
144begin
145 result := '';
146 if ChildType(varChild) = ctNoChild then
147 begin
148 if Assigned(FControl) then
149 result := FControl.Caption;
150 end
151 else if Assigned(DefaultObject) then
152 result := DefaultObject.Get_accName(varChild);
153end;
154
155function TAccessibleRichEdit.Get_accParent: IDispatch;
156begin
157 result := nil;
158 if Assigned(DefaultObject) then
159 result := DefaultObject.Get_accParent;
160end;
161
162function TAccessibleRichEdit.Get_accRole(
163 varChild: OleVariant): OleVariant;
164begin
165 if ChildType(varChild) = ctNoChild then
166 result := ROLE_SYSTEM_TEXT
167 else
168 result := ROLE_SYSTEM_CLIENT;
169end;
170
171function TAccessibleRichEdit.Get_accSelection: OleVariant;
172begin
173 result := NULL;
174 if Assigned(DefaultObject) then
175 result := DefaultObject.Get_accSelection;
176end;
177
178function TAccessibleRichEdit.Get_accState(
179 varChild: OleVariant): OleVariant;
180begin
181 result := NULL;
182 if Assigned(DefaultObject) then
183 result := DefaultObject.Get_accState(varChild);
184end;
185
186function TAccessibleRichEdit.Get_accValue(
187 varChild: OleVariant): WideString;
188begin
189 //This is the crux of the issue: RichEdit controls return what should be the
190 //Value as the Name.
191 result := '';
192 if Assigned(DefaultObject) then
193 result := DefaultObject.Get_accName(varChild);
194end;
195
196procedure TAccessibleRichEdit.accDoDefaultAction(varChild: OleVariant);
197begin
198 if Assigned(DefaultObject) then
199 DefaultObject.accDoDefaultAction(varChild);
200end;
201
202procedure TAccessibleRichEdit.accLocation(out pxLeft, pyTop, pcxWidth,
203 pcyHeight: Integer; varChild: OleVariant);
204begin
205 if Assigned(DefaultObject) then
206 DefaultObject.accLocation(pxLeft,pyTop,pcxWidth,pcyHeight,VarChild);
207end;
208
209procedure TAccessibleRichEdit.accSelect(flagsSelect: Integer;
210 varChild: OleVariant);
211begin
212 if Assigned(DefaultObject) then
213 DefaultObject.accSelect(flagsSelect, varChild);
214end;
215
216procedure TAccessibleRichEdit.Set_accName(varChild: OleVariant;
217 const pszName: WideString);
218begin
219 if Assigned(DefaultObject) then
220 DefaultObject.Set_accName(varChild, pszName);
221end;
222
223procedure TAccessibleRichEdit.Set_accValue(varChild: OleVariant;
224 const pszValue: WideString);
225begin
226 if Assigned(DefaultObject) then
227 DefaultObject.Set_accValue(varChild, pszValue);
228end;
229
230function TAccessibleRichEdit.ChildType(varChild: OleVariant): TChildType;
231begin
232 if VarType(varChild) <> varInteger then
233 result := ctInvalid
234 else if varChild = CHILDID_SELF then
235 result := ctNoChild
236 else
237 result := ctChild;
238end;
239
240function TAccessibleRichEdit.GetDefaultObject: IAccessible;
241begin
242 if Assigned(FControl) and not FDefaultObjectLoaded then begin
243 FDefaultObject := uAccessAPI.GetDefaultObject(FControl);
244 FDefaultObjectLoaded := True;
245 end;
246 Result := FDefaultObject;
247end;
248
249function TAccessibleRichEdit.SafeCallException(ExceptObject: TObject;
250 ExceptAddr: Pointer): HResult;
251begin
252 if (ExceptObject is EOleSysError) then
253 result := EOleSysError(ExceptObject).ErrorCode
254 else
255 result := inherited SafeCallException(ExceptObject, ExceptAddr);
256end;
257
258class procedure TAccessibleRichEdit.UnwrapControl(
259 Control: TCaptionRichEdit);
260begin
261 if not UserIsRestricted then
262 Control.MakeAccessible(nil);
263end;
264
265class procedure TAccessibleRichEdit.WrapControl(
266 Control: TCaptionRichEdit);
267var
268 AccessibleRichEdit: TAccessibleRichEdit;
269 {Using Accessible here is probably just interface reference count paranoia}
270 Accessible: IAccessible;
271begin
272 if not UserIsRestricted then
273 begin
274 AccessibleRichEdit := TAccessibleRichEdit.Create;
275 Accessible := AccessibleRichEdit;
276 AccessibleRichEdit.Control := Control;
277 Control.MakeAccessible(Accessible);
278 end;
279end;
280
281initialization
282 try
283 TAutoObjectFactory.Create(ComServer, TAccessibleRichEdit, Class_AccessibleRichEdit,
284 ciMultiInstance, tmApartment);
285 except
286 {Let the poor restricted users pass!}
287 UserIsRestricted := True;
288 end;
289end.
290
Note: See TracBrowser for help on using the repository browser.