BSOne.SFC/Tocsg.Lib/VCL/Tocsg.MSAA.pas

682 lines
21 KiB
Plaintext

{*******************************************************}
{ }
{ Tocsg.MSAA }
{ }
{ Copyright (C) 2022 kku }
{ }
{*******************************************************}
unit Tocsg.MSAA;
interface
uses
Winapi.Windows, Winapi.oleacc, System.Classes, System.SysUtils;
const
IID_IServiceProvider: TGUID = '{6D5140C1-7436-11CE-8034-00AA006009FA}';
IID_ISimpleDOMNode: TGUID = '{1814ceeb-49e2-407f-af99-fa755a7d2607}';//'{0C539790-12E4-11CF-B661-00AA004CD6D8}';
IID_ISimpleDOMDocument: TGUID = '{0D68D6D0-D93D-4d08-A30D-F00DD1F45B24}';
IID_IEnumVARIANT: TGUID ='{00020404-0000-0000-C000-000000000046}';
type
IServiceProvider = interface(IUnknown)
[IID_IServiceProvider]
function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall;
end;
ISimpleDOMNode = interface(IUnknown)
[IID_ISimpleDOMNode]
function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall;
end;
ISimpleDOMDocument = interface(IUnknown)
[IID_ISimpleDOMDocument]
function QueryService(const rsid, IID: TGuid; out Obj): HResult; stdcall;
end;
TProcessEnumAccessible = reference to procedure(aParentAccObj, aAccObj: IAccessible; varChild: OleVariant; h: HWND; nLevel: Integer; var bContinue: Boolean);
function GetObjectState(aAccObj: IAccessible; var aVarChild: OleVariant; var nState: Integer): Boolean;
function GetObjectRole(aAccObj: IAccessible; var aVarChild: OleVariant; var nRole: Integer): Boolean;
function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant; sData: PChar): Boolean;
function GetObjectName(aAccObj: IAccessible; var aVarChild: OleVariant): String;
function GetObjectValue(aAccObj: IAccessible; var aVarChild: OleVariant): String;
function EnumAccessible(h: HWND; ProcEnumAccessible: TProcessEnumAccessible; bIncludeInvisible: Boolean = false): Boolean;
function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean;
function WindowFromAccessibleObject(aAccObj: IAccessible; var h: HWND): HRESULT; stdcall; external 'oleacc.dll';
function AccessibleChildren(paccContainer : Pointer; iChildStart : LONGINT; cChildren : LONGINT;
out rgvarChildren : OleVariant; out pcObtained : LONGINT) : HRESULT; stdcall; external 'oleacc.dll';
function GetRoleTextA(dwRole: DWORD; sRole: PAnsiChar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll';
function GetRoleTextW(dwRole: DWORD; sRole: PWideChar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll';
function GetRoleText(dwRole: DWORD; sRole: pchar; cRoleMax: byte):HRESULT; stdcall; external 'oleacc.dll' name 'GetRoleTextW';
implementation
uses
Winapi.ActiveX, System.Variants, Tocsg.Exception,
Tocsg.Trace;
var
gnLevel: Integer = 0;
function GetObjectState(aAccObj: IAccessible; var aVarChild: OleVariant; var nState: Integer): Boolean;
var
varState: OleVariant;
begin
Result := false;
try
if (aAccObj <> nil) and not VarIsNull(aVarChild) then
begin
VariantInit(varState);
try
if SUCCEEDED(aAccObj.Get_accState(aVarChild, varState)) and (TVarData(varState).VType = VT_I4) then
begin
nState := TVarData(varState).VInteger;
Result := true;
end;
finally
VariantClear(varState);
end;
end;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. GetObjectState()');
end;
end;
function GetObjectRole(aAccObj: IAccessible; var aVarChild: OleVariant; var nRole: Integer): Boolean;
var
varRole: OleVariant;
begin
Result := false;
try
if (aAccObj <> nil) and not VarIsNull(aVarChild) then
begin
VariantInit(varRole);
try
if SUCCEEDED(aAccObj.Get_accRole(aVarChild, varRole)) and (TVarData(varRole).VType = VT_I4) then
begin
nRole := TVarData(varRole).VInteger;
Result := true;
end;
finally
VariantClear(varRole);
end;
end;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. GetObjectRole()');
end;
end;
//function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant): String;
function GetObjectRoleString(aAccObj: IAccessible; var aVarChild: OleVariant; sData: PChar): Boolean;
var
varRole: OleVariant;
nLen,
nRole: Integer;
// 여기 안에서 메모리 생성하면 안되는듯.. 계속 크러쉬 난다 22_0623 14:12:59 kku
// arrBuf 선언하면 프로그램이 크러쉬 나고, pBuf로 동적으로 메모리 셋팅 하면 윈도우가 크러쉬 난다.
// 32bit 환경에서는 괜찮았던거 같은데...
// pBuf: TBytes;
// arrBuf: array [0..199] of WideChar; // 100에서 200으로 올림 22_0620 14:41:59 kku
begin
Result := false;
try
if (aAccObj <> nil) and not VarIsNull(aVarChild) then
begin
VariantInit(varRole);
try
if SUCCEEDED(aAccObj.Get_accRole(aVarChild, varRole)) then // and
// (TVarData(varRole).VType = VT_I4) then
begin
case TVarData(varRole).VType of
VT_I4 :
begin
nRole := TVarData(varRole).VInteger;
// nLen := GetRoleText(nRole, nil, 0);
// if (nLen <= 0) or (nLen > 100) then
// exit;
// SetLength(pBuf, nLen * 2);
// GetRoleText(nRole, @pBuf[0], nLen * 2);
// ZeroMemory(@arrBuf, SizeOf(arrBuf));
// nLen := GetRoleText(nRole, nil, 0);
// if (nLen <= 0) or (nLen > 100) then
// exit;
// GetRoleText(nRole, @arrBuf, nLen * 2);
//
// Result := arrBuf; // String(PChar(@pBuf[0]));
nLen := GetRoleText(nRole, nil, 0);
if (nLen <= 0) or (nLen > 100) then
begin
{$IFDEF DEBUG} ASSERT(false); {$ENDIF}
exit;
end;
Result := GetRoleText(nRole, sData, nLen * 2) > 0;
end;
// VT_BSTR :
// begin
// Result := String(TVarData(varRole).VString);
// end;
end;
end;
finally
VariantClear(varRole);
end;
end;
except
on E: Exception do
begin
ETgException.TraceException(E, 'Fail .. GetObjectRoleString()');
end;
end;
end;
function GetObjectName(aAccObj: IAccessible; var aVarChild: OleVariant): String;
var
sVal: WideString;
begin
try
sVal := '';
Result := '';
if (aAccObj <> nil) and not VarIsNull(aVarChild) then
if SUCCEEDED(aAccObj.Get_accName(aVarChild, sVal)) then
begin
Result := sVal;
end;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. GetObjectName()');
end;
end;
function GetObjectValue(aAccObj: IAccessible; var aVarChild: OleVariant): String;
var
sVal: WideString;
begin
try
sVal := '';
Result := '';
if (aAccObj <> nil) and not VarIsNull(aVarChild) then
if SUCCEEDED(aAccObj.Get_accValue(aVarChild, sVal)) then
begin
Result := sVal;
end;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. GetObjectValue()');
end;
end;
function EnumAccessible(h: HWND; ProcEnumAccessible: TProcessEnumAccessible; bIncludeInvisible: Boolean = false): Boolean;
var
AccObj: IAccessible;
begin
Result := false;
try
if IsWindow(h) and (@ProcEnumAccessible <> nil) then
begin
AccObj := nil;
if SUCCEEDED(AccessibleObjectFromWindow(h, OBJID_WINDOW, IID_IAccessible, AccObj)) and (AccObj <> nil) then
FindChildAccessible(AccObj, ProcEnumAccessible, true, bIncludeInvisible);
end;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. EnumAccessible()');
end;
end;
//function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean;
//var
// enumVar: IEnumVARIANT;
// varChild: OleVariant;
// AccChild: IAccessible;
// bContinue: Boolean;
// i, nChildCnt, nCnt,
// nState, nRole: Integer;
// dwFetched: DWORD;
// Dispatch: IDispatch;
// hChild: HWND;
// arrChild: array of OleVariant;
//begin
// Result := false;
// try
// bContinue := true;
// enumVar := nil;
//
// if bFirst then
// begin
// gnLevel := 0;
// VariantInit(varChild);
// TVarData(varChild).VType := VT_I4;
// TVarData(varChild).VInteger := CHILDID_SELF;
// ProcEnumAccessible(aAccParent, varChild, 0, gnLevel, bContinue);
// end;
// Inc(gnLevel);
//
//// aAccParent.QueryInterface(IID_IEnumVARIANT, enumVar);
//// if enumVar <> nil then
//// enumVar.Reset;
//
// nChildCnt := 0;
// aAccParent.Get_accChildCount(nChildCnt);
//
// if nChildCnt = 0 then
// exit;
//
// nCnt := 0;
// if AccessibleChildren(aAccParent, 0, nChildCnt, arrChild[0], nCnt) <> S_OK then
// exit;
//
// SetLength(arrChild, nChildCnt);
// for i := 0 to nCnt - 1 do
// begin
// if not bContinue then
// break;
//
//// VariantClear(varChild);
// varChild := arrChild[i];
//
// AccChild := nil;
//// if enumVar <> nil then
//// begin
//// dwFetched := 0;
//// if not SUCCEEDED(enumVar.Next(1, varChild, dwFetched)) then
//// begin
//// Result := false;
//// exit;
//// end;
////
//// // 위에서 성공해도 varChild가 "Unassigned" 상태일 수 있다.
//// // 이럴땐 기본값 강제로 넣어주도록 보완 18_0718 17:17:00 kku
//// if VarIsEmpty(varChild) then
//// begin
//// TVarData(varChild).VType := VT_I4;
//// TVarData(varChild).VInteger := i;
//// end;
//// end else begin
//// TVarData(varChild).VType := VT_I4;
//// TVarData(varChild).VInteger := i;
//// end;
//
// Dispatch := nil;
// case TVarData(varChild).VType of
// VT_I4 : aAccParent.Get_accChild(varChild, Dispatch);
// VT_DISPATCH : Dispatch := IDispatch(TVarData(varChild).VDispatch);
// end;
//
// if Dispatch <> nil then
// begin
// Dispatch.QueryInterface(IID_IAccessible, AccChild);
//
// if AccChild <> nil then
// begin
// VariantInit(varChild);
// TVarData(varChild).VType := VT_I4;
// TVarData(varChild).VInteger := CHILDID_SELF;
// end;
// end;
//
// nState := 0;
// hChild := 0;
// if AccChild <> nil then
// begin
// // nRole := 0;
// // GetObjectRole(AccChild, varChild, nRole);
//
// GetObjectState(AccChild, varChild, nState);
// if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then
// continue;
//
// WindowFromAccessibleObject(AccChild, hChild);
//// {$IFDEF DEBUG}
//// if gnLevel = 5 then
//// gnLevel := gnLevel + 0;
//// {$ENDIF}
// ProcEnumAccessible(AccChild, varChild, hChild, gnLevel, bContinue);
//
// if bContinue then
// bContinue := FindChildAccessible(AccChild, ProcEnumAccessible, false, bIncludeInvisible);
// end else begin
// GetObjectState(aAccParent, varChild, nState);
// if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then
// continue;
//
// WindowFromAccessibleObject(aAccParent, hChild);
// ProcEnumAccessible(aAccParent, varChild, hChild, gnLevel, bContinue);
// end;
// end;
// VariantClear(varChild);
// Dec(gnLevel);
// Result := bContinue;
// except
// on E: Exception do
// ETgException.TraceException(E, 'Fail .. FindChildAccessible()');
// end;
//end;
function FindChildAccessible(aAccParent: IAccessible; ProcEnumAccessible: TProcessEnumAccessible; bFirst, bIncludeInvisible: Boolean): Boolean;
var
enumVar: IEnumVARIANT;
varChild: OleVariant;
AccChild: IAccessible;
bContinue: Boolean;
i, nChildCnt,
nState, nRole: Integer;
dwFetched: DWORD;
Dispatch: IDispatch;
hChild: HWND;
arrChild: array of OleVariant;
begin
Result := false;
try
bContinue := true;
enumVar := nil;
if bFirst then
begin
gnLevel := 0;
VariantInit(varChild);
TVarData(varChild).VType := VT_I4;
TVarData(varChild).VInteger := CHILDID_SELF;
ProcEnumAccessible(nil, aAccParent, varChild, 0, gnLevel, bContinue);
end;
Inc(gnLevel);
aAccParent.QueryInterface(IID_IEnumVARIANT, enumVar);
if enumVar <> nil then
enumVar.Reset;
nChildCnt := 0;
aAccParent.Get_accChildCount(nChildCnt);
for i := 1 {0=self} to nChildCnt do
begin
if not bContinue then
break;
VariantClear(varChild);
AccChild := nil;
if enumVar <> nil then
begin
dwFetched := 0;
if not SUCCEEDED(enumVar.Next(1, varChild, dwFetched)) then
begin
Result := false;
exit;
end;
// 위에서 성공해도 varChild가 "Unassigned" 상태일 수 있다.
// 이럴땐 기본값 강제로 넣어주도록 보완 18_0718 17:17:00 kku
if VarIsEmpty(varChild) then
begin
TVarData(varChild).VType := VT_I4;
TVarData(varChild).VInteger := i;
end;
end else begin
TVarData(varChild).VType := VT_I4;
TVarData(varChild).VInteger := i;
end;
Dispatch := nil;
case TVarData(varChild).VType of
VT_I4 : aAccParent.Get_accChild(varChild, Dispatch);
VT_DISPATCH : Dispatch := IDispatch(TVarData(varChild).VDispatch);
end;
if Dispatch <> nil then
begin
Dispatch.QueryInterface(IID_IAccessible, AccChild);
if AccChild <> nil then
begin
VariantInit(varChild);
TVarData(varChild).VType := VT_I4;
TVarData(varChild).VInteger := CHILDID_SELF;
end;
end;
nState := 0;
hChild := 0;
if AccChild <> nil then
begin
// nRole := 0;
// GetObjectRole(AccChild, varChild, nRole);
GetObjectState(AccChild, varChild, nState);
if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then
continue;
WindowFromAccessibleObject(AccChild, hChild);
// {$IFDEF DEBUG}
// if gnLevel = 5 then
// gnLevel := gnLevel + 0;
// {$ENDIF}
ProcEnumAccessible(aAccParent, AccChild, varChild, hChild, gnLevel, bContinue);
if bContinue then
bContinue := FindChildAccessible(AccChild, ProcEnumAccessible, false, bIncludeInvisible);
end else begin
GetObjectState(aAccParent, varChild, nState);
if not bIncludeInvisible and ((nState and STATE_SYSTEM_INVISIBLE) <> 0) then
continue;
WindowFromAccessibleObject(aAccParent, hChild);
ProcEnumAccessible(nil, aAccParent, varChild, hChild, gnLevel, bContinue);
end;
end;
VariantClear(varChild);
Dec(gnLevel);
Result := bContinue;
except
on E: Exception do
ETgException.TraceException(E, 'Fail .. FindChildAccessible()');
end;
end;
(*
// 나중에 필요하면 포팅해서 쓰자 14_1112 14:40:03 kku
//=============================================================================
BOOL CXMSAALib::GetObjectDescription(IAccessible *pAcc,
VARIANT *pvarChild,
LPTSTR lpszDescription,
UINT cchDescription)
//=============================================================================
{
BOOL bRet = FALSE;
_ASSERTE(pAcc);
_ASSERTE(pvarChild);
_ASSERTE(lpszDescription);
if (pAcc && pvarChild && lpszDescription)
{
lpszDescription[0] = 0;
BSTR bstrDescription = NULL;
HRESULT hr = pAcc->get_accDescription(*pvarChild, &bstrDescription);
if (SUCCEEDED(hr) && bstrDescription)
{
_bstr_t btemp(bstrDescription, false);
if ((LPCTSTR)btemp)
_tcsncpy(lpszDescription, btemp, cchDescription);
bRet = TRUE;
}
}
return bRet;
}
//=============================================================================
BOOL CXMSAALib::GetObjectLocation(IAccessible *pAcc,
VARIANT *pvarChild,
RECT& rect)
//=============================================================================
{
BOOL bRet = FALSE;
_ASSERTE(pAcc);
_ASSERTE(pvarChild);
if (pAcc && pvarChild)
{
HRESULT hr = pAcc->accLocation(&rect.left, &rect.top,
&rect.right, &rect.bottom, *pvarChild);
if (SUCCEEDED(hr))
{
// accLocation returns width and height
rect.right += rect.left;
rect.bottom += rect.top;
bRet = TRUE;
}
}
return bRet;
}
BOOL CXMSAALib::GetObjectChildCount(IAccessible *pAcc,
long& nCount)
//=============================================================================
{
BOOL bRet = FALSE;
_ASSERTE(pAcc);
if (pAcc)
{
HRESULT hr = pAcc->get_accChildCount(&nCount);
if (SUCCEEDED(hr))
{
bRet = TRUE;
}
}
return bRet;
}
BOOL CXMSAALib::GetObjectStateString(IAccessible *pAcc,
VARIANT *pvarChild,
LPTSTR lpszBuf,
UINT cchBuf)
//=============================================================================
{
BOOL bRet = FALSE;
_ASSERTE(pAcc);
_ASSERTE(pvarChild);
_ASSERTE(lpszBuf);
if (pAcc && pvarChild && lpszBuf)
{
lpszBuf[0] = 0;
UINT nState = 0;
if (GetObjectState(pAcc, pvarChild, nState))
{
if ((nState & STATE_SYSTEM_INVISIBLE) == 0)
{
if (cchBuf > _tcslen(_T("visible")))
_tcscpy(lpszBuf, _T("visible"));
}
TCHAR szState[200];
szState[0] = 0;
UINT nChars = 0;
// convert state flags to comma separated list
for (DWORD dwStateBit = STATE_SYSTEM_UNAVAILABLE;
(dwStateBit < STATE_SYSTEM_HASPOPUP) && (nChars < cchBuf);
dwStateBit <<= 1)
{
if (nState & dwStateBit)
{
szState[0] = 0;
nChars += GetStateText(dwStateBit, szState, sizeof(szState)/sizeof(TCHAR)-1);
if ((nChars < (cchBuf-3)) && (szState[0] != 0))
{
if (lpszBuf[0] != 0)
_tcscat(lpszBuf, _T(","));
_tcscat(lpszBuf, szState);
nChars = (UINT)_tcslen(lpszBuf);
}
}
}
bRet = TRUE;
}
}
return bRet;
}
typedef void (CALLBACK *XWINEVENTURLPROC)(IAccessible *pAccChild,
VARIANT *pvarChild,
DWORD event,
HWND hwnd);
typedef BOOL (CALLBACK *XENUMACCESSIBLEPROC)(IAccessible *pAccChild,
VARIANT *pvarChild,
HWND hwndChild,
int nLevel,
LPARAM lParam);
static XWINEVENTURLPROC g_lpfnXWinEventUrlProc = 0;
//=============================================================================
static void CALLBACK CXMSAALib_WinEventProc(HWINEVENTHOOK /*hook*/,
DWORD event,
HWND hwnd,
LONG idObject,
LONG idChild,
DWORD /*dwEventThread*/,
DWORD /*dwmsEventTime*/)
//=============================================================================
{
switch (event)
{
case EVENT_OBJECT_FOCUS:
{
TRACE(_T("event=0x%X\n"), event);
IAccessible *pIAcc = 0;
VARIANT varChild;
VariantInit(&varChild);
HRESULT hr = AccessibleObjectFromEvent(hwnd, idObject, idChild,
&pIAcc, &varChild);
if ((hr == S_OK) && (pIAcc != NULL))
{
if (IsWindow(hwnd))
{
TRACE(_T("hwnd=0x%X\n"), hwnd);
TCHAR szClassname[256];
::GetClassName(hwnd, szClassname, sizeof(szClassname)/sizeof(TCHAR)-1);
szClassname[sizeof(szClassname)/sizeof(TCHAR)-1] = 0;
TRACE(_T("class %s\n"), szClassname);
}
if (g_lpfnXWinEventUrlProc)
{
g_lpfnXWinEventUrlProc(pIAcc, &varChild, event, hwnd);
TRACE(_T("after event proc\n"));
}
SAFE_RELEASE(pIAcc);
}
break;
}
default:
break;
}
}
//=============================================================================
BOOL CXMSAALib::StartGetObjectFromEvent(XWINEVENTURLPROC lpfnXWinEventUrlProc)
//=============================================================================
{
TRACE(_T("in CXMSAALib::StartGetObjectFromEvent\n"));
g_lpfnXWinEventUrlProc = 0;
if (lpfnXWinEventUrlProc)
{
g_lpfnXWinEventUrlProc = lpfnXWinEventUrlProc;
}
_ASSERTE(g_lpfnXWinEventUrlProc);
if (g_lpfnXWinEventUrlProc == 0)
{
StopGetObjectFromEvent();
}
else if (g_lpfnXWinEventUrlProc)
{
if (!m_eHook)
{
m_eHook = ::SetWinEventHook(EVENT_OBJECT_FOCUS, EVENT_OBJECT_VALUECHANGE, 0,
CXMSAALib_WinEventProc, 0, 0, WINEVENT_OUTOFCONTEXT | WINEVENT_SKIPOWNPROCESS);
}
}
TRACE(_T("exiting CXMSAALib::StartGetObjectFromEvent\n"));
return m_eHook != 0;
}
//=============================================================================
void CXMSAALib::StopGetObjectFromEvent()
//=============================================================================
{
if (m_eHook)
::UnhookWinEvent(m_eHook);
m_eHook = 0;
g_lpfnXWinEventUrlProc = 0;
}
*)
end.