如何截取屏幕上某块区域或某个控件上的文字？
比方像是QQ的好友列表，IE的菜单栏上的文字，或弹按下菜单后出来的文字。
[解决办法]
鼠标取词
在有些软件里当鼠标移到某单词上,其注释就会显示单词的中文解释.这样的软件是如何制作的呢?下面我就介绍以下获取鼠标所在单词的方法,至于中文结实要关系到数据库及字库问题在此我不做解释.
首先建立新工程,在FORM上添加一个TEXT文本框.
声明SendMessage函数.
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const EM_CHARFORMPOS=&HD7'在API浏览器里无此值请自己加上.
自定义过程:
Private Sub Text1_MouseDown(Button As Intege,Shift As Integer,x As Single, y As Single)
'获取鼠标所点的是第几行第几个字符
Dim pos As Long,Lc As Long
Dim Line As Integer,CharPos As Integer
x=x/Screen.TwipsPerPixelX
y=y/Screen.TwipsperPixelY
pos=x+y*65536
Lc=SendMessage(Text1.hwnd,EM_CHARFROMPOS,0,ByVal pos)
Line=Lc\65536 '第几行
CharPos=Lc MOD 65536 '第几个字符
End Sub
'接下来才是真正的读取函数
Function GetWord(txt As TextBox,pos As Integer) As String
Dim bArr()As Byte,pos1 As Integer,pos2 As Integer, i As Integer
bArr=StrConv(txt.Text,vbFromUnicode)'转换成Byte数组
pos1=0:pos2=UBound(bArr)
'向前搜索分格符的位置
For i=pos-1 To 0 Step -1
If IsDelimiter(bArr(i)) Then
pos1=i+1
Exit For
End If
Next
'向后搜寻分隔符字符的位置
For i=pos To UBound(bArr)
If IsDelimiter(bArr(i)) Then
pos2=i-1
Exit For
End If
Next
'截取pos1-pos2之间的字符,以构成一个单词
If pos2>pos1 Then
ReDim bArr2(pos2-pos1) As Byte
For i=pos1 To Pos2
bArr2(i-pos1)=bArr(i)
Next
GetWord=StrConv(bArr2,vbUnicode)
Else
GetWord=""
End If
End Function
'IsDelimiter函数
Functon IsDelimiter(ByVal Char As Byte) As Boolean
Dim S As String
S=Chr(Char)
IsDelimiter=False
If S=" " Or S="," Or S="." Or S="?" Or S="vbCr Or S=vbLf Then
IsDelimiter=True
End If
End Function
VERSION 5.00
Begin VB.Form Form1
BackColor = &H00000000&
BorderStyle = 4 'Fixed ToolWindow
Caption = "XdictGrb-屏幕取词保存到剪贴板和c:\XdictGrb.txt中"
ClientHeight = 210
ClientLeft = 45
ClientTop = 285
ClientWidth = 8310
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 210
ScaleWidth = 8310
ShowInTaskbar = 0 'False
Begin VB.Label Label2
BackColor = &H00000000&
ForeColor = &H0000FFFF&
Height = 255
Left = 30
TabIndex = 0
Top = 15
Width = 8280
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'将XdictGrb.dll放在system32下.运行regsvr32 XdictGrb.dll注册.
'新建工程,引用XdictGrb.dll.
'加三个Label到窗体.
Option Explicit
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = &H2 '不移动窗体
Private Const SWP_NOSIZE = &H1 '不改变窗体尺寸
Private Const Flag = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1 '窗体总在最前面
Private Const HWND_NOTOPMOST = -2 '窗体不在最前面
Implements IXDictGrabSink
Private gp As GrabProxy
Dim f As Integer
Dim ls As String
Private Sub Form_Load()
ls = ""
f = FreeFile()
Open "c:\XDictGrb.txt" For Append As #f
Set gp = New GrabProxy
With gp
.GrabEnabled = True '是否有效
.GrabInterval = 5 '指定抓取时间间隔
.GrabMode = XDictGrabMouse '模式(鼠标是否加按键)
.AdviseGrab Me '接口指向自身
End With
SetWindowPos Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, Flag
End Sub
Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Top = 600 - Form1.Top
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form1.Top = 600 - Form1.Top
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set gp = Nothing
Close #f
End Sub
Private Function IXDictGrabSink_QueryWord(ByVal WordString As String, ByVal lCursorX As Long, ByVal lCursorY As Long, ByVal SentenceString As String, lLoc As Long, lStart As Long) As Long
' Label1.Caption = "当前坐标：" & "(" & lCursorX & "," & lCursorY & ")"
Label2.Caption = SentenceString
' Label3.Caption = "当前字符：" & Mid(SentenceString, lLoc + 1, 1000)
If ls <> SentenceString Then
ls = SentenceString
Print #f, ls
Clipboard.Clear
Clipboard.SetText ls
End If
If 0 <= lCursorX And lCursorX <= 559 Then
If 0 <= lCursorY And lCursorY <= 39 Then
Form1.Top = 600
End If
If 40 <= lCursorY And lCursorY <= 79 Then
Form1.Top = 0
End If
End If
End Function
