source: cprs/branches/tmg-cprs/CPRS-Chart/uAccessibleRichEdit.pas@ 1593

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

Initial upload of TMG-CPRS 1.0.26.69

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