{*******************************************************}
{                                                       }
{       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.