如何实现像金山词霸那样屏幕取词?

Question

如何实现像金山词霸那样屏幕取词?

Answer 1

鼠标取词
    
    在有些软件里当鼠标移到某单词上,其注释就会显示单词的中文解释.这样的软件是如何制作的呢?下面我就介绍以下获取鼠标所在单词的方法,至于中文结实要关系到数据库及字库问题在此我不做解释.
    首先建立新工程,在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  另外：请参考http://www.21code.com/codebase/?pos=down&id=1094

Answer 2

屏幕取词的基本原理
1。获得当前鼠标的位置
2。通过程序截获Textout,exttextout等windows api函数
3。在鼠标当前位置上生成一个机小的窗口，占一个像素，window将发出wm_paint消息给该窗口，通知窗口重画该区域的屏幕。系统在进行重画的过程中，文字部分是通过调用api Textout,exttextout等来完成。
截获这些api函数的技术称为apihook.

Answer 3

!!!up
http://bookhouse.xiloo.com/

Answer 4

Option ExplicitPrivate Const EM_CHARFROMPOS& = &HD7
Private Type POINTAPI
    X As Long
    Y As Long
End TypePrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long' Return the word the mouse is over.
Public Function RichWordOver(rch As RichTextBox, X As Single, Y As Single) As String
Dim pt As POINTAPI
Dim pos As Integer
Dim start_pos As Integer
Dim end_pos As Integer
Dim ch As String
Dim txt As String
Dim txtlen As Integer    ' Convert the position to pixels.
    pt.X = X \ Screen.TwipsPerPixelX
    pt.Y = Y \ Screen.TwipsPerPixelY    ' Get the character number
    pos = SendMessage(rch.hWnd, EM_CHARFROMPOS, 0&, pt)
    If pos <= 0 Then Exit Function    ' Find the start of the word.
    txt = rch.Text
    For start_pos = pos To 1 Step -1
        ch = Mid$(rch.Text, start_pos, 1)
        ' Allow digits, letters, and underscores.
        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next start_pos
    start_pos = start_pos + 1    ' Find the end of the word.
    txtlen = Len(txt)
    For end_pos = pos To txtlen
        ch = Mid$(txt, end_pos, 1)
        ' Allow digits, letters, and underscores.
        If Not ( _
            (ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or _
            ch = "_" _
        ) Then Exit For
    Next end_pos
    end_pos = end_pos - 1    If start_pos <= end_pos Then _
        RichWordOver = Mid$(txt, start_pos, end_pos - start_pos + 1)
End FunctionPrivate Sub Form_Load()
    rchMainText.Text = "Ready-To-Run Visual Basic Algorithms, Second Edition" & _
        vbCrLf & vbCrLf & "Extend your applications with powerful algorithms written in Visual Basic. Sorting, searching, trees, hashing, advanced recursion, network algorithms, object-oriented programming, and much more. Visual Basic Algorithms updated and expanded for Visual Basic 5." & _
        vbCrLf & vbCrLf & "http://www.vb-helper.com/vba.htm"
End SubPrivate Sub rchMainText_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim txt As String    txt = RichWordOver(rchMainText, X, Y)
    If lblCurrentWord.Caption <> txt Then _
        lblCurrentWord.Caption = txt
End Sub

Answer 5

我也正在做类似的东东！多多交流！
[email protected]