Get the caret position of a Firefox window - vba

Question

The code below will correctly get the caret position on screen of a notepad window.  But when run for Firefox it returns all zeros?
I’m I do doing something wrong?   Or does Firefox just self-draw the caret onscreen outside of the Windows OS?  If the later, is there an alternative way to achieve this?
Thanks
    Option Explicit
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function GetGUIThreadInfo Lib "user32" (ByVal dwthreadid As Long, lpguithreadinfo As GUITHREADINFO) As Long
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    Private Type GUITHREADINFO
        cbSize As Long
        flags As Long
        hwndActive As Long
        hwndFocus As Long
        hwndCapture As Long
        hwndMenuOwner As Long
        hwndMoveSize As Long
        hwndCaret As Long
        rcCaret As RECT
    End Type
    Private Function GetCaretPosition() As GUITHREADINFO
        Dim pThreadId As Long
        Dim guiInfo As GUITHREADINFO
        pThreadId = GetWindowThreadProcessId(GetForegroundWindow(), &H0)
        guiInfo.cbSize = LenB(guiInfo)
        GetGUIThreadInfo pThreadId, guiInfo
        GetCaretPosition = guiInfo
    End Function
    Private Sub Test()
        Dim guiInfo As GUITHREADINFO
        'Works on notepad
        AppActivate "Notepad"
        Application.Wait DateAdd("s", 1, Now)
        guiInfo = GetCaretPosition()
        Debug.Print guiInfo.flags, guiInfo.hwndFocus, guiInfo.hwndCaret, guiInfo.rcCaret.Left, guiInfo.rcCaret.Top, guiInfo.rcCaret.Right, guiInfo.rcCaret.Bottom
        'Returns:  1             5119032       5119032       5             0             6             22
   
        'Doesn't work on Firefox
        AppActivate "Firefox"
        Application.Wait DateAdd("s", 1, Now)
        guiInfo = GetCaretPosition()
        Debug.Print guiInfo.flags, guiInfo.hwndFocus, guiInfo.hwndCaret, guiInfo.rcCaret.Left, guiInfo.rcCaret.Top, guiInfo.rcCaret.Right, guiInfo.rcCaret.Bottom
        'Returns:   0             5444838       0             0             0             0             0
End Sub

Answer 1

Here's my solution... WARNING it is using a intrusive method of SendKeys and clipboard access to test if the caret active is on the window. I have got it to tidy up as it goes, but still could have undesired affects depending on the context in which it's used.
It doesn't return the caret position; just a true/false indicator whether or not the window as can active caret.
It's usueful if trying to identify when an opened window has keyboard focus and is ready for further SendKeys; just setup to run the check in a loop until true or suitable timeout has passed
Option Explicit
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Sub test2()
AppActivate "Notepad"
Application.Wait DateAdd("s", 1, Now)
Debug.Print WindowHasKeyboardFocus(GetForegroundWindow())
'Returns True
AppActivate "Firefox"
Application.Wait DateAdd("s", 1, Now)
Debug.Print WindowHasKeyboardFocus(GetForegroundWindow())
'Returns True
End Sub
Private Function WindowHasKeyboardFocus(hwnd As Long) As Boolean
Dim WSH As Object
Dim UserClipboard As String
Set WSH = CreateObject("WScript.Shell")
'Copy of user's clipboard for later restore
UserClipboard = GetClipboard()
SetClipboard ""
'Send keys to prove it has keyboard focus
WindowHasKeyboardFocus = False
If SetForegroundWindow(hwnd) <> 0 Then
WSH.SendKeys "a+{LEFT}^x" 'Type "a", then select it and cut it to clipboard
Sleep 200
WindowHasKeyboardFocus = GetClipboard() = "a"
End If
'Restore User's clipboard
SetClipboard UserClipboard
Set WSH = Nothing
End Function
Private Sub Sleep(Milliseconds As Long)
Dim WaitTimer As Double
WaitTimer = Timer + Milliseconds / 1000
While Timer < WaitTimer
DoEvents
Wend
End Sub
Private Function GetClipboard() As String
Dim X As Long
Dim CB As Object
Set CB = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'Get data from Clipboard (sometimes fails so done on loop)
On Error Resume Next
For X = 1 To 100
CB.GetFromClipboard
GetClipboard = CB.GetText
Select Case Err.Number
Case 0: Exit For
Case -2147221040: Err.Clear 'Try Again (DataObject:GetText OpenClipboard Failed)
Case Else: Err.Raise Err.Number, Err.Source, Err.Description
End Select
Next
'Pass back any error that occured
If Err.Number > 0 Then
Err.Raise Err.Number, Err.Source, Err.Description
End If
Set CB = Nothing
End Function
Private Function SetClipboard(Value As String)
Dim X As Long
Dim Timeout As Single
Dim CB As Object
Set CB = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'Prone to errors
On Error Resume Next
'Put data into Clipboard (sometimes fails so done on loop)
CB.SetText Value
For X = 1 To 100
CB.PutInClipboard
Select Case Err.Number
Case 0: Exit For
Case -2147221040: Err.Clear 'Try Again (DataObject:PutInClipboard OpenClipboard Failed)
Case Else: Err.Raise Err.Number, Err.Source, Err.Description
End Select
Next
'Pass back any error that occured
If Err.Number > 0 Then
Err.Raise Err.Number, Err.Source, Err.Description
End If
Set CB = Nothing
End Function