PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Capturing Text from under your mouse cursor

https://www.purebasic.fr/english/viewtopic.php?t=33954

Page 2 of 2

Re: Capturing Text from under your mouse cursor

Posted: Tue Feb 17, 2015 5:29 pm
by RASHAD
Change to

Code: Select all

Procedure TextFromWindowPosition(*Name.String, *Value.String) 
  Define p.POINT,vt.VARIANT,*pIAcc.IAccessible,pName.l,len.l
  GetCursorPos_(@p)
  If AccessibleObjectFromPoint(p\x,p\y,@*pIAcc,@vt)=#S_OK
    *Name\s=""
    If *pIAcc\get_accName(vt, @pName) = #S_OK
      len = SysStringLen_(pName)
      *Name\s = Space(len)
      CompilerIf #PB_Compiler_Unicode  
          PokeS( @*Name\s,PeekS(pName))
      CompilerElse
          WideCharToMultiByte_(#CP_ACP, 0,pName, -1, @*Name\s, len, 0, 0) 
      CompilerEndIf
      SysFreeString_(pName)
    EndIf
    *Value\s=""
    If *pIAcc\get_accValue(vt, @pName) = #S_OK
      len = SysStringLen_(pName)
      *Value\s = Space(len)
      CompilerIf #PB_Compiler_Unicode  
          PokeS( @*Value\s,PeekS(pName))
      CompilerElse
          WideCharToMultiByte_(#CP_ACP, 0,pName, -1, @*Value\s, len, 0, 0) 
      CompilerEndIf  
      SysFreeString_(pName)
    EndIf
    *pIAcc\Release()
  EndIf
  ProcedureReturn #True
EndProcedure

Re: Capturing Text from under your mouse cursor

Posted: Wed Feb 18, 2015 1:43 am
by Dude
TYVM, Rashad! :D

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 12:41 pm
by BarryG
The following line doesn't work with 64-bit PureBasic:

Code: Select all

If AccessibleObjectFromPoint(CursorPos\x,CursorPos\y,@*pIAcc,@vt)=#S_OK
It gives an illegal memory error. Does anyone know how to fix it? I used the code from the first post. Thanks.

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 1:12 pm
by breeze4me
It seems to work well with PB 5.73/6.0 b5 x86/x64 on Windows 10.

Code: Select all

; CaptureText
; Author: fizban (ported from a VC++ code of Nibu Babu Thomas)
; Original source: http://nibuthomas.wordpress.com/2008/08/15/capturing-text-from-under-your-mouse-cursor/
; Date:  31. August 2008
; OS: Windows 

EnableExplicit

;-Gadgets
Enumeration
  #txtValue
  #txtName
  #edValue
  #edName
  #imgCursor  
  #frmOptions
  #txtDrag
  #chkCopy
  #chkHide
  #chkAlwaysTop
EndEnumeration

;-Images
Enumeration
  #picHand
  #picNo
EndEnumeration

;-Prototypes
Prototype.l ProtoAccessibleObjectFromPoint(pt.q, *ia,*var)
Global AccessibleObjectFromPoint.ProtoAccessibleObjectFromPoint
Define hdll

;Applications must initialize the COM library before they can call COM library functions 
CoInitialize_(0)
hdll=OpenLibrary(#PB_Any,"Oleacc.dll")
AccessibleObjectFromPoint=GetFunction(hdll,"AccessibleObjectFromPoint")

Procedure SetWindowTopMost(hWnd, TopMost)
  Define After
  If Topmost : After=#HWND_TOPMOST : Else : After=#HWND_NOTOPMOST :EndIf
  SetWindowPos_( hWnd, After, 0, 0, 0, 0, #SWP_NOMOVE | #SWP_NOSIZE )
EndProcedure

Procedure TextFromWindowPosition(*Name.String, *Value.String) 
  Define p.POINT,vt.VARIANT,*pIAcc.IAccessible,pName,len.l
  GetCursorPos_(@p)
  If AccessibleObjectFromPoint((p\y << 32) | (p\x & $FFFFFFFF), @*pIAcc, @vt)=#S_OK
    *Name\s=""
    If *pIAcc\get_accName(vt, @pName) = #S_OK
      len = SysStringLen_(pName)
      *Name\s = Space(len)
      CompilerIf #PB_Compiler_Unicode  
          PokeS( @*Name\s,PeekS(pName))
      CompilerElse
          WideCharToMultiByte_(#CP_ACP, 0,pName, -1, @*Name\s, len, 0, 0) 
      CompilerEndIf
      SysFreeString_(pName)
    EndIf
    *Value\s=""
    If *pIAcc\get_accValue(vt, @pName) = #S_OK
      len = SysStringLen_(pName)
      *Value\s = Space(len)
      CompilerIf #PB_Compiler_Unicode  
          PokeS( @*Value\s,PeekS(pName))
      CompilerElse
          WideCharToMultiByte_(#CP_ACP, 0,pName, -1, @*Value\s, len, 0, 0) 
      CompilerEndIf  
      SysFreeString_(pName)
    EndIf
    *pIAcc\Release()
  EndIf
  ProcedureReturn #True
EndProcedure 

;-Main
Define dragging.b,ev,hdc,PositionBeforeMove.Point
Define name.string,value.string,SystemPath.s
Define handcursor   = LoadCursor_(0,#IDC_HAND) 
Define normalcursor = LoadCursor_(0,#IDC_ARROW) 
Define nocursor = LoadCursor_(0,#IDC_NO) 


If OpenWindow(0, 0, 0, 540, 408, "Capture text", #PB_Window_SystemMenu | #PB_Window_ScreenCentered| #PB_Window_MinimizeGadget)
  
  TextGadget(#txtName,14,14,46,16,"Name:")
  EditorGadget(#edName, 14, 30, 516, 110) 
  TextGadget(#txtValue,14,148,44,16,"Value:")
  EditorGadget(#edValue, 14, 164, 516, 160)
  CreateImage(#picHand,40,40)
  ;Image Gadgets do not properly handle directly monochrome icons. So we use an image to draw the icon
  ;see http://www.purebasic.fr/english/viewtopic.php?t=33943
  hdc=StartDrawing(ImageOutput(#picHand))
    Box(0,0,40,40,GetSysColor_(#COLOR_3DFACE))
    ;DrawImage (handcursor,0,0)
    DrawIconEx_(hdc, 0,0, handcursor, 0,0,0,0,#DI_NORMAL)
  StopDrawing()
  CreateImage(#picNo,40,40)
  hdc=StartDrawing(ImageOutput(#picNo))
    Box(0,0,40,40,GetSysColor_(#COLOR_3DFACE))
    ;DrawImage (nocursor,0,0)
    DrawIconEx_(hdc, 0,0, nocursor, 0,0,0,0,#DI_NORMAL)
  StopDrawing()
  ImageGadget(#imgCursor,140,334,40,40,ImageID(#picHand))
  TextGadget(#txtDrag,54,346,80,40,"Drag me around:")
  FrameGadget(#frmOptions,38,324,460,76,"")
  CheckBoxGadget(#chkCopy,240,336,240,20,"&Copy to clipboard on mouse up")
  CheckBoxGadget(#chkHide,240,356,240,20,"Hide window on drag")
  CheckBoxGadget(#chkAlwaysTop,240,376,240,20,"Always on top")
  ;Set the icon for the window using one of the standard icons
  SystemPath=Space(255) 
  GetSystemDirectory_(SystemPath,255) 
  SendMessage_(WindowID(0),#WM_SETICON,#False,ExtractIcon_(0,SystemPath+"\shell32.dll",73))
;--Main loop
  Repeat 
  Ev = WaitWindowEvent() 
    Select Ev
      Case #PB_Event_Gadget 
        Select EventGadget() 
          Case #imgCursor
            If EventType()=#PB_EventType_LeftClick 
              SetCapture_(WindowID(0))
              SetCursor_(handcursor)
              SetGadgetState(#imgCursor,ImageID(#picNo))
              dragging=#True
              If GetGadgetState(#chkHide) 
                PositionBeforeMove\x=WindowX(0)
                PositionBeforeMove\y=WindowY(0)
                ExamineDesktops()
                ResizeWindow(0,DesktopWidth(0),DesktopHeight(0),#PB_Ignore ,#PB_Ignore )
              EndIf
            EndIf
          Case #chkAlwaysTop
            SetWindowTopMost(WindowID(0),GetGadgetState(#chkAlwaysTop))
        EndSelect
      Case #WM_MOUSEMOVE 
        If dragging=#True
          TextFromWindowPosition(@name,@value)
          SetGadgetText(#edName,name\s )
          SetGadgetText(#edValue,value\s)
        EndIf
      Case  #WM_LBUTTONUP 
        If dragging=#True
          ReleaseCapture_()
          SetCursor_(normalcursor)
          SetGadgetState(#imgCursor,ImageID(#picHand))
          dragging=#False
          If GetGadgetState(#chkCopy)
            SetClipboardText(name\s + #CRLF$ + value\s)
          EndIf
        EndIf
        If GetGadgetState(#chkHide) 
          ResizeWindow(0,PositionBeforeMove\x,PositionBeforeMove\y,#PB_Ignore ,#PB_Ignore )
        EndIf      
    EndSelect
  Until Ev = #PB_Event_CloseWindow 
EndIf
CoUninitialize_() 
CloseLibrary(hdll)

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 1:22 pm
by mk-soft
Peeks is enought ...

Code: Select all

;-Prototypes
Prototype.l ProtoAccessibleObjectFromPoint(ptScreen.q, *ppacc, *pvarChild)
Global AccessibleObjectFromPoint.ProtoAccessibleObjectFromPoint
Define hdll.l

;Applications must initialize the COM library before they can call COM library functions 
CoInitialize_(0)
hdll=OpenLibrary(#PB_Any,"Oleacc.dll")
AccessibleObjectFromPoint=GetFunction(hdll,"AccessibleObjectFromPoint")

Procedure SetWindowTopMost(hWnd.l,TopMost.l)
  Define After.l
  If Topmost : After=#HWND_TOPMOST : Else : After=#HWND_NOTOPMOST :EndIf
  SetWindowPos_( hWnd, After, 0, 0, 0, 0, #SWP_NOMOVE | #SWP_NOSIZE )
EndProcedure

Procedure TextFromWindowPosition(*Name.String, *Value.String)  
  Define CursorPos.point,vt.VARIANT,*pIAcc.IAccessible,pName.l,len.l
  GetCursorPos_(@CursorPos) 
  
  If AccessibleObjectFromPoint(CursorPos\y << 32 | CursorPos\x,@*pIAcc,@vt)=#S_OK
    *Name\s=""
    If *pIAcc\get_accName(vt, @pName) = #S_OK 
      *Name\s = PeekS(pName, -1, #PB_Unicode)
      SysFreeString_(pName)
    EndIf
    *Value\s=""
    If *pIAcc\get_accValue(vt, @pName) = #S_OK 
      *Value\s = PeekS(pName, -1, #PB_Unicode) 
      SysFreeString_(pName)
    EndIf
    *pIAcc\Release() 
  EndIf
  ProcedureReturn #True
EndProcedure

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 1:27 pm
by RASHAD
Removed

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 2:22 pm
by infratec
Since the german special letters were shown with a placeholder, I played a bit.
This works for me:

Code: Select all

Procedure TextFromWindowPosition(*Name.String, *Value.String) 
  Define p.POINT,vt.VARIANT,*pIAcc.IAccessible,*pName
  GetCursorPos_(@p)
  If AccessibleObjectFromPoint(p\y<<32|p\x,@*pIAcc,@vt)=#S_OK
    *Name\s=""
    If *pIAcc\get_accName(vt, @*pName) = #S_OK
      *Name\s = PeekS(*pName)
      SysFreeString_(*pName)
    EndIf
    *Value\s=""
    *pIAcc\Release()
  EndIf
  ProcedureReturn #True
EndProcedure
Since the len is stored before the pointervalue, and the BSTR is terminated with $0000 PeekS() works.

For testing: öüäÖÜÄß

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 6:16 pm
by AZJIO

Code: Select all

p\y<<32|p\x
PeekQ(@p)

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 10:08 pm
by BarryG
Thanks, everyone! It's working under 64-bit now.

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 11:31 pm
by AZJIO
It would be nice if the icon was in the tray and clicking on it would activate the text capture.
It would be nice if the element over which the cursor is highlighted with a red rectangle.
In this case, the result could be displayed in ToolTip. ToolTip should move to the opposite side of the screen from the cursor.

Re: Capturing Text from under your mouse cursor

Posted: Mon Mar 07, 2022 11:45 pm
by infratec
AZJIO wrote: Mon Mar 07, 2022 11:31 pm It would be nice if the icon was in the tray and clicking on it would activate the text capture.
It would be nice if the element over which the cursor is highlighted with a red rectangle.
In this case, the result could be displayed in ToolTip. ToolTip should move to the opposite side of the screen from the cursor.
You have the code ... simply do what you want.
Since you are here since nearly 5 years, it should not be a problem.

Re: Capturing Text from under your mouse cursor

Posted: Tue Mar 08, 2022 12:08 am
by AZJIO
infratec
I have code in another programming language. I wrote it wrong, using crutches. On WindowsXP it worked fine, but when I switched to Win7-10, I had to get used to double-clicking the mouse to grab the window with the cursor near the tray and drag it. I'd like to click once and not hold down the mouse so it switches to search mode and a second click grabs the element under the cursor.

Code: Select all

TextFromWindowPosition(@name,@value)
RedRect()
When moving the mouse cursor, also call drawing a rectangle. This is taken from my program and converted to PureBasic

Code: Select all

Procedure RedRect()
	Protected iPenWidth = 2
	Protected rgn, rgn2, hWin_1
	Protected Rect.RECT
	Protected gcp.POINT
	Protected hWndCur, w, h
	Static hWinOld 
	
	GetCursorPos_(@gcp.POINT)
	hWndCur = WindowFromPoint_(PeekQ(@gcp))
	If hWinOld = hWndCur
		ProcedureReturn
	EndIf
	hWinOld = hWndCur
	If GetWindowRect_(hWndCur, @Rect)
		If IsWindow(1)
			CloseWindow(1)
		EndIf
		w = Rect\right - Rect\left
		h = Rect\bottom - Rect\top
		hWin_1 = OpenWindow(1, Rect\left, Rect\top, w, h, "", #WS_POPUP, WindowID(0))
		SetWindowColor(1, RGB(255, 0 , 0)) 
		rgn = CreateRoundRectRgn_(0, 0, w, h, 0, 0)
		rgn2 = CreateRoundRectRgn_(iPenWidth, iPenWidth, w - iPenWidth, h - iPenWidth, 0, 0)
		CombineRgn_(rgn, rgn, rgn2, #RGN_DIFF)
		DeleteObject_(rgn2)
		SetWindowRgn_(hWin_1, rgn, #True)
		StickyWindow(1, #True) 
		HideWindow(1, #False, #PB_Window_NoActivate) 
		DisableWindow(1, 1)
	EndIf
EndProcedure
Holding the tray icon tries to move the tray icon
(translation2) Clicking on the systray icon and dragging moves the systray icon
working version - Clicking on the tray icon shows a window next to the icon, sized 32x32. In this window, drag the cursor.

Code: Select all

EnableExplicit

; XIncludeFile "ToolTip.pb"

#Window = 0
#SysTrayIcon = 0
#Menu = 0
Define hWin_0
Define dragging
Define name.string,value.string
Define handcursor   = LoadCursor_(0,#IDC_CROSS)
Define normalcursor = LoadCursor_(0,#IDC_ARROW)
Define nocursor = LoadCursor_(0,#IDC_NO)

Prototype.l ProtoAccessibleObjectFromPoint(ptScreen.q, *ppacc, *pvarChild)
Global AccessibleObjectFromPoint.ProtoAccessibleObjectFromPoint
Define hdll.l

CoInitialize_(0)
hdll=OpenLibrary(#PB_Any,"Oleacc.dll")
If hdll
	AccessibleObjectFromPoint=GetFunction(hdll,"AccessibleObjectFromPoint")
Else
	MessageRequester("", "Failed to open Oleacc.dll")
	End
EndIf

Procedure TextFromWindowPosition(*Name.String, *Value.String) 
	Define p.POINT,vt.VARIANT,*pIAcc.IAccessible,*pName
	GetCursorPos_(@p)
; 	PeekQ(@p)
	If AccessibleObjectFromPoint(p\y<<32|p\x,@*pIAcc,@vt)=#S_OK
		*Name\s=""
		If *pIAcc\get_accName(vt, @*pName) = #S_OK
			*Name\s = PeekS(*pName)
			SysFreeString_(*pName)
		EndIf
		*Value\s=""
		If *pIAcc\get_accValue(vt, @*pName) = #S_OK 
			*Value\s = PeekS(*pName, -1, #PB_Unicode) 
			SysFreeString_(*pName)
		EndIf
		*pIAcc\Release()
	EndIf
	ProcedureReturn #True
EndProcedure

;-GUI
hWin_0 = OpenWindow(#Window, 100, 150, 300, 100, "CaptureText - SysTray", #PB_Window_SystemMenu | #PB_Window_Invisible)
If hWin_0
	AddSysTrayIcon(#SysTrayIcon, hWin_0, GetClassLongPtr_(hWin_0, #GCL_HICON))
	SysTrayIconToolTip(#SysTrayIcon, "CaptureText")
	
	
	If CreatePopupImageMenu(#Menu)
		MenuItem(0, "Exit")
	EndIf
	
	;-
	Repeat
		Select WaitWindowEvent()
			Case #WM_MOUSEMOVE
				If dragging=#True
					TextFromWindowPosition(@name,@value)
; 					ToolTip(name\s + #CRLF$+ value\s, 0, 500)
				EndIf
			Case  #WM_LBUTTONUP
				If dragging=#True
					ReleaseCapture_()
					SetCursor_(normalcursor)
					dragging=#False
					SetClipboardText(name\s + #CRLF$ + value\s)
				EndIf
			Case #PB_Event_SysTray
				Select EventType()
					Case #PB_EventType_LeftClick
							SetCapture_(hWin_0)
							SetCursor_(handcursor)
							dragging=#True
						
					Case #PB_EventType_RightClick
						DisplayPopupMenu(#Menu, hWin_0)
				EndSelect
			Case #PB_Event_Menu
				Select EventMenu()
					Case 0
						RemoveSysTrayIcon(#SysTrayIcon)
						FreeMenu(#Menu)
						CloseWindow(#Window)
						End
				EndSelect
		EndSelect
	ForEver
EndIf
All times are UTC+01:00
Page 2 of 2

Powered by phpBB® Forum Software © phpBB Limited