source: cprs/branches/tmg-cprs/CPRS-Chart/uAccessibleListBox.pas@ 795

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

Initial upload of TMG-CPRS 1.0.26.69

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