vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
NEU! sevCoolbar 3.0 - Professionelle Toolbars im modernen Design!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik:    |   VB-Versionen: VB4, VB5, VB601.05.04
Wort unter dem Mauszeiger ermitteln (TextBox)

Heute verraten wir Ihnen, wie sich in der TextBox das Wort ermitteln lässt, auf dem sich der Mauszeiger aktuell befindet.

Autor:  LonelySuicide666Bewertung:     [ Jetzt bewerten ]Views:  1.763 
http://www.vbapihelpline.de/System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt 

Heute verraten wir Ihnen, wie sich in der TextBox das Wort ermitteln lässt, auf dem sich der Mauszeiger aktuell befindet. So könnte man bspw. immer das aktuelle Wort als ToolTip anzeigen, oder bspw. auch prüfen, ob es sich bei dem Wort um eine URL oder EMail-Adresse handelt und den Mauszeiger entsprechend als Hansymbol anzuzeigen.

Erstellen Sie ein neues Projekt und platzieren auf die Form eine TextBox mit der Eigenschaft "MultiLine = True". Ferner brauchen wir noch ein Label-Control (lblWord) für die Anzeige des aktuellen Wortes, auf das sich der Mauszeiger aktuell befindet.

Fügen Sie nachfolgenden Code in den Codeteil der Form ein:

Option Explicit
 
' zunächst die benötigten API-Deklarationen
Private Declare Function GetCursorPos Lib "user32" ( _
  lpPoint As POINTAPI) As Long
 
Private Declare Function WindowFromPoint Lib "user32" ( _
  ByVal xPoint As Long, _
  ByVal yPoint As Long) As Long
 
Private Declare Function ScreenToClient Lib "user32" ( _
  ByVal hWnd As Long, _
  lpPoint As POINTAPI) As Long
 
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 Declare Function GetDC Lib "user32" ( _
  ByVal hWnd As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hObject As Long) As Long
 
Private Declare Function DrawText Lib "user32" _
  Alias "DrawTextA" ( _
  ByVal hdc As Long, _
  ByVal lpStr As String, _
  ByVal nCount As Long, _
  lpRect As RECT, _
  ByVal wFormat As Long) As Long
 
Private Declare Function PtInRect Lib "user32" ( _
  lpRect As RECT, _
  ByVal X As Long, _
  ByVal Y As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" ( _
  ByVal hWnd As Long, _
  ByVal hdc As Long) As Long
 
Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Const WM_GETFONT As Long = &H31
 
Private Const EM_CHARFROMPOS As Long = &HD7
Private Const EM_GETRECT As Long = &HB2
Private Const EM_LINELENGTH As Long = &HC1
Private Const EM_LINEFROMCHAR As Long = &HC9
Private Const EM_GETLINE As Long = &HC4
 
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_WORDBREAK = &H10
' Wort unter dem Mauszeiger ermitteln (TextBox)
Public Function WordFromMousePos(ByVal oControl As Control) As String
   Dim xPos As Integer
   Dim yPos As Integer
   Dim CharPos As Long
   Dim LinePos As Long
   Dim TmpStr As String
   Dim Retval As Long
   Dim TextDC As Long
   Dim R As RECT
   Dim P As POINTAPI
   Dim hFont As Long
 
   With oControl
    ' aktuelle Mausposition
    On Error Resume Next
    GetCursorPos P
    If WindowFromPoint(P.X, P.Y) = .hWnd Then
      ' Pixelkoordinaten ermitteln
      ScreenToClient .hWnd, P
      xPos = P.X
      yPos = P.Y
 
      ' Ermitteln der Positionen für Zeichen und Zeile
      Retval = SendMessage(.hWnd, EM_CHARFROMPOS, 0&, ByVal Dword(yPos, xPos))
      CharPos = Retval And &HFFFF&
 
      ' Textbox vorbereiten
      TextDC = GetDC(.hWnd)
      hFont = SendMessage(.hWnd, WM_GETFONT, 0, ByVal 0&)
      hFont = SelectObject(TextDC, hFont)
 
      ' Befindet sich die Maus innerhalb des Textbereichs?
      SendMessage .hWnd, EM_GETRECT, 0, R
      DrawText TextDC, .Text, Len(.Text), R, DT_CALCRECT Or DT_EDITCONTROL Or DT_WORDBREAK
      If PtInRect(R, xPos, yPos) = 0 Then
        Exit Function
      End If
 
      ' Befindet sich die Maus neben (rechts) vom Textbereich?
      TmpStr = Space$(SendMessage(.hWnd, EM_LINELENGTH, CharPos, ByVal 0&))
      LinePos = SendMessage(.hWnd, EM_LINEFROMCHAR, CharPos, ByVal 0&)
      SendMessage .hWnd, EM_GETLINE, LinePos, ByVal TmpStr
      DrawText TextDC, TmpStr, Len(TmpStr), R, DT_CALCRECT Or DT_EDITCONTROL Or DT_WORDBREAK
 
      ' Textbox wiederherstellen
      SelectObject TextDC, hFont
      ReleaseDC .hWnd, TextDC
 
      If xPos > R.Right Then
        Exit Function
      End If
 
      ' Wort anhand der Positionen extrahieren
      If CharPos = 0 Then CharPos = CharPos + 1
      TmpStr = Replace(.Text, vbCrLf, " ")
      TmpStr = Left$(TmpStr & " ", InStr(CharPos, TmpStr & " ", " ") - 1)
      TmpStr = Mid$(TmpStr, InStrRev(TmpStr, " ") + 1)
 
      ' Wort zurückgeben
      WordFromMousePos = TmpStr
    End If
  End With
End Function

Den Aufruf der WordFromMousePos-Funktion setzen wir in das "MouseMove"-Ereignis der TextBox:

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  ' Wort unter dem Mauszeiger ermitteln
  lblWord.Caption = WordFromMousePos(Text1)
End Sub