如何实现屏幕取词？

Question

如何实现类似于《金山词霸》的屏幕取词功能。运行该程序，将鼠标指针移动到文本框内的某个单词上，则在窗体下方的标签中就会显示出该单词。

Answer 1

从你的要求来看，输入信息是鼠标的位置，而输出信息是鼠标所在位置的单词。直接从鼠标的位置得到该位置的单词是很困难的。    通过SendMessage函数向RichTextBox控件发送EM_CHARFROMPOS消息，可以将鼠标在RichTextBox控件中的位置信息转换为字符的位置信息。这样，以该字符为中心，向前向后检索该单词的其他字符即可。代码如下Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Const EM_CHARFROMPOS& = &HD7
Private Type POINTAPI
    X As Long
    Y As Long
End Type' 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
    '将鼠标位置的单位转换为像素
    pt.X = X / Screen.TwipsPerPixelX
    pt.Y = Y / Screen.TwipsPerPixelY
    '得到字符的位置
    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)
        '允许字符为数字、字母和下划线
        If Not ((ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or ch = "_") Then
            Exit For
        End If
    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)
        '允许字符为数字、字母和下划线
        If Not ((ch >= "0" And ch <= "9") Or _
            (ch >= "a" And ch <= "z") Or _
            (ch >= "A" And ch <= "Z") Or ch = "_") Then
            Exit For
        End If
    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 If
End FunctionPrivate Sub Form_Load()
    RichTextBox1.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 6." & _
        vbCrLf & vbCrLf & "http://www.vb-helper.com/vba.htm"
    Label1.Caption = ""
End SubPrivate Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim txt As String
    txt = RichWordOver(RichTextBox1, X, Y)
    If Label1.Caption <> txt Then
        Label1.Caption = txt
    End If
End Sub
欢迎光临电脑爱好者论坛 bbs.cfanclub.net

Answer 2

楼上的方法正确，使用SendMessage就可以得到。不过他的代码长些。Attribute VB_Name = "Module1"
Option ExplicitPublic Const EM_CHARFROMPOS = &HD7
Public Const EM_GETLINECOUNT = &HBA
Public Const EM_GETLINE = &HC4
Public Const EM_LINEINDEX = &HBB
Public Const EM_LINELENGTH = &HC1Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
------------------------------------------------------------------------
VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "读取鼠标所在位置的单词"
   ClientHeight    =   2352
   ClientLeft      =   60
   ClientTop       =   348
   ClientWidth     =   5160
   LinkTopic       =   "Form1"
   ScaleHeight     =   196
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   430
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text1 
      BeginProperty Font 
         Name            =   "MS Serif"
         Size            =   12
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1815
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Text            =   "GetWord.frx":0000
      Top             =   240
      Width           =   4695
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim pos As Long, lc As Long
    Dim Line As Integer, CharPos As Integer
    
    pos = X / Screen.TwipsPerPixelX + Y / Screen.TwipsPerPixelY * 65536
    lc = SendMessage(Text1.hwnd, EM_CHARFROMPOS, 0, ByVal pos)
    
    Line = lc \ 65536
    CharPos = lc Mod 65536
    
    MsgBox " = " & GetLine(Text1, Line) & vbCrLf & "单词= " & GetWord(Text1, CharPos)
End SubFunction 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)
    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
    
    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 FunctionFunction 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 FunctionFunction GetLine(txt As TextBox, ByVal Line As Integer) As String
    Dim S As String, Length As Integer, pos As Long
    
    GetLine = ""
    pos = SendMessage(txt.hwnd, EM_LINEINDEX, Line, ByVal 0&)
    Length = SendMessage(txt.hwnd, EM_LINELENGTH, pos, ByVal 0&)
    S = String(Length, Chr(0))
    RtlMoveMemory ByVal S, Length, 2
    If SendMessage(Text1.hwnd, EM_GETLINE, Line, ByVal S) > 0 Then
        GetLine = S
    End If
End FunctionPrivate Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim pos As Long, lc As Long
    Dim Line As Integer, CharPos As Integer
    
    pos = X / Screen.TwipsPerPixelX + Y / Screen.TwipsPerPixelY * 65536
    lc = SendMessage(Text1.hwnd, EM_CHARFROMPOS, 0, ByVal pos)
    
    Line = lc \ 65536
    CharPos = lc Mod 65536
    
    Text1.ToolTipText = GetWord(Text1, CharPos)
End Sub