1 | unit uAccessibleListBox;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | ComObj, ActiveX, CPRSChart_TLB, StdVcl, Accessibility_TLB, ORCtrls, Variants;
|
---|
7 |
|
---|
8 | type
|
---|
9 | TChildType = (ctInvalid, ctNoChild, ctChild);
|
---|
10 |
|
---|
11 | TAccessibleListBox = class(TAutoObject, IAccessibleListBox, IAccessible)
|
---|
12 | private
|
---|
13 | FDefaultObject: IAccessible;
|
---|
14 | FDefaultObjectLoaded: boolean;
|
---|
15 | FControl: TORListBox;
|
---|
16 | function GetDefaultObject: IAccessible;
|
---|
17 | protected
|
---|
18 | function accHitTest(xLeft, yTop: Integer): OleVariant; safecall;
|
---|
19 | function accNavigate(navDir: Integer; varStart: OleVariant): OleVariant;
|
---|
20 | safecall;
|
---|
21 | function Get_accChild(varChild: OleVariant): IDispatch; safecall;
|
---|
22 | function Get_accChildCount: Integer; safecall;
|
---|
23 | function Get_accDefaultAction(varChild: OleVariant): WideString; safecall;
|
---|
24 | function Get_accDescription(varChild: OleVariant): WideString; safecall;
|
---|
25 | function Get_accFocus: OleVariant; safecall;
|
---|
26 | function Get_accHelp(varChild: OleVariant): WideString; safecall;
|
---|
27 | function Get_accHelpTopic(out pszHelpFile: WideString;
|
---|
28 | varChild: OleVariant): Integer; safecall;
|
---|
29 | function Get_accKeyboardShortcut(varChild: OleVariant): WideString;
|
---|
30 | safecall;
|
---|
31 | function Get_accName(varChild: OleVariant): WideString; safecall;
|
---|
32 | function Get_accParent: IDispatch; safecall;
|
---|
33 | function Get_accRole(varChild: OleVariant): OleVariant; safecall;
|
---|
34 | function Get_accSelection: OleVariant; safecall;
|
---|
35 | function Get_accState(varChild: OleVariant): OleVariant; safecall;
|
---|
36 | function Get_accValue(varChild: OleVariant): WideString; safecall;
|
---|
37 | procedure accDoDefaultAction(varChild: OleVariant); safecall;
|
---|
38 | procedure accLocation(out pxLeft, pyTop, pcxWidth, pcyHeight: Integer;
|
---|
39 | varChild: OleVariant); safecall;
|
---|
40 | procedure accSelect(flagsSelect: Integer; varChild: OleVariant); safecall;
|
---|
41 | procedure Set_accName(varChild: OleVariant; const pszName: WideString);
|
---|
42 | safecall;
|
---|
43 | procedure Set_accValue(varChild: OleVariant; const pszValue: WideString);
|
---|
44 | safecall;
|
---|
45 | public
|
---|
46 | property Control: TORListBox read FControl write FControl;
|
---|
47 | property DefaultObject: IAccessible read GetDefaultObject write FDefaultObject;
|
---|
48 | function ChildType( varChild: OleVariant): TChildType;
|
---|
49 | class procedure WrapControl( Control: TORComboBox); overload;
|
---|
50 | class procedure UnwrapControl( Control: TORComboBox); overload;
|
---|
51 | class procedure WrapControl( Control: TORListBox); overload;
|
---|
52 | class procedure UnwrapControl( Control: TORListBox); overload;
|
---|
53 | end;
|
---|
54 |
|
---|
55 | implementation
|
---|
56 |
|
---|
57 | uses uComServ, uAccessAPI, Windows, SysUtils;
|
---|
58 |
|
---|
59 | var
|
---|
60 | UserIsRestricted: boolean = False;
|
---|
61 |
|
---|
62 | function TAccessibleListBox.accHitTest(xLeft, yTop: Integer): OleVariant;
|
---|
63 | begin
|
---|
64 | result := Null;
|
---|
65 | if Assigned(DefaultObject) then
|
---|
66 | result := DefaultObject.accHitTest(xLeft,yTop);
|
---|
67 | end;
|
---|
68 |
|
---|
69 | function TAccessibleListBox.accNavigate(navDir: Integer;
|
---|
70 | varStart: OleVariant): OleVariant;
|
---|
71 | begin
|
---|
72 | result := Null;
|
---|
73 | if Assigned(DefaultObject) then
|
---|
74 | result := DefaultObject.accNavigate(navDir, varStart);
|
---|
75 | end;
|
---|
76 |
|
---|
77 | function TAccessibleListBox.Get_accChild(varChild: OleVariant): IDispatch;
|
---|
78 | begin
|
---|
79 | result := nil;
|
---|
80 | if Assigned(DefaultObject) then
|
---|
81 | result := DefaultObject.Get_accChild(varChild);
|
---|
82 | end;
|
---|
83 |
|
---|
84 | function TAccessibleListBox.Get_accChildCount: Integer;
|
---|
85 | begin
|
---|
86 | result := 0;
|
---|
87 | if Assigned(DefaultObject) then
|
---|
88 | result := DefaultObject.Get_accChildCount;
|
---|
89 | end;
|
---|
90 |
|
---|
91 | function TAccessibleListBox.Get_accDefaultAction(
|
---|
92 | varChild: OleVariant): WideString;
|
---|
93 | begin
|
---|
94 | result := '';
|
---|
95 | if Assigned(DefaultObject) then
|
---|
96 | result := DefaultObject.Get_accDefaultAction(varChild);
|
---|
97 | end;
|
---|
98 |
|
---|
99 | function TAccessibleListBox.Get_accDescription(
|
---|
100 | varChild: OleVariant): WideString;
|
---|
101 | begin
|
---|
102 | result := '';
|
---|
103 | if Assigned(DefaultObject) then
|
---|
104 | result := DefaultObject.Get_accDescription(varChild);
|
---|
105 | end;
|
---|
106 |
|
---|
107 | function TAccessibleListBox.Get_accFocus: OleVariant;
|
---|
108 | begin
|
---|
109 | result := NULL;
|
---|
110 | if Assigned(DefaultObject) then
|
---|
111 | result := DefaultObject.Get_accFocus;
|
---|
112 | end;
|
---|
113 |
|
---|
114 | function TAccessibleListBox.Get_accHelp(varChild: OleVariant): WideString;
|
---|
115 | begin
|
---|
116 | result := '';
|
---|
117 | if Assigned(DefaultObject) then
|
---|
118 | result := DefaultObject.Get_accHelp(varChild);
|
---|
119 | end;
|
---|
120 |
|
---|
121 | function TAccessibleListBox.Get_accHelpTopic(out pszHelpFile: WideString;
|
---|
122 | varChild: OleVariant): Integer;
|
---|
123 | begin
|
---|
124 | result := 0;
|
---|
125 | if Assigned(DefaultObject) then
|
---|
126 | result := DefaultObject.Get_accHelpTopic(pszHelpFile, varChild);
|
---|
127 | end;
|
---|
128 |
|
---|
129 | function TAccessibleListBox.Get_accKeyboardShortcut(
|
---|
130 | varChild: OleVariant): WideString;
|
---|
131 | begin
|
---|
132 | result := '';
|
---|
133 | if Assigned(DefaultObject) then
|
---|
134 | result := DefaultObject.Get_accKeyboardShortcut(varChild);
|
---|
135 | end;
|
---|
136 |
|
---|
137 | function TAccessibleListBox.Get_accName(varChild: OleVariant): WideString;
|
---|
138 | var
|
---|
139 | LongName: string;
|
---|
140 | Previous: string;
|
---|
141 | i: integer;
|
---|
142 | begin
|
---|
143 | if ChildType(varChild) = ctChild then
|
---|
144 | begin
|
---|
145 | result := '';
|
---|
146 | if Assigned(FControl) then
|
---|
147 | begin
|
---|
148 | i := varChild - 1;
|
---|
149 | LongName := FControl.DisplayText[i];
|
---|
150 | if i > 0 then
|
---|
151 | Previous := FControl.DisplayText[i-1]
|
---|
152 | else
|
---|
153 | Previous := '';
|
---|
154 | result := CalcShortName( LongName, Previous);
|
---|
155 | end;
|
---|
156 | end
|
---|
157 | else if Assigned(DefaultObject) then
|
---|
158 | result := DefaultObject.Get_accName(varChild);
|
---|
159 | end;
|
---|
160 |
|
---|
161 | function TAccessibleListBox.Get_accParent: IDispatch;
|
---|
162 | begin
|
---|
163 | result := nil;
|
---|
164 | if Assigned(DefaultObject) then
|
---|
165 | result := DefaultObject.Get_accParent;
|
---|
166 | end;
|
---|
167 |
|
---|
168 | function TAccessibleListBox.Get_accRole(varChild: OleVariant): OleVariant;
|
---|
169 | begin
|
---|
170 | result := NULL;
|
---|
171 | if Assigned(DefaultObject) then
|
---|
172 | result := DefaultObject.Get_accRole(varChild);
|
---|
173 | end;
|
---|
174 |
|
---|
175 | function TAccessibleListBox.Get_accSelection: OleVariant;
|
---|
176 | begin
|
---|
177 | result := NULL;
|
---|
178 | if Assigned(DefaultObject) then
|
---|
179 | result := DefaultObject.Get_accSelection;
|
---|
180 | end;
|
---|
181 |
|
---|
182 | function TAccessibleListBox.Get_accState(varChild: OleVariant): OleVariant;
|
---|
183 | begin
|
---|
184 | result := NULL;
|
---|
185 | if Assigned(DefaultObject) then
|
---|
186 | result := DefaultObject.Get_accState(varChild);
|
---|
187 | end;
|
---|
188 |
|
---|
189 | function TAccessibleListBox.Get_accValue(varChild: OleVariant): WideString;
|
---|
190 | begin
|
---|
191 | result := '';
|
---|
192 | if Assigned(DefaultObject) then
|
---|
193 | result := DefaultObject.Get_accValue(varChild);
|
---|
194 | end;
|
---|
195 |
|
---|
196 | procedure TAccessibleListBox.accDoDefaultAction(varChild: OleVariant);
|
---|
197 | begin
|
---|
198 | if Assigned(DefaultObject) then
|
---|
199 | DefaultObject.accDoDefaultAction(varChild);
|
---|
200 | end;
|
---|
201 |
|
---|
202 | procedure TAccessibleListBox.accLocation(out pxLeft, pyTop, pcxWidth,
|
---|
203 | pcyHeight: Integer; varChild: OleVariant);
|
---|
204 | begin
|
---|
205 | if Assigned(DefaultObject) then
|
---|
206 | DefaultObject.accLocation(pxLeft,pyTop,pcxWidth,pcyHeight,VarChild);
|
---|
207 | end;
|
---|
208 |
|
---|
209 | procedure TAccessibleListBox.accSelect(flagsSelect: Integer;
|
---|
210 | varChild: OleVariant);
|
---|
211 | begin
|
---|
212 | if Assigned(DefaultObject) then
|
---|
213 | DefaultObject.accSelect(flagsSelect, varChild);
|
---|
214 | end;
|
---|
215 |
|
---|
216 | procedure TAccessibleListBox.Set_accName(varChild: OleVariant;
|
---|
217 | const pszName: WideString);
|
---|
218 | begin
|
---|
219 | if Assigned(DefaultObject) then
|
---|
220 | DefaultObject.Set_accName(varChild, pszName);
|
---|
221 | end;
|
---|
222 |
|
---|
223 | procedure TAccessibleListBox.Set_accValue(varChild: OleVariant;
|
---|
224 | const pszValue: WideString);
|
---|
225 | begin
|
---|
226 | if Assigned(DefaultObject) then
|
---|
227 | DefaultObject.Set_accValue(varChild, pszValue);
|
---|
228 | end;
|
---|
229 |
|
---|
230 | function TAccessibleListBox.GetDefaultObject: IAccessible;
|
---|
231 | begin
|
---|
232 | if Assigned(FControl) and not FDefaultObjectLoaded then begin
|
---|
233 | FDefaultObject := uAccessAPI.GetDefaultObject(FControl);
|
---|
234 | FDefaultObjectLoaded := True;
|
---|
235 | end;
|
---|
236 | Result := FDefaultObject;
|
---|
237 | end;
|
---|
238 |
|
---|
239 | function TAccessibleListBox.ChildType(varChild: OleVariant): TChildType;
|
---|
240 | begin
|
---|
241 | if VarType(varChild) <> varInteger then
|
---|
242 | result := ctInvalid
|
---|
243 | else if varChild = CHILDID_SELF then
|
---|
244 | result := ctNoChild
|
---|
245 | else
|
---|
246 | result := ctChild;
|
---|
247 | end;
|
---|
248 |
|
---|
249 | class procedure TAccessibleListBox.WrapControl(Control: TORComboBox);
|
---|
250 | var
|
---|
251 | AccessibleListBox: TAccessibleListBox;
|
---|
252 | {Using Accessible here is probably just interface reference count paranoia}
|
---|
253 | Accessible: IAccessible;
|
---|
254 | begin
|
---|
255 | if not UserIsRestricted then
|
---|
256 | begin
|
---|
257 | AccessibleListBox := TAccessibleListBox.Create;
|
---|
258 | Accessible := AccessibleListBox;
|
---|
259 | AccessibleListBox.Control := Control.MakeAccessible(Accessible);
|
---|
260 | end;
|
---|
261 | end;
|
---|
262 |
|
---|
263 | class procedure TAccessibleListBox.UnwrapControl(Control: TORComboBox);
|
---|
264 | begin
|
---|
265 | if not UserIsRestricted then
|
---|
266 | Control.MakeAccessible(nil);
|
---|
267 | end;
|
---|
268 |
|
---|
269 | class procedure TAccessibleListBox.UnwrapControl(Control: TORListBox);
|
---|
270 | begin
|
---|
271 | if not UserIsRestricted then
|
---|
272 | Control.MakeAccessible(nil);
|
---|
273 | end;
|
---|
274 |
|
---|
275 | class procedure TAccessibleListBox.WrapControl(Control: TORListBox);
|
---|
276 | var
|
---|
277 | AccessibleListBox: TAccessibleListBox;
|
---|
278 | {Using Accessible here is probably just interface reference count paranoia}
|
---|
279 | Accessible: IAccessible;
|
---|
280 | begin
|
---|
281 | if not UserIsRestricted then
|
---|
282 | begin
|
---|
283 | AccessibleListBox := TAccessibleListBox.Create;
|
---|
284 | Accessible := AccessibleListBox;
|
---|
285 | AccessibleListBox.Control := Control;
|
---|
286 | Control.MakeAccessible(Accessible);
|
---|
287 | end;
|
---|
288 | end;
|
---|
289 |
|
---|
290 | initialization
|
---|
291 | try
|
---|
292 | TAutoObjectFactory.Create(ComServer, TAccessibleListBox, Class_AccessibleListBox,
|
---|
293 | ciMultiInstance, tmApartment);
|
---|
294 | except
|
---|
295 | {Let the poor restricted users pass!}
|
---|
296 | UserIsRestricted := True;
|
---|
297 | end;
|
---|
298 | end.
|
---|