babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
lasarus_compotents/ToolBar 2000/Source/TB2Acc.pas

1396 lines
44 KiB
ObjectPascal
Raw Blame History

unit TB2Acc;
{$MODE Delphi}
{
Toolbar2000
Copyright (C) 1998-2008 by Jordan Russell
All rights reserved.
The contents of this file are subject to the "Toolbar2000 License"; you may
not use or distribute this file except in compliance with the
"Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in
TB2k-LICENSE.txt or at:
http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt
Alternatively, the contents of this file may be used under the terms of the
GNU General Public License (the "GPL"), in which case the provisions of the
GPL are applicable instead of those in the "Toolbar2000 License". A copy of
the GPL may be found in GPL-LICENSE.txt or at:
http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt
If you wish to allow use of your version of this file only under the terms of
the GPL and not to allow others to use your version of this file under the
"Toolbar2000 License", indicate your decision by deleting the provisions
above and replace them with the notice and other provisions required by the
GPL. If you do not delete the provisions above, a recipient may use your
version of this file under either the "Toolbar2000 License" or the GPL.
$jrsoftware: tb2k/Source/TB2Acc.pas,v 1.9 2008/04/19 05:31:00 jr Exp $
This unit is used internally to implement the IAccessible interface on
TTBView and TTBItemViewer for Microsoft Active Accessibility support.
}
interface
{$I TB2Ver.inc}
uses
LCLIntf, LCLType, LMessages, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{$IFDEF CLR} System.Runtime.InteropServices, {$ENDIF}
TB2Item;
type
{ Our declaration for IAccessible }
{$IFNDEF CLR}
TTBVariant = OleVariant;
ITBAccessible = interface(IDispatch)
['{618736E0-3C3D-11CF-810C-00AA00389B71}']
function get_accParent(out ppdispParent: IDispatch): HRESULT; stdcall;
function get_accChildCount(out pcountChildren: Integer): HRESULT; stdcall;
function get_accChild(varChild: TTBVariant; out ppdispChild: IDispatch): HRESULT; stdcall;
function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; stdcall;
function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; stdcall;
function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; stdcall;
function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; stdcall;
function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; stdcall;
function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; stdcall;
function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; stdcall;
function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; stdcall;
function get_accFocus(out pvarID: TTBVariant): HRESULT; stdcall;
function get_accSelection(out pvarChildren: TTBVariant): HRESULT; stdcall;
function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; stdcall;
function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; stdcall;
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: TTBVariant): HRESULT; stdcall;
function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; stdcall;
function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; stdcall;
function accDoDefaultAction(varChild: TTBVariant): HRESULT; stdcall;
function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; stdcall;
function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; stdcall;
end;
{$ELSE}
TTBVariant = TObject;
[ComImport,
GuidAttribute('618736E0-3C3D-11CF-810C-00AA00389B71'),
InterfaceTypeAttribute(ComInterfaceType.InterfaceIsDual)]
ITBAccessible = interface
[PreserveSig]
function get_accParent([out, MarshalAs(UnmanagedType.IDispatch)] out ppdispParent): HRESULT;
[PreserveSig]
function get_accChildCount(out pcountChildren: Integer): HRESULT;
[PreserveSig]
function get_accChild(varChild: TTBVariant; [out, MarshalAs(UnmanagedType.IDispatch)] out ppdispChild): HRESULT;
[PreserveSig]
function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT;
[PreserveSig]
function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT;
[PreserveSig]
function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT;
[PreserveSig]
function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT;
[PreserveSig]
function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT;
[PreserveSig]
function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT;
[PreserveSig]
function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT;
[PreserveSig]
function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT;
[PreserveSig]
function get_accFocus(out pvarID: TTBVariant): HRESULT;
[PreserveSig]
function get_accSelection(out pvarChildren: TTBVariant): HRESULT;
[PreserveSig]
function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT;
[PreserveSig]
function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT;
[PreserveSig]
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: TTBVariant): HRESULT;
[PreserveSig]
function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT;
[PreserveSig]
function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT;
[PreserveSig]
function accDoDefaultAction(varChild: TTBVariant): HRESULT;
[PreserveSig]
function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT;
[PreserveSig]
function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT;
end;
{$ENDIF}
TTBCustomAccObject = class(TTBBaseAccObject)
private
{$IFNDEF CLR}
FPrevious, FNext: TTBCustomAccObject;
{$ENDIF}
public
{$IFNDEF CLR}
constructor Create;
destructor Destroy; override;
{$ENDIF}
end;
{$IFDEF CLR}
{ Note: Without ComVisible(true), attempts to return objects in IAccessible's
IDispatch-type out parameters fail with InvalidCastException }
[ComVisible(true)]
{$ENDIF}
TTBViewAccObject = class(TTBCustomAccObject, ITBAccessible)
private
FView: TTBView;
function Check(const varChild: TTBVariant; var ErrorCode: HRESULT): Boolean;
{ ITBAccessible }
function accDoDefaultAction(varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accChild(varChild: TTBVariant; out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accChildCount(out pcountChildren: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accFocus(out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accSelection(out pvarChildren: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
{$IFDEF CLR}
strict protected
procedure Finalize; override;
{$ENDIF}
public
constructor Create(AView: TTBView);
{$IFNDEF CLR}
destructor Destroy; override;
{$ENDIF}
procedure ClientIsDestroying; override;
end;
{$IFDEF CLR}
[ComVisible(true)]
{$ENDIF}
TTBItemViewerAccObject = class(TTBCustomAccObject, ITBAccessible)
private
FViewer: TTBItemViewer;
function Check(const varChild: TTBVariant; var ErrorCode: HRESULT): Boolean;
function IsActionable: Boolean;
function IsAvailable: Boolean;
function IsFocusable: Boolean;
{ ITBAccessible }
function accDoDefaultAction(varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accChild(varChild: TTBVariant; out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accChildCount(out pcountChildren: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accFocus(out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accSelection(out pvarChildren: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF}
{$IFDEF CLR}
strict protected
procedure Finalize; override;
{$ENDIF}
public
constructor Create(AViewer: TTBItemViewer);
{$IFNDEF CLR}
destructor Destroy; override;
{$ENDIF}
procedure ClientIsDestroying; override;
procedure HandleAccSelect(const AExecute: Boolean);
end;
procedure CallNotifyWinEvent(event: DWORD; hwnd: HWND; idObject: DWORD;
idChild: Longint);
function InitializeOleAcc: Boolean;
{$IFNDEF CLR}
var
LresultFromObjectFunc: function(const riid: TGUID; wParam: WPARAM;
pUnk: IUnknown): LRESULT; stdcall;
AccessibleObjectFromWindowFunc: function(hwnd: HWND; dwId: DWORD;
const riid: TGUID; out ppvObject): HRESULT; stdcall;
{$ELSE}
function LresultFromObjectFunc([in, MarshalAs(UnmanagedType.LPStruct)] riid: TGUID;
wParam: WPARAM; [in, MarshalAs(UnmanagedType.IUnknown)] pUnk: TObject): LRESULT;
function AccessibleObjectFromWindowFunc(hwnd: HWND; dwId: DWORD;
[in, MarshalAs(UnmanagedType.LPStruct)] riid: TGUID;
[MarshalAs(UnmanagedType.Interface)] out ppvObject): HRESULT;
{$ENDIF}
var
{ For debugging purposes only: }
ViewAccObjectInstances: Integer = 0;
ItemViewerAccObjectInstances: Integer = 0;
implementation
uses
{$IFDEF CLR} System.Security, System.Threading, Types, {$ENDIF}
{$IFNDEF CLR} {$IFDEF JR_D6} Variants, {$ENDIF} {$ENDIF}
ActiveX, Menus, TB2Common;
const
{ Constants from OleAcc.h }
ROLE_SYSTEM_MENUBAR = $2;
ROLE_SYSTEM_CLIENT = $a;
ROLE_SYSTEM_MENUPOPUP = $b;
ROLE_SYSTEM_MENUITEM = $c;
ROLE_SYSTEM_SEPARATOR = $15;
ROLE_SYSTEM_TOOLBAR = $16;
ROLE_SYSTEM_PUSHBUTTON = $2b;
ROLE_SYSTEM_BUTTONMENU = $39;
STATE_SYSTEM_HASPOPUP = $40000000;
NAVDIR_UP = 1;
NAVDIR_DOWN = 2;
NAVDIR_LEFT = 3;
NAVDIR_RIGHT = 4;
NAVDIR_NEXT = 5;
NAVDIR_PREVIOUS = 6;
NAVDIR_FIRSTCHILD = 7;
NAVDIR_LASTCHILD = 8;
SELFLAG_TAKEFOCUS = 1;
type
{$IFNDEF CLR}
TControlAccess = class(TControl);
{$ENDIF}
TTBViewAccess = class(TTBView);
TTBCustomItemAccess = class(TTBCustomItem);
TTBItemViewerAccess = class(TTBItemViewer);
{$IFNDEF CLR}
var
LastAccObject: TTBCustomAccObject; { last object in the linked list }
LastAccObjectCritSect: TRTLCriticalSection;
NotifyWinEventInited: BOOL;
NotifyWinEventFunc: procedure(event: DWORD; hwnd: HWND; idObject: Longint;
idChild: Longint); stdcall;
{$ENDIF}
{$IFDEF CLR}
[SuppressUnmanagedCodeSecurity, DllImport('oleacc.dll', CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'LresultFromObject')]
function LresultFromObjectFunc; external;
[SuppressUnmanagedCodeSecurity, DllImport('oleacc.dll', CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'AccessibleObjectFromWindow')]
function AccessibleObjectFromWindowFunc; external;
{$ENDIF}
procedure CallNotifyWinEvent(event: DWORD; hwnd: HWND; idObject: DWORD;
idChild: Longint);
begin
{$IFNDEF CLR}
if not NotifyWinEventInited then begin
NotifyWinEventFunc := GetProcAddress(GetModuleHandle(user32), 'NotifyWinEvent');
InterlockedExchange(Integer(NotifyWinEventInited), Ord(True));
end;
if Assigned(NotifyWinEventFunc) then
NotifyWinEventFunc(event, hwnd, Longint(idObject), idChild);
{$ELSE}
{ NotifyWinEvent is supported on all platforms .NET supports }
NotifyWinEvent(event, hwnd, Longint(idObject), idChild);
{$ENDIF}
end;
var
OleAccInited: Integer;
OleAccAvailable: BOOL;
function InitializeOleAcc: Boolean;
var
M: HMODULE;
begin
if OleAccInited = 0 then begin
M := {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} ('oleacc.dll');
if M <> 0 then begin
{$IFNDEF CLR}
LresultFromObjectFunc := GetProcAddress(M, 'LresultFromObject');
AccessibleObjectFromWindowFunc := GetProcAddress(M, 'AccessibleObjectFromWindow');
if Assigned(LresultFromObjectFunc) and
Assigned(AccessibleObjectFromWindowFunc) then
{$ENDIF}
OleAccAvailable := True;
end;
InterlockedExchange(OleAccInited, 1);
end;
Result := OleAccAvailable;
end;
{$IFNDEF CLR}
function AccObjectFromWindow(const Wnd: HWND; out ADisp: IDispatch): HRESULT;
begin
Result := AccessibleObjectFromWindowFunc(Wnd, OBJID_WINDOW, IDispatch, ADisp);
if Result <> S_OK then
ADisp := nil;
end;
{$ELSE}
function AccObjectFromWindow(const Wnd: HWND; out ADisp): HRESULT;
begin
Result := AccessibleObjectFromWindowFunc(Wnd, OBJID_WINDOW,
TypeOf(IDispatch).GUID, ADisp);
if Result <> S_OK then
ADisp := nil;
end;
{$ENDIF}
{$IFNDEF CLR}
procedure DisconnectAccObjects;
{ This procedure calls CoDisconnectObject() on all acc. objects still
allocated. This is needed to prevent potential AV's when TB2k is compiled
into a DLL, since a DLL may be freed by the application while an MSAA
client still holds acc. object references. }
var
Obj, PrevObj: TTBCustomAccObject;
begin
Obj := LastAccObject;
while Assigned(Obj) do begin
{ Make a copy of Obj.FPrevious since CoDisconnectObject may cause Obj
to be freed }
PrevObj := Obj.FPrevious;
{ CoDisconnectObject should cause remote MSAA clients to release all
references to the object, thus destroying it (assuming the local
application doesn't have references of its own). }
CoDisconnectObject(Obj, 0);
Obj := PrevObj;
end;
end;
{$ELSE}
{ DisconnectAccObjects isn't implemented on .NET because:
- I'm not sure it's needed (the case mentioned above doesn't apply).
- Keeping references to objects in a global linked list would prevent the GC
from ever reclaiming the unused ones.
- The current implementation of TTBStandardOleMarshalObject.DisconnectObject
always returns E_NOTIMPL, so CoDisconnectObject would fail.
- Windows Forms doesn't appear to do it. (Its accessible objects are
derived from StandardOleMarshalObject, and they don't appear to override
the default E_NOTIMPL handling.) }
{$ENDIF}
function GetAltKeyName: String;
{ This silly function is needed since ShortCutToText(VK_MENU) fails on Delphi
and C++Builder versions <= 4 }
{$IFNDEF CLR}
var
ScanCode: UINT;
KeyName: array[0..255] of Char;
begin
ScanCode := MapVirtualKey(VK_MENU, 0) shl 16;
if (ScanCode <> 0) and
(GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName) div SizeOf(KeyName[0])) > 0) then
Result := KeyName
else
Result := 'Alt'; { shouldn't get here, but just in case... }
end;
{$ELSE}
begin
Result := ShortCutToText(VK_MENU);
end;
{$ENDIF}
function VarIsInteger(const AVar: TTBVariant): Boolean;
{ Returns True if the specified variant is of type VT_I4, the only integer
type used/allowed in MSAA }
begin
{$IFNDEF CLR}
Result := (VarType(AVar) = varInteger);
{$ELSE}
Result := Assigned(AVar) and (System.Type.GetTypeCode(AVar.GetType) = TypeCode.Int32);
{$ENDIF}
end;
procedure AssignObjectToVar(var AVariant: TTBVariant; const AObject: TTBBaseAccObject);
{ Creates a VT_DISPATCH-type variant that references AObject }
begin
{$IFNDEF CLR}
AVariant := IDispatch(AObject);
{$ELSE}
AVariant := AObject;
{$ENDIF}
end;
{ TTBCustomAccObject }
{$IFNDEF CLR}
constructor TTBCustomAccObject.Create;
begin
inherited Create;
{ Add Self to linked list of objects }
EnterCriticalSection(LastAccObjectCritSect);
try
FPrevious := LastAccObject;
if Assigned(FPrevious) then
FPrevious.FNext := Self;
LastAccObject := Self;
finally
LeaveCriticalSection(LastAccObjectCritSect);
end;
end;
{$ENDIF}
{$IFNDEF CLR}
destructor TTBCustomAccObject.Destroy;
begin
{ Remove Self from linked list of objects }
EnterCriticalSection(LastAccObjectCritSect);
try
if LastAccObject = Self then
LastAccObject := FPrevious;
if Assigned(FPrevious) then
FPrevious.FNext := FNext;
if Assigned(FNext) then
FNext.FPrevious := FPrevious;
finally
LeaveCriticalSection(LastAccObjectCritSect);
end;
inherited;
end;
{$ENDIF}
{ TTBViewAccObject }
constructor TTBViewAccObject.Create(AView: TTBView);
begin
inherited Create;
FView := AView;
InterlockedIncrement(ViewAccObjectInstances);
end;
{$IFNDEF CLR}
destructor TTBViewAccObject.Destroy;
begin
InterlockedDecrement(ViewAccObjectInstances);
if Assigned(FView) then begin
TTBViewAccess(FView).FAccObjectInstance := nil;
FView := nil;
end;
inherited;
end;
{$ELSE}
procedure TTBViewAccObject.Finalize;
begin
InterlockedDecrement(ViewAccObjectInstances);
inherited;
end;
{$ENDIF}
procedure TTBViewAccObject.ClientIsDestroying;
begin
FView := nil;
end;
function TTBViewAccObject.Check(const varChild: TTBVariant;
var ErrorCode: HRESULT): Boolean;
begin
if FView = nil then begin
ErrorCode := E_FAIL;
Result := False;
end
else if not VarIsInteger(varChild) or (Integer(varChild) <> CHILDID_SELF) then begin
ErrorCode := E_INVALIDARG;
Result := False;
end
else
Result := True;
end;
function TTBViewAccObject.accDoDefaultAction(varChild: TTBVariant): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.accHitTest(xLeft, yTop: Integer;
out pvarID: TTBVariant): HRESULT;
var
ViewWnd, W: HWND;
R: TRect;
P: TPoint;
D: {$IFNDEF CLR} IDispatch {$ELSE} TObject {$ENDIF};
V: TTBItemViewer;
begin
try
if FView = nil then begin
Result := E_FAIL;
Exit;
end;
ViewWnd := FView.Window.Handle;
GetWindowRect(ViewWnd, R);
P.X := xLeft;
P.Y := yTop;
if PtInRect(R, P) then begin
P := FView.Window.ScreenToClient(P);
W := ChildWindowFromPointEx(ViewWnd, P, CWP_SKIPINVISIBLE);
if (W <> 0) and (W <> ViewWnd) then begin
{ Point is inside a child window (most likely belonging to a
TTBControlItem) }
Result := AccObjectFromWindow(W, D);
pvarID := D;
end
else begin
V := FView.ViewerFromPoint(P);
if Assigned(V) then
AssignObjectToVar(pvarID, V.GetAccObject)
else
pvarID := TTBVariant(Integer(CHILDID_SELF));
Result := S_OK;
end;
end
else
Result := S_FALSE;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.accLocation(out pxLeft, pyTop, pcxWidth,
pcyHeight: Integer; varChild: TTBVariant): HRESULT;
var
R: TRect;
begin
try
if not Check(varChild, Result) then
Exit;
GetWindowRect(FView.Window.Handle, R);
pxLeft := R.Left;
pyTop := R.Top;
pcxWidth := R.Right - R.Left;
pcyHeight := R.Bottom - R.Top;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.accNavigate(navDir: Integer; varStart: TTBVariant;
out pvarEnd: TTBVariant): HRESULT;
var
I: Integer;
begin
try
if not Check(varStart, Result) then
Exit;
Result := S_FALSE;
case navDir of
NAVDIR_FIRSTCHILD: begin
for I := 0 to FView.ViewerCount-1 do
if FView.Viewers[I].IsAccessible then begin
AssignObjectToVar(pvarEnd, FView.Viewers[I].GetAccObject);
Result := S_OK;
Break;
end;
end;
NAVDIR_LASTCHILD: begin
for I := FView.ViewerCount-1 downto 0 do
if FView.Viewers[I].IsAccessible then begin
AssignObjectToVar(pvarEnd, FView.Viewers[I].GetAccObject);
Result := S_OK;
Break;
end;
end;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.accSelect(flagsSelect: Integer;
varChild: TTBVariant): HRESULT;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
function TTBViewAccObject.get_accChild(varChild: TTBVariant;
out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT;
var
I, J: Integer;
Viewer: TTBItemViewer;
Ctl: TControl;
begin
try
if FView = nil then begin
Result := E_FAIL;
Exit;
end;
if not VarIsInteger(varChild) then begin
Result := E_INVALIDARG;
Exit;
end;
I := Integer(varChild);
if I = CHILDID_SELF then begin
ppdispChild := Self;
Result := S_OK;
end
else begin
{ Convert a one-based child index (I) into a real viewer index (J) }
J := 0;
while J < FView.ViewerCount do begin
if FView.Viewers[J].IsAccessible then begin
if I = 1 then Break;
Dec(I);
end;
Inc(J);
end;
if J >= FView.ViewerCount then begin
{ 'I' was either negative or too high }
Result := E_INVALIDARG;
Exit;
end;
Viewer := FView.Viewers[J];
if Viewer.Item is TTBControlItem then begin
{ For windowed controls, return the window's accessible object instead
of the item viewer's }
Ctl := TTBControlItem(Viewer.Item).Control;
if (Ctl is TWinControl) and TWinControl(Ctl).HandleAllocated then begin
Result := AccObjectFromWindow(TWinControl(Ctl).Handle, ppdispChild);
Exit;
end;
end;
ppdispChild := Viewer.GetAccObject;
Result := S_OK;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accChildCount(out pcountChildren: Integer): HRESULT;
var
Count, I: Integer;
begin
try
if Assigned(FView) then begin
Count := 0;
for I := 0 to FView.ViewerCount-1 do
if FView.Viewers[I].IsAccessible then
Inc(Count);
pCountChildren := Count;
Result := S_OK;
end
else
Result := E_FAIL;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accDefaultAction(varChild: TTBVariant;
out pszDefaultAction: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.get_accDescription(varChild: TTBVariant;
out pszDescription: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.get_accFocus(out pvarID: TTBVariant): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.get_accHelp(varChild: TTBVariant;
out pszHelp: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.get_accHelpTopic(out pszHelpFile: WideString;
varChild: TTBVariant; out pidTopic: Integer): HRESULT;
begin
pidTopic := 0; { Delphi doesn't implicitly clear Integer 'out' parameters }
Result := S_FALSE;
end;
function TTBViewAccObject.get_accKeyboardShortcut(varChild: TTBVariant;
out pszKeyboardShortcut: WideString): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
if vsMenuBar in FView.Style then begin
pszKeyboardShortcut := GetAltKeyName;
Result := S_OK;
end
else
Result := S_FALSE;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accName(varChild: TTBVariant;
out pszName: WideString): HRESULT;
var
S: String;
begin
try
if not Check(varChild, Result) then
Exit;
if Assigned(FView.ParentView) and Assigned(FView.ParentView.OpenViewer) then
S := StripAccelChars(TTBItemViewerAccess(FView.ParentView.OpenViewer).GetCaptionText);
if S = '' then
{$IFNDEF CLR}
S := TControlAccess(FView.Window).Caption;
{$ELSE}
S := FView.Window.GetText;
{$ENDIF}
pszName := S;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT;
begin
try
if Assigned(FView) then begin
if Assigned(FView.ParentView) and Assigned(FView.ParentView.OpenViewer) then begin
ppdispParent := FView.ParentView.OpenViewer.GetAccObject;
Result := S_OK;
end
else
Result := AccObjectFromWindow(FView.Window.Handle, ppdispParent);
end
else
Result := E_FAIL;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accRole(varChild: TTBVariant;
out pvarRole: TTBVariant): HRESULT;
var
Role: Integer;
begin
try
if not Check(varChild, Result) then
Exit;
if FView.IsPopup then
Role := ROLE_SYSTEM_MENUPOPUP
else begin
if vsMenuBar in FView.Style then
Role := ROLE_SYSTEM_MENUBAR
else
Role := ROLE_SYSTEM_TOOLBAR;
end;
pvarRole := TTBVariant(Role);
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accSelection(out pvarChildren: TTBVariant): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.get_accState(varChild: TTBVariant;
out pvarState: TTBVariant): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
pvarState := TTBVariant(Integer(0));
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBViewAccObject.get_accValue(varChild: TTBVariant;
out pszValue: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.put_accName(varChild: TTBVariant;
const pszName: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBViewAccObject.put_accValue(varChild: TTBVariant;
const pszValue: WideString): HRESULT;
begin
Result := S_FALSE;
end;
{ TTBItemViewerAccObject }
constructor TTBItemViewerAccObject.Create(AViewer: TTBItemViewer);
begin
inherited Create;
FViewer := AViewer;
InterlockedIncrement(ItemViewerAccObjectInstances);
end;
{$IFNDEF CLR}
destructor TTBItemViewerAccObject.Destroy;
begin
InterlockedDecrement(ItemViewerAccObjectInstances);
if Assigned(FViewer) then begin
TTBItemViewerAccess(FViewer).FAccObjectInstance := nil;
FViewer := nil;
end;
inherited;
end;
{$ELSE}
procedure TTBItemViewerAccObject.Finalize;
begin
InterlockedDecrement(ItemViewerAccObjectInstances);
inherited;
end;
{$ENDIF}
procedure TTBItemViewerAccObject.ClientIsDestroying;
begin
FViewer := nil;
end;
function TTBItemViewerAccObject.Check(const varChild: TTBVariant;
var ErrorCode: HRESULT): Boolean;
begin
if FViewer = nil then begin
ErrorCode := E_FAIL;
Result := False;
end
else if not VarIsInteger(varChild) or (Integer(varChild) <> CHILDID_SELF) then begin
ErrorCode := E_INVALIDARG;
Result := False;
end
else
Result := True;
end;
function TTBItemViewerAccObject.IsActionable: Boolean;
{ Returns True if 'doDefaultAction' may be performed on the viewer, i.e. if
it's visible/off-edge/clipped, enabled & selectable, and the view is
focusable. }
begin
Result := FViewer.IsAccessible and IsAvailable and IsFocusable;
end;
function TTBItemViewerAccObject.IsAvailable: Boolean;
{ Returns True if the viewer's item is enabled and selectable }
begin
Result := FViewer.Item.Enabled and
(tbisSelectable in TTBCustomItemAccess(FViewer.Item).ItemStyle);
end;
function TTBItemViewerAccObject.IsFocusable: Boolean;
{ Returns True if viewers on the view can be 'focused' (i.e. the view's window
doesn't have the csDesigning state, the window is visible and enabled, and
the application is active). }
function IsWindowAndParentsEnabled(W: HWND): Boolean;
begin
Result := True;
repeat
if not IsWindowEnabled(W) then begin
Result := False;
Break;
end;
W := GetParent(W);
until W = 0;
end;
var
ViewWnd, ActiveWnd: HWND;
begin
Result := False;
if csDesigning in FViewer.View.Window.ComponentState then
Exit;
ViewWnd := FViewer.View.Window.Handle;
if IsWindowVisible(ViewWnd) and IsWindowAndParentsEnabled(ViewWnd) then begin
if vsModal in FViewer.View.State then
Result := True
else begin
ActiveWnd := GetActiveWindow;
if (ActiveWnd <> 0) and
((ActiveWnd = ViewWnd) or IsChild(ActiveWnd, ViewWnd)) then
Result := True;
end;
end;
end;
procedure TTBItemViewerAccObject.HandleAccSelect(const AExecute: Boolean);
begin
if Assigned(FViewer) and
((AExecute and IsActionable) or (not AExecute and IsFocusable)) then begin
FViewer.View.Selected := FViewer;
FViewer.View.ScrollSelectedIntoView;
if vsModal in FViewer.View.State then begin
if AExecute then
FViewer.View.ExecuteSelected(False);
end
else if (FViewer.View.ParentView = nil) and (GetCapture = 0) then begin
if AExecute then
FViewer.View.EnterToolbarLoop([tbetExecuteSelected, tbetFromMSAA])
else
FViewer.View.EnterToolbarLoop([tbetFromMSAA]);
end;
end;
end;
function TTBItemViewerAccObject.accDoDefaultAction(varChild: TTBVariant): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
{ NOTE: This must be kept in synch with get_accDefaultAction }
if IsActionable then begin
Result := S_OK;
if FViewer.View.OpenViewer = FViewer then begin
FViewer.View.CancelChildPopups;
{ Like standard menus, cancel the modal loop when a top-level menu
is closed }
if (vsModal in FViewer.View.State) and not FViewer.View.IsPopup then
FViewer.View.EndModal;
end
else begin
FViewer.View.Selected := FViewer;
FViewer.View.ScrollSelectedIntoView;
TTBItemViewerAccess(FViewer).PostAccSelect(True);
end;
end
else
{ Note: Standard menus return DISP_E_MEMBERNOTFOUND in this case but
that doesn't make much sense. The member is there but just isn't
currently available. }
Result := E_FAIL;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.accHitTest(xLeft, yTop: Integer;
out pvarID: TTBVariant): HRESULT;
var
P: TPoint;
begin
try
if FViewer = nil then begin
Result := E_FAIL;
Exit;
end;
P := FViewer.View.Window.ScreenToClient(Point(xLeft, yTop));
if PtInRect(FViewer.BoundsRect, P) then begin
pvarID := TTBVariant(Integer(CHILDID_SELF));
Result := S_OK;
end
else
Result := S_FALSE;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.accLocation(out pxLeft, pyTop, pcxWidth,
pcyHeight: Integer; varChild: TTBVariant): HRESULT;
var
R: TRect;
P: TPoint;
begin
try
if not Check(varChild, Result) then
Exit;
R := FViewer.BoundsRect;
P := FViewer.View.Window.ClientToScreen(Point(0, 0));
OffsetRect(R, P.X, P.Y);
pxLeft := R.Left;
pyTop := R.Top;
pcxWidth := R.Right - R.Left;
pcyHeight := R.Bottom - R.Top;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.accNavigate(navDir: Integer; varStart: TTBVariant;
out pvarEnd: TTBVariant): HRESULT;
var
I, J: Integer;
View: TTBView;
begin
try
if not Check(varStart, Result) then
Exit;
Result := S_FALSE;
if (navDir = NAVDIR_FIRSTCHILD) or (navDir = NAVDIR_LASTCHILD) then begin
{ Return the child view's acc. object }
View := FViewer.View.OpenViewerView;
if Assigned(View) then begin
AssignObjectToVar(pvarEnd, View.GetAccObject);
Result := S_OK;
end;
end
else begin
I := FViewer.View.IndexOf(FViewer);
if I >= 0 then begin
case navDir of
NAVDIR_UP, NAVDIR_LEFT, NAVDIR_PREVIOUS:
for J := I-1 downto 0 do
if FViewer.View.Viewers[J].IsAccessible then begin
AssignObjectToVar(pvarEnd, FViewer.View.Viewers[J].GetAccObject);
Result := S_OK;
Break;
end;
NAVDIR_DOWN, NAVDIR_RIGHT, NAVDIR_NEXT:
for J := I+1 to FViewer.View.ViewerCount-1 do
if FViewer.View.Viewers[J].IsAccessible then begin
AssignObjectToVar(pvarEnd, FViewer.View.Viewers[J].GetAccObject);
Result := S_OK;
Break;
end;
end;
end;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.accSelect(flagsSelect: Integer;
varChild: TTBVariant): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
if flagsSelect <> SELFLAG_TAKEFOCUS then begin
Result := E_INVALIDARG;
Exit;
end;
if IsFocusable and (FViewer.Show or FViewer.Clipped) then begin
FViewer.View.Selected := FViewer;
FViewer.View.ScrollSelectedIntoView;
if not(vsModal in FViewer.View.State) and
(FViewer.View.ParentView = nil) then
TTBItemViewerAccess(FViewer).PostAccSelect(False);
end
else
Result := E_FAIL;
{ ^ what Office XP returns when you try focusing an off-edge item }
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accChild(varChild: TTBVariant;
out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT;
var
View: TTBView;
begin
try
if FViewer = nil then begin
Result := E_FAIL;
Exit;
end;
Result := E_INVALIDARG;
if VarIsInteger(varChild) then begin
if Integer(varChild) = CHILDID_SELF then begin
ppdispChild := Self;
Result := S_OK;
end
else if Integer(varChild) = 1 then begin
{ Return the child view's acc. object }
View := FViewer.View.OpenViewerView;
if Assigned(View) then begin
ppdispChild := View.GetAccObject;
Result := S_OK;
end;
end;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accChildCount(out pcountChildren: Integer): HRESULT;
begin
try
if FViewer = nil then begin
Result := E_FAIL;
Exit;
end;
{ Return 1 if the viewer has a child view }
if FViewer.View.OpenViewer = FViewer then
pCountChildren := 1
else
pCountChildren := 0;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accDefaultAction(varChild: TTBVariant;
out pszDefaultAction: WideString): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
if IsActionable then begin
{ I'm not sure if these should be localized, or even if any screen
readers make use of this text...
NOTE: This must be kept in synch with accDoDefaultAction }
if FViewer.View.OpenViewer = FViewer then
pszDefaultAction := 'Close'
else if tbisSubmenu in TTBCustomItemAccess(FViewer.Item).ItemStyle then
pszDefaultAction := 'Open'
else if FViewer.View.IsPopup or (vsMenuBar in FViewer.View.Style) then
pszDefaultAction := 'Execute'
else
pszDefaultAction := 'Press';
Result := S_OK;
end
else
Result := S_FALSE;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accDescription(varChild: TTBVariant;
out pszDescription: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBItemViewerAccObject.get_accFocus(out pvarID: TTBVariant): HRESULT;
begin
try
if FViewer = nil then begin
Result := E_FAIL;
Exit;
end;
if (vsModal in FViewer.View.State) and
(FViewer.View.Selected = FViewer) then begin
pvarID := TTBVariant(Integer(CHILDID_SELF));
Result := S_OK;
end
else
Result := S_FALSE;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accHelp(varChild: TTBVariant;
out pszHelp: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBItemViewerAccObject.get_accHelpTopic(out pszHelpFile: WideString;
varChild: TTBVariant; out pidTopic: Integer): HRESULT;
begin
pidTopic := 0; { Delphi doesn't implicitly clear Integer 'out' parameters }
Result := S_FALSE;
end;
function TTBItemViewerAccObject.get_accKeyboardShortcut(varChild: TTBVariant;
out pszKeyboardShortcut: WideString): HRESULT;
var
C: Char;
begin
try
if not Check(varChild, Result) then
Exit;
Result := S_FALSE;
if TTBItemViewerAccess(FViewer).CaptionShown then begin
C := FindAccelChar(TTBItemViewerAccess(FViewer).GetCaptionText);
if C <> #0 then begin
C := CharToLower(C); { like standard menus, always use lowercase... }
if FViewer.View.IsPopup then
pszKeyboardShortcut := C
else begin
{ Prefix 'Alt+' }
pszKeyboardShortcut := GetAltKeyName + '+' + C;
end;
Result := S_OK;
end;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accName(varChild: TTBVariant;
out pszName: WideString): HRESULT;
var
C, S: String;
begin
try
if not Check(varChild, Result) then
Exit;
C := StripAccelChars(TTBItemViewerAccess(FViewer).GetCaptionText);
if not FViewer.IsToolbarStyle then
S := FViewer.Item.GetShortCutText;
if S = '' then
pszName := C
else
pszName := C + #9 + S;
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT;
begin
try
if Assigned(FViewer) then begin
ppdispParent := FViewer.View.GetAccObject;
Result := S_OK;
end
else
Result := E_FAIL;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accRole(varChild: TTBVariant;
out pvarRole: TTBVariant): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
pvarRole := TTBVariant(Integer(TTBItemViewerAccess(FViewer).GetAccRole));
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accSelection(out pvarChildren: TTBVariant): HRESULT;
begin
Result := S_FALSE;
end;
function TTBItemViewerAccObject.get_accState(varChild: TTBVariant;
out pvarState: TTBVariant): HRESULT;
var
Flags: Integer;
begin
try
if not Check(varChild, Result) then
Exit;
Flags := 0;
if FViewer.View.Selected = FViewer then begin
Flags := Flags or STATE_SYSTEM_HOTTRACKED;
if vsModal in FViewer.View.State then
Flags := Flags or STATE_SYSTEM_FOCUSED;
if FViewer.View.MouseOverSelected and FViewer.View.Capture then
{ ^ based on "IsPushed :=" code in TTBView.DrawItem }
Flags := Flags or STATE_SYSTEM_PRESSED;
end;
if tbisSubmenu in TTBCustomItemAccess(FViewer.Item).ItemStyle then
Flags := Flags or STATE_SYSTEM_HASPOPUP;
if FViewer.Show or FViewer.Clipped then begin
if IsFocusable then
Flags := Flags or STATE_SYSTEM_FOCUSABLE;
end
else begin
{ Mark off-edge items as invisible, like Office }
Flags := Flags or STATE_SYSTEM_INVISIBLE;
end;
if not IsAvailable then
Flags := Flags or STATE_SYSTEM_UNAVAILABLE;
if FViewer.Item.Checked then
Flags := Flags or STATE_SYSTEM_CHECKED;
pvarState := TTBVariant(Flags);
Result := S_OK;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.get_accValue(varChild: TTBVariant;
out pszValue: WideString): HRESULT;
begin
try
if not Check(varChild, Result) then
Exit;
if TTBItemViewerAccess(FViewer).GetAccValue(pszValue) then
Result := S_OK
else begin
{ When S_FALSE is returned, the Inspect tool wants NULL in pszValue.
On Delphi for Win32, '' is NULL. On .NET, we have to assign nil. }
pszValue := {$IFNDEF CLR} '' {$ELSE} nil {$ENDIF};
Result := S_FALSE;
end;
except
Result := E_UNEXPECTED;
end;
end;
function TTBItemViewerAccObject.put_accName(varChild: TTBVariant;
const pszName: WideString): HRESULT;
begin
Result := S_FALSE;
end;
function TTBItemViewerAccObject.put_accValue(varChild: TTBVariant;
const pszValue: WideString): HRESULT;
begin
Result := S_FALSE;
end;
{$IFNDEF CLR}
{ Note: This COM initialization code based on code from DBTables }
var
SaveInitProc: Pointer;
NeedToUninitialize: Boolean;
procedure InitCOM;
begin
if SaveInitProc <> nil then TProcedure(SaveInitProc);
NeedToUninitialize := SUCCEEDED(CoInitialize(nil));
end;
initialization
InitializeCriticalSection(LastAccObjectCritSect);
if not IsLibrary then begin
SaveInitProc := InitProc;
InitProc := @InitCOM;
end;
finalization
DisconnectAccObjects;
if NeedToUninitialize then
CoUninitialize;
DeleteCriticalSection(LastAccObjectCritSect);
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink