1 | unit VA508MSAASupport;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | Windows, Messages, SysUtils, Classes, Controls, ComObj, ActiveX, oleacc2, MSAAConstants,
|
---|
7 | ImgList, VAClasses, Graphics, ComCtrls, CommCtrl, Contnrs, VA508AccessibilityConst;
|
---|
8 |
|
---|
9 | type
|
---|
10 | TVA508ImageListType = (iltImages, iltLargeImages, iltOverlayImages, iltSmallImages, iltStateImages);
|
---|
11 | TVA508ImageListTypes = set of TVA508ImageListType;
|
---|
12 |
|
---|
13 | TVA508OnImageIndexQueryEvent = procedure(Sender: TObject; ImageIndex: integer;
|
---|
14 | ImageType: TVA508ImageListType; var ImageText: string) of object;
|
---|
15 |
|
---|
16 | const
|
---|
17 | VA508ImageListLabelerClasses: array[0..1] of TClass = (TCustomTreeView, TCustomListView);
|
---|
18 |
|
---|
19 | procedure RegisterComponentImageListQueryEvent(Component: TWinControl;
|
---|
20 | ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
21 |
|
---|
22 | procedure UnregisterComponentImageListQueryEvent(Component: TWinControl;
|
---|
23 | Event: TVA508OnImageIndexQueryEvent);
|
---|
24 |
|
---|
25 | procedure RegisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
|
---|
26 | procedure UnregisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
|
---|
27 | procedure RegisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
|
---|
28 | procedure UnregisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
|
---|
29 |
|
---|
30 | implementation
|
---|
31 |
|
---|
32 | var
|
---|
33 | uShutDown: boolean = FALSE;
|
---|
34 | Events: TInterfaceList = nil;
|
---|
35 | AccPropServices: IAccPropServices = nil;
|
---|
36 | NamePropIDs: array[0..0] of TGUID;
|
---|
37 | uNotifier: TVANotificationEventComponent;
|
---|
38 |
|
---|
39 | type
|
---|
40 | TServerType = (stImageList, stList, stNormal);
|
---|
41 | TServerTypes = set of TServerType;
|
---|
42 |
|
---|
43 | TImageEventData = class
|
---|
44 | ImageListTypes: TVA508ImageListTypes;
|
---|
45 | Event: TVA508OnImageIndexQueryEvent;
|
---|
46 | end;
|
---|
47 |
|
---|
48 | TListProcData = class
|
---|
49 | Proc: TVA508ListQueryProc;
|
---|
50 | end;
|
---|
51 |
|
---|
52 | TProcData = class
|
---|
53 | Proc: TVA508QueryProc;
|
---|
54 | end;
|
---|
55 |
|
---|
56 | IMSAAServer = interface
|
---|
57 | function GetComponent: TWinControl;
|
---|
58 | procedure AddImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
59 | procedure RemoveImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
60 | procedure AddListProc(Proc: TVA508ListQueryProc);
|
---|
61 | procedure RemoveListProc(Proc: TVA508ListQueryProc);
|
---|
62 | procedure AddProc(Proc: TVA508QueryProc);
|
---|
63 | procedure RemoveProc(Proc: TVA508QueryProc);
|
---|
64 | procedure AssignServerType(AServerType: TServerType);
|
---|
65 | function EventCount: integer;
|
---|
66 | end;
|
---|
67 |
|
---|
68 | TMSAAServer = class(TInterfacedObject, IAccPropServer, IMSAAServer)
|
---|
69 | private
|
---|
70 | FServerTypes: TServerTypes;
|
---|
71 | FAttached: boolean;
|
---|
72 | FEventData: TObjectList;
|
---|
73 | FComponent: TWinControl;
|
---|
74 | FOldWndProc: TWndMethod;
|
---|
75 | function ImageEventIndex(Event: TVA508OnImageIndexQueryEvent): integer;
|
---|
76 | function ListProcIndex(Proc: TVA508ListQueryProc): integer;
|
---|
77 | function ProcIndex(Proc: TVA508QueryProc): integer;
|
---|
78 | procedure Attach;
|
---|
79 | procedure Detatch;
|
---|
80 | procedure Hook;
|
---|
81 | procedure UnHook;
|
---|
82 | procedure AssignServerType(AServerType: TServerType);
|
---|
83 | procedure UnassignServerType(AServerType: TServerType);
|
---|
84 | protected
|
---|
85 | procedure MSAAWindowProc(var Message: TMessage);
|
---|
86 | public
|
---|
87 | constructor Create(AComponent: TWinControl);
|
---|
88 | destructor Destroy; override;
|
---|
89 | class procedure ValidateServerType(AComponent: TWinControl; AServerType: TServerType);
|
---|
90 | function GetPropValue(const pIDString: PByte; dwIDStringLen: LongWord; idProp: MSAAPROPID;
|
---|
91 | out pvarValue: OleVariant; out pfHasProp: Integer): HResult; stdcall;
|
---|
92 | function GetComponent: TWinControl;
|
---|
93 | procedure AddImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
94 | procedure RemoveImageEvent(ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
95 | procedure AddListProc(Proc: TVA508ListQueryProc);
|
---|
96 | procedure RemoveListProc(Proc: TVA508ListQueryProc);
|
---|
97 | procedure AddProc(Proc: TVA508QueryProc);
|
---|
98 | procedure RemoveProc(Proc: TVA508QueryProc);
|
---|
99 | function EventCount: integer;
|
---|
100 | end;
|
---|
101 |
|
---|
102 | TExposedTreeView = class(TCustomTreeView);
|
---|
103 | TExposedListView = class(TCustomListView);
|
---|
104 |
|
---|
105 | function FindServer(Component: TWinControl; var index: integer): IMSAAServer; forward;
|
---|
106 |
|
---|
107 | procedure NotifyEvent(Self: TObject; AComponent: TComponent; Operation: TOperation);
|
---|
108 | var
|
---|
109 | server: IMSAAServer;
|
---|
110 | index: integer;
|
---|
111 | begin
|
---|
112 | if assigned(Events) and (Operation = opRemove) and (AComponent is TWinControl) then
|
---|
113 | begin
|
---|
114 | server := FindServer(TWinControl(AComponent), index);
|
---|
115 | try
|
---|
116 | if assigned(server) then
|
---|
117 | Events.Delete(index);
|
---|
118 | finally
|
---|
119 | server := nil;
|
---|
120 | end;
|
---|
121 | end;
|
---|
122 | end;
|
---|
123 |
|
---|
124 | var
|
---|
125 | AccServicesCount: integer = 0;
|
---|
126 |
|
---|
127 | procedure IncAccServices;
|
---|
128 | var
|
---|
129 | m: TVANotifyEvent;
|
---|
130 | begin
|
---|
131 | if AccServicesCount = 0 then
|
---|
132 | begin
|
---|
133 | AccPropServices := CoCAccPropServices.Create;
|
---|
134 | NamePropIDs[0] := PROPID_ACC_NAME;
|
---|
135 | TMethod(m).Code := @NotifyEvent;
|
---|
136 | TMethod(m).Data := nil;
|
---|
137 | uNotifier := TVANotificationEventComponent.NotifyCreate(nil, m);
|
---|
138 | end;
|
---|
139 | inc(AccServicesCount);
|
---|
140 | end;
|
---|
141 |
|
---|
142 | procedure DecAccServices;
|
---|
143 | begin
|
---|
144 | dec(AccServicesCount);
|
---|
145 | if AccServicesCount = 0 then
|
---|
146 | begin
|
---|
147 | FreeAndNil(uNotifier);
|
---|
148 | AccPropServices := nil;
|
---|
149 | end;
|
---|
150 | end;
|
---|
151 |
|
---|
152 | procedure Cleanup;
|
---|
153 | begin
|
---|
154 | uShutDown := TRUE;
|
---|
155 | if assigned(Events) then
|
---|
156 | begin
|
---|
157 | Events := nil;
|
---|
158 | DecAccServices;
|
---|
159 | end;
|
---|
160 | end;
|
---|
161 |
|
---|
162 | function FindServer(Component: TWinControl; var index: integer): IMSAAServer;
|
---|
163 | var
|
---|
164 | i: integer;
|
---|
165 |
|
---|
166 | begin
|
---|
167 | if not assigned(Events) then
|
---|
168 | begin
|
---|
169 | Events := TInterfaceList.Create;
|
---|
170 | IncAccServices;
|
---|
171 | end;
|
---|
172 | for I := 0 to Events.Count - 1 do
|
---|
173 | begin
|
---|
174 | Result := IMSAAServer(Events[i]);
|
---|
175 | index := i;
|
---|
176 | if Result.GetComponent = Component then exit;
|
---|
177 | end;
|
---|
178 | Result := nil;
|
---|
179 | index := -1;
|
---|
180 | end;
|
---|
181 |
|
---|
182 | procedure RegisterComponentImageListQueryEvent(Component: TWinControl;
|
---|
183 | ImageListTypes: TVA508ImageListTypes; Event: TVA508OnImageIndexQueryEvent);
|
---|
184 | var
|
---|
185 | server: IMSAAServer;
|
---|
186 | index: integer;
|
---|
187 | begin
|
---|
188 | if uShutDown then exit;
|
---|
189 | if not assigned(Component) then exit;
|
---|
190 | TMSAAServer.ValidateServerType(Component,stImageList);
|
---|
191 | server := FindServer(Component, index);
|
---|
192 | try
|
---|
193 | if not assigned(server) then
|
---|
194 | begin
|
---|
195 | server := TMSAAServer.Create(Component);
|
---|
196 | Events.Add(server);
|
---|
197 | uNotifier.FreeNotification(Component);
|
---|
198 | end;
|
---|
199 | server.AddImageEvent(ImageListTypes, Event);
|
---|
200 | finally
|
---|
201 | server := nil;
|
---|
202 | end;
|
---|
203 | end;
|
---|
204 |
|
---|
205 | procedure UnregisterComponentImageListQueryEvent(Component: TWinControl;
|
---|
206 | Event: TVA508OnImageIndexQueryEvent);
|
---|
207 | var
|
---|
208 | server: IMSAAServer;
|
---|
209 | index: integer;
|
---|
210 | begin
|
---|
211 | if uShutDown then exit;
|
---|
212 | if not assigned(Component) then exit;
|
---|
213 | server := FindServer(Component, index);
|
---|
214 | try
|
---|
215 | if assigned(server) then
|
---|
216 | begin
|
---|
217 | uNotifier.RemoveFreeNotification(Component);
|
---|
218 | server.RemoveImageEvent([], Event);
|
---|
219 | if server.EventCount = 0 then
|
---|
220 | Events.Delete(index);
|
---|
221 | end;
|
---|
222 | finally
|
---|
223 | server := nil;
|
---|
224 | end;
|
---|
225 | end;
|
---|
226 |
|
---|
227 | procedure RegisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
|
---|
228 | var
|
---|
229 | server: IMSAAServer;
|
---|
230 | index: integer;
|
---|
231 | begin
|
---|
232 | if uShutDown then exit;
|
---|
233 | if not assigned(Component) then exit;
|
---|
234 | TMSAAServer.ValidateServerType(Component, stNormal);
|
---|
235 | server := FindServer(Component, index);
|
---|
236 | try
|
---|
237 | if not assigned(server) then
|
---|
238 | begin
|
---|
239 | server := TMSAAServer.Create(Component);
|
---|
240 | Events.Add(server);
|
---|
241 | uNotifier.FreeNotification(Component);
|
---|
242 | end;
|
---|
243 | server.AddProc(Proc);
|
---|
244 | finally
|
---|
245 | server := nil;
|
---|
246 | end;
|
---|
247 | end;
|
---|
248 |
|
---|
249 | procedure UnregisterMSAAComponentQueryProc(Component: TWinControl; Proc: TVA508QueryProc);
|
---|
250 | var
|
---|
251 | server: IMSAAServer;
|
---|
252 | index: integer;
|
---|
253 | begin
|
---|
254 | if uShutDown then exit;
|
---|
255 | if not assigned(Component) then exit;
|
---|
256 | server := FindServer(Component, index);
|
---|
257 | try
|
---|
258 | if assigned(server) then
|
---|
259 | begin
|
---|
260 | uNotifier.RemoveFreeNotification(Component);
|
---|
261 | server.RemoveProc(Proc);
|
---|
262 | if server.EventCount = 0 then
|
---|
263 | Events.Delete(index);
|
---|
264 | end;
|
---|
265 | finally
|
---|
266 | server := nil;
|
---|
267 | end;
|
---|
268 | end;
|
---|
269 |
|
---|
270 | procedure RegisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
|
---|
271 | var
|
---|
272 | server: IMSAAServer;
|
---|
273 | index: integer;
|
---|
274 | begin
|
---|
275 | if uShutDown then exit;
|
---|
276 | if not assigned(Component) then exit;
|
---|
277 | TMSAAServer.ValidateServerType(Component, stList);
|
---|
278 | server := FindServer(Component, index);
|
---|
279 | try
|
---|
280 | if not assigned(server) then
|
---|
281 | begin
|
---|
282 | server := TMSAAServer.Create(Component);
|
---|
283 | Events.Add(server);
|
---|
284 | uNotifier.FreeNotification(Component);
|
---|
285 | end;
|
---|
286 | server.AddListProc(Proc);
|
---|
287 | finally
|
---|
288 | server := nil;
|
---|
289 | end;
|
---|
290 | end;
|
---|
291 |
|
---|
292 | procedure UnregisterMSAAComponentListQueryProc(Component: TWinControl; Proc: TVA508ListQueryProc);
|
---|
293 | var
|
---|
294 | server: IMSAAServer;
|
---|
295 | index: integer;
|
---|
296 | begin
|
---|
297 | if uShutDown then exit;
|
---|
298 | if not assigned(Component) then exit;
|
---|
299 | server := FindServer(Component, index);
|
---|
300 | try
|
---|
301 | if assigned(server) then
|
---|
302 | begin
|
---|
303 | uNotifier.RemoveFreeNotification(Component);
|
---|
304 | server.RemoveListProc(Proc);
|
---|
305 | if server.EventCount = 0 then
|
---|
306 | Events.Delete(index);
|
---|
307 | end;
|
---|
308 | finally
|
---|
309 | server := nil;
|
---|
310 | end;
|
---|
311 | end;
|
---|
312 |
|
---|
313 | { TMSAAImageListServer }
|
---|
314 |
|
---|
315 | procedure TMSAAServer.AddImageEvent(ImageListTypes: TVA508ImageListTypes;
|
---|
316 | Event: TVA508OnImageIndexQueryEvent);
|
---|
317 | var
|
---|
318 | data: TImageEventData;
|
---|
319 | idx: integer;
|
---|
320 | begin
|
---|
321 | idx := ImageEventIndex(Event);
|
---|
322 | if idx < 0 then
|
---|
323 | begin
|
---|
324 | data := TImageEventData.Create;
|
---|
325 | data.Event := Event;
|
---|
326 | FEventData.Add(data);
|
---|
327 | end
|
---|
328 | else
|
---|
329 | data := TImageEventData(FEventData[idx]);
|
---|
330 | data.ImageListTypes := ImageListTypes;
|
---|
331 | AssignServerType(stImageList);
|
---|
332 | end;
|
---|
333 |
|
---|
334 | procedure TMSAAServer.AddListProc(Proc: TVA508ListQueryProc);
|
---|
335 | var
|
---|
336 | data: TListProcData;
|
---|
337 | idx: integer;
|
---|
338 | begin
|
---|
339 | idx := ListProcIndex(Proc);
|
---|
340 | if idx < 0 then
|
---|
341 | begin
|
---|
342 | data := TListProcData.Create;
|
---|
343 | data.Proc := Proc;
|
---|
344 | FEventData.Add(data);
|
---|
345 | end;
|
---|
346 | AssignServerType(stList);
|
---|
347 | end;
|
---|
348 |
|
---|
349 | procedure TMSAAServer.AddProc(Proc: TVA508QueryProc);
|
---|
350 | var
|
---|
351 | data: TProcData;
|
---|
352 | idx: integer;
|
---|
353 | begin
|
---|
354 | idx := ProcIndex(Proc);
|
---|
355 | if idx < 0 then
|
---|
356 | begin
|
---|
357 | data := TProcData.Create;
|
---|
358 | data.Proc := Proc;
|
---|
359 | FEventData.Add(data);
|
---|
360 | end;
|
---|
361 | AssignServerType(stNormal);
|
---|
362 | end;
|
---|
363 |
|
---|
364 | procedure TMSAAServer.AssignServerType(AServerType: TServerType);
|
---|
365 | begin
|
---|
366 | FServerTypes := FServerTypes + [AServerType];
|
---|
367 | end;
|
---|
368 |
|
---|
369 | procedure TMSAAServer.Attach;
|
---|
370 | begin
|
---|
371 | if (not FAttached) and (not uShutDown) and (FComponent.Handle <> 0) then
|
---|
372 | begin
|
---|
373 | // if FServerType = stNormal then
|
---|
374 | // FAttached := Succeeded(AccPropServices.SetHwndPropServer(FComponent.Handle,
|
---|
375 | // OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1, Self, ANNO_THIS))
|
---|
376 | // else
|
---|
377 | FAttached := Succeeded(AccPropServices.SetHwndPropServer(FComponent.Handle,
|
---|
378 | OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1, Self, ANNO_CONTAINER));
|
---|
379 | end;
|
---|
380 | end;
|
---|
381 |
|
---|
382 | constructor TMSAAServer.Create(AComponent: TWinControl);
|
---|
383 | begin
|
---|
384 | IncAccServices;
|
---|
385 | FComponent := AComponent;
|
---|
386 | FEventData := TObjectList.Create;
|
---|
387 | if AComponent.Showing then
|
---|
388 | Attach
|
---|
389 | else
|
---|
390 | Hook;
|
---|
391 | end;
|
---|
392 |
|
---|
393 | destructor TMSAAServer.Destroy;
|
---|
394 | begin
|
---|
395 | Detatch;
|
---|
396 | FreeAndNil(FEventData);
|
---|
397 | DecAccServices;
|
---|
398 | inherited;
|
---|
399 | end;
|
---|
400 |
|
---|
401 | procedure TMSAAServer.Detatch;
|
---|
402 | var
|
---|
403 | Ok2Detatch: boolean;
|
---|
404 | begin
|
---|
405 | if FAttached and (not uShutDown) then
|
---|
406 | begin
|
---|
407 | Ok2Detatch := (not (csDestroying in FComponent.ComponentState)) and FComponent.visible;
|
---|
408 | if Ok2Detatch then
|
---|
409 | begin
|
---|
410 | if Succeeded(AccPropServices.ClearHwndProps(FComponent.Handle,
|
---|
411 | OBJID_CLIENT, CHILDID_SELF, @NamePropIDs, 1)) then
|
---|
412 | FAttached := FALSE;
|
---|
413 | end
|
---|
414 | else
|
---|
415 | FAttached := FALSE;
|
---|
416 | end;
|
---|
417 | end;
|
---|
418 |
|
---|
419 | function TMSAAServer.EventCount: integer;
|
---|
420 | begin
|
---|
421 | Result := FEventData.Count;
|
---|
422 | end;
|
---|
423 |
|
---|
424 | function TMSAAServer.ImageEventIndex(
|
---|
425 | Event: TVA508OnImageIndexQueryEvent): integer;
|
---|
426 | var
|
---|
427 | i: integer;
|
---|
428 | data: TImageEventData;
|
---|
429 | begin
|
---|
430 | for i := 0 to FEventData.Count - 1 do
|
---|
431 | begin
|
---|
432 | if FEventData[i] is TImageEventData then
|
---|
433 | begin
|
---|
434 | data := TImageEventData(FEventData[i]);
|
---|
435 | if (TMethod(data.Event).Code = TMethod(Event).Code) and
|
---|
436 | (TMethod(data.Event).Data = TMethod(Event).Data) then
|
---|
437 | begin
|
---|
438 | Result := i;
|
---|
439 | exit;
|
---|
440 | end;
|
---|
441 | end;
|
---|
442 | end;
|
---|
443 | Result := -1;
|
---|
444 | end;
|
---|
445 |
|
---|
446 | function TMSAAServer.ListProcIndex(Proc: TVA508ListQueryProc): integer;
|
---|
447 | var
|
---|
448 | i: integer;
|
---|
449 | data: TListProcData;
|
---|
450 | begin
|
---|
451 | for i := 0 to FEventData.Count - 1 do
|
---|
452 | begin
|
---|
453 | if FEventData[i] is TListProcData then
|
---|
454 | begin
|
---|
455 | data := TListProcData(FEventData[i]);
|
---|
456 | if @data.Proc = @Proc then
|
---|
457 | begin
|
---|
458 | Result := i;
|
---|
459 | exit;
|
---|
460 | end;
|
---|
461 | end;
|
---|
462 | end;
|
---|
463 | Result := -1;
|
---|
464 | end;
|
---|
465 |
|
---|
466 | function TMSAAServer.GetComponent: TWinControl;
|
---|
467 | begin
|
---|
468 | Result := FComponent;
|
---|
469 | end;
|
---|
470 |
|
---|
471 | function TMSAAServer.GetPropValue(const pIDString: PByte;
|
---|
472 | dwIDStringLen: LongWord; idProp: MSAAPROPID; out pvarValue: OleVariant;
|
---|
473 | out pfHasProp: Integer): HResult;
|
---|
474 | var
|
---|
475 | phwnd: HWND;
|
---|
476 | pidObject: LongWord;
|
---|
477 | pidChild: LongWord;
|
---|
478 | text, CombinedText: string;
|
---|
479 |
|
---|
480 | function Append(data: array of string): string;
|
---|
481 | var
|
---|
482 | i: integer;
|
---|
483 | begin
|
---|
484 | Result := '';
|
---|
485 | for i := low(data) to high(data) do
|
---|
486 | begin
|
---|
487 | if data[i] <> '' then
|
---|
488 | begin
|
---|
489 | if result <> '' then
|
---|
490 | Result := Result + ' ';
|
---|
491 | Result := Result + data[i];
|
---|
492 | end;
|
---|
493 | end;
|
---|
494 | end;
|
---|
495 |
|
---|
496 | function GetImageLabelText(ImageListType: TVA508ImageListType; ImageIndex: integer): string;
|
---|
497 | var
|
---|
498 | i: integer;
|
---|
499 | Data: TImageEventData;
|
---|
500 | begin
|
---|
501 | Result := '';
|
---|
502 | for i := 0 to FEventData.Count - 1 do
|
---|
503 | begin
|
---|
504 | if FEventData[i] is TImageEventData then
|
---|
505 | begin
|
---|
506 | data := TImageEventData(FEventData[i]);
|
---|
507 | if ImageListType in data.ImageListTypes then
|
---|
508 | begin
|
---|
509 | data.Event(FComponent, ImageIndex, ImageListType, Result);
|
---|
510 | break;
|
---|
511 | end;
|
---|
512 | end;
|
---|
513 | end;
|
---|
514 | end;
|
---|
515 |
|
---|
516 | procedure DoTreeView;
|
---|
517 | var
|
---|
518 | id: HTREEITEM;
|
---|
519 | node: TTreeNode;
|
---|
520 | overlay: string;
|
---|
521 | state: string;
|
---|
522 | tree:TExposedTreeView;
|
---|
523 | begin
|
---|
524 | tree := TExposedTreeView(FComponent);
|
---|
525 | id := HTREEITEM(pidChild);
|
---|
526 | node := tree.Items.GetNode(id);
|
---|
527 | if assigned(node) then
|
---|
528 | begin
|
---|
529 | state := '';
|
---|
530 | overlay := '';
|
---|
531 | // 0 state not valid on tree views
|
---|
532 | if assigned(tree.StateImages) and (node.StateIndex > 0) then
|
---|
533 | state := GetImageLabelText(iltStateImages, node.StateIndex);
|
---|
534 | if node.Selected then
|
---|
535 | text := GetImageLabelText(iltImages, node.SelectedIndex)
|
---|
536 | else
|
---|
537 | text := GetImageLabelText(iltImages, node.ImageIndex);
|
---|
538 | if node.OverlayIndex >= 0 then
|
---|
539 | begin
|
---|
540 | overlay := GetImageLabelText(iltOverlayImages, node.OverlayIndex);
|
---|
541 | end;
|
---|
542 | text := Append([state, text, overlay, node.Text]);
|
---|
543 | end;
|
---|
544 | end;
|
---|
545 |
|
---|
546 | procedure DoListView;
|
---|
547 | var
|
---|
548 | view: TExposedListView;
|
---|
549 | ilType: TVA508ImageListType;
|
---|
550 | item: TListItem;
|
---|
551 | state: string;
|
---|
552 | overlay: string;
|
---|
553 | i: integer;
|
---|
554 | coltext: string;
|
---|
555 | begin
|
---|
556 | view := TExposedListView(FComponent);
|
---|
557 | if pidChild > LongWord(view.Items.Count) then exit;
|
---|
558 | state := '';
|
---|
559 | overlay := '';
|
---|
560 | item := view.Items[pidChild-1];
|
---|
561 | if assigned(view.StateImages) then
|
---|
562 | state := GetImageLabelText(iltStateImages, item.StateIndex);
|
---|
563 | if view.ViewStyle = vsIcon then
|
---|
564 | ilType := iltLargeImages
|
---|
565 | else
|
---|
566 | ilType := iltSmallImages;
|
---|
567 | text := GetImageLabelText(ilType, item.ImageIndex);
|
---|
568 | if (item.OverlayIndex >= 0) then
|
---|
569 | overlay := GetImageLabelText(iltOverlayImages, item.OverlayIndex);
|
---|
570 | text := Append([state, text, overlay]);
|
---|
571 |
|
---|
572 | if not (stList in FServerTypes) then
|
---|
573 | begin
|
---|
574 | if (view.ViewStyle = vsReport) and (view.Columns.Count > 0) then
|
---|
575 | text := Append([text, view.Columns[0].Caption]);
|
---|
576 | colText := item.Caption;
|
---|
577 | if colText = '' then
|
---|
578 | colText := 'blank';
|
---|
579 | text := Append([text, colText]);
|
---|
580 |
|
---|
581 | if view.ViewStyle = vsReport then
|
---|
582 | begin
|
---|
583 | for i := 1 to view.Columns.Count - 1 do
|
---|
584 | begin
|
---|
585 | if view.Columns[i].Width > 0 then
|
---|
586 | begin
|
---|
587 | text := Append([text, view.Columns[i].Caption]);
|
---|
588 | if (i-1) < item.SubItems.Count then
|
---|
589 | colText := item.SubItems[i-1]
|
---|
590 | else
|
---|
591 | colText := '';
|
---|
592 | if colText = '' then
|
---|
593 | colText := 'blank';
|
---|
594 | Text := Append([text, colText + ',']);
|
---|
595 | end;
|
---|
596 | end;
|
---|
597 | end;
|
---|
598 | end;
|
---|
599 | end;
|
---|
600 |
|
---|
601 | procedure DoListComponent;
|
---|
602 | var
|
---|
603 | i: integer;
|
---|
604 | data: TListProcData;
|
---|
605 | begin
|
---|
606 | for i := 0 to FEventData.Count - 1 do
|
---|
607 | begin
|
---|
608 | if FEventData[i] is TListProcData then
|
---|
609 | begin
|
---|
610 | data := TListProcData(FEventData[i]);
|
---|
611 | data.Proc(FComponent, pidChild-1, text);
|
---|
612 | end;
|
---|
613 | end;
|
---|
614 | end;
|
---|
615 |
|
---|
616 | procedure DoNormalComponent;
|
---|
617 | var
|
---|
618 | i: integer;
|
---|
619 | data: TProcData;
|
---|
620 | begin
|
---|
621 | for i := 0 to FEventData.Count - 1 do
|
---|
622 | begin
|
---|
623 | if FEventData[i] is TProcData then
|
---|
624 | begin
|
---|
625 | data := TProcData(FEventData[i]);
|
---|
626 | data.Proc(FComponent, text);
|
---|
627 | end;
|
---|
628 | end;
|
---|
629 | end;
|
---|
630 |
|
---|
631 | procedure HasProperty;
|
---|
632 | begin
|
---|
633 | TVarData(pvarValue).VType := VT_BSTR;
|
---|
634 | pfHasProp := 1;
|
---|
635 | text := '';
|
---|
636 | end;
|
---|
637 |
|
---|
638 | procedure NoProperty;
|
---|
639 | begin
|
---|
640 | TVarData(pvarValue).VType := VT_EMPTY;
|
---|
641 | pfHasProp := 0;
|
---|
642 | end;
|
---|
643 |
|
---|
644 | begin
|
---|
645 | VariantInit(pvarValue);
|
---|
646 | OleCheck(AccPropServices.DecomposeHwndIdentityString(pIDString, dwIDStringLen,
|
---|
647 | phwnd, pidObject, pidChild));
|
---|
648 | if (phwnd = FComponent.Handle) then
|
---|
649 | begin
|
---|
650 | if (pidChild = CHILDID_SELF) then
|
---|
651 | begin
|
---|
652 | if stNormal in FServerTypes then
|
---|
653 | begin
|
---|
654 | HasProperty;
|
---|
655 | DoNormalComponent;
|
---|
656 | pvarValue := text;
|
---|
657 | end
|
---|
658 | else
|
---|
659 | NoProperty;
|
---|
660 | end
|
---|
661 | else
|
---|
662 | begin
|
---|
663 | NoProperty;
|
---|
664 | if (FServerTypes * [stList, stImageList]) <> [] then
|
---|
665 | begin
|
---|
666 | HasProperty;
|
---|
667 | CombinedText := '';
|
---|
668 | if stImageList in FServerTypes then
|
---|
669 | begin
|
---|
670 | if FComponent is TCustomTreeView then DoTreeView else
|
---|
671 | if FComponent is TCustomListView then DoListView;
|
---|
672 | end;
|
---|
673 | CombinedText := text;
|
---|
674 | text := '';
|
---|
675 | if stList in FServerTypes then
|
---|
676 | begin
|
---|
677 | DoListComponent;
|
---|
678 | end;
|
---|
679 | if text <> '' then
|
---|
680 | begin
|
---|
681 | if CombinedText <> '' then
|
---|
682 | CombinedText := CombinedText + ' ';
|
---|
683 | CombinedText := CombinedText + text;
|
---|
684 | end;
|
---|
685 | pvarValue := CombinedText;
|
---|
686 | end;
|
---|
687 | end;
|
---|
688 | end
|
---|
689 | else
|
---|
690 | NoProperty;
|
---|
691 | Result := S_OK;
|
---|
692 | end;
|
---|
693 |
|
---|
694 | procedure TMSAAServer.Hook;
|
---|
695 | begin
|
---|
696 | FOldWndProc := FComponent.WindowProc;
|
---|
697 | FComponent.WindowProc := MSAAWindowProc;
|
---|
698 | end;
|
---|
699 |
|
---|
700 | procedure TMSAAServer.RemoveImageEvent(ImageListTypes: TVA508ImageListTypes;
|
---|
701 | Event: TVA508OnImageIndexQueryEvent);
|
---|
702 | var
|
---|
703 | idx: integer;
|
---|
704 | begin
|
---|
705 | idx := ImageEventIndex(Event);
|
---|
706 | if idx >= 0 then
|
---|
707 | FEventData.Delete(idx);
|
---|
708 | UnassignServerType(stImageList);
|
---|
709 | end;
|
---|
710 |
|
---|
711 | procedure TMSAAServer.RemoveListProc(Proc: TVA508ListQueryProc);
|
---|
712 | var
|
---|
713 | idx: integer;
|
---|
714 | begin
|
---|
715 | idx := ListProcIndex(Proc);
|
---|
716 | if idx >= 0 then
|
---|
717 | FEventData.Delete(idx);
|
---|
718 | UnassignServerType(stList);
|
---|
719 | end;
|
---|
720 |
|
---|
721 | procedure TMSAAServer.RemoveProc(Proc: TVA508QueryProc);
|
---|
722 | var
|
---|
723 | idx: integer;
|
---|
724 | begin
|
---|
725 | idx := ProcIndex(Proc);
|
---|
726 | if idx >= 0 then
|
---|
727 | FEventData.Delete(idx);
|
---|
728 | UnassignServerType(stNormal);
|
---|
729 | end;
|
---|
730 |
|
---|
731 | class procedure TMSAAServer.ValidateServerType(AComponent: TWinControl; AServerType: TServerType);
|
---|
732 | var
|
---|
733 | i: integer;
|
---|
734 |
|
---|
735 | begin
|
---|
736 | if AServerType = stImageList then
|
---|
737 | begin
|
---|
738 | for i := low(VA508ImageListLabelerClasses) to high(VA508ImageListLabelerClasses) do
|
---|
739 | begin
|
---|
740 | if AComponent is VA508ImageListLabelerClasses[i] then exit;
|
---|
741 | end;
|
---|
742 | raise TVA508Exception.Create('Unsupported Image List MSAA Label Component');
|
---|
743 | end;
|
---|
744 | end;
|
---|
745 |
|
---|
746 | procedure TMSAAServer.UnassignServerType(AServerType: TServerType);
|
---|
747 | begin
|
---|
748 | FServerTypes := FServerTypes - [AServerType];
|
---|
749 | end;
|
---|
750 |
|
---|
751 | procedure TMSAAServer.UnHook;
|
---|
752 | begin
|
---|
753 | FComponent.WindowProc := FOldWndProc;
|
---|
754 | end;
|
---|
755 |
|
---|
756 | procedure TMSAAServer.MSAAWindowProc(var Message: TMessage);
|
---|
757 | var
|
---|
758 | DoAttach: boolean;
|
---|
759 | begin
|
---|
760 | DoAttach := (Message.Msg = CM_SHOWINGCHANGED);
|
---|
761 | FOldWndProc(Message);
|
---|
762 | if DoAttach then
|
---|
763 | begin
|
---|
764 | Unhook;
|
---|
765 | Attach;
|
---|
766 | end;
|
---|
767 | end;
|
---|
768 |
|
---|
769 | function TMSAAServer.ProcIndex(Proc: TVA508QueryProc): integer;
|
---|
770 | var
|
---|
771 | i: integer;
|
---|
772 | data: TProcData;
|
---|
773 | begin
|
---|
774 | for i := 0 to FEventData.Count - 1 do
|
---|
775 | begin
|
---|
776 | if FEventData[i] is TProcData then
|
---|
777 | begin
|
---|
778 | data := TProcData(FEventData[i]);
|
---|
779 | if @data.Proc = @Proc then
|
---|
780 | begin
|
---|
781 | Result := i;
|
---|
782 | exit;
|
---|
783 | end;
|
---|
784 | end;
|
---|
785 | end;
|
---|
786 | Result := -1;
|
---|
787 | end;
|
---|
788 |
|
---|
789 | initialization
|
---|
790 |
|
---|
791 | finalization
|
---|
792 | Cleanup;
|
---|
793 |
|
---|
794 | end.
|
---|