vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
TOP-Angebot: 17 bzw. 24 Entwickler-Vollversionen zum unschlagbaren Preis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Controls · TextBox & RichTextBox   |   VB-Versionen: VB604.12.09
Automatischer ToolTip für die TextBox

Kann der Text in einer TextBox nicht vollständig angezeigt werden, weil die TextBox in der Breite zu klein ist, wird dieser automatisch als ToolTip angezeigt.

Autor:   Dieter OtterBewertung:     [ Jetzt bewerten ]Views:  17.832 
www.tools4vb.deSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Heute stellen wir Ihnen eine Funktion vor, die es ermöglicht, überlange Texte in einer TextBox als ToolTip anzuzeigen. Der Tipp funktioniert hierbei sowohl für eine normale einzeilige TextBox, als auch für eine MultiLine-TextBox. Bei einer MultiLine-TextBox macht das Ganze aber nur Sinn, wenn kein vertikaler Scrollbalken eingeblendet wird, sondern nur der horizontale Scrollbalken.

Fügen Sie nachfolgenden Code in ein Modul ein:

Option Explicit
 
' benötigte API-Deklarationen
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 Declare Function GetCursorPos Lib "user32" ( _
  ByRef 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, _
  ByRef lpPoint As POINTAPI) As Long
 
Private Declare Function GetClientRect Lib "user32" ( _
  ByVal hWnd As Long, _
  ByRef lpRect As RECT) As Long
 
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" ( _
  ByVal hWnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  ByRef 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 SetRect Lib "user32" ( _
  lpRect As RECT, _
  ByVal X1 As Long, _
  ByVal Y1 As Long, _
  ByVal X2 As Long, _
  ByVal Y2 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 ReleaseDC Lib "user32" ( _
  ByVal hWnd As Long, _
  ByVal hdc As Long) As Long
 
Private Const WM_GETFONT As Long = &H31
 
Private Const DT_CALCRECT = &H400
Private Const DT_SINGLELINE = &H20
 
Private Const EM_CHARFROMPOS = &HD7
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINELENGTH = &HC1
' autom. ToolTip-Anzeige überlanger Textzeilen 
Public Sub TextBox_SetAutoToolTip(ByRef oTextBox As TextBox)
  Dim p As POINTAPI
  Dim hWnd As Long
  Dim nLine As Long
  Dim nStart As Long
  Dim nLen As Long
  Dim sLine As String
  Dim r As RECT
  Dim nDC As Long
  Dim hFont As Long
  Dim nWidth As Long
 
  ' Prüfen, ob sich der Mauszeiger auf der TextBox befindet
  hWnd = oTextBox.hWnd
  GetCursorPos p
  If WindowFromPoint(p.X, p.Y) = hWnd Then
    ' aktuelle Zeile ermitteln
    ScreenToClient hWnd, p
    nLine = SendMessage(hWnd, EM_CHARFROMPOS, 0&, ByVal Dword(CInt(p.Y), CInt(p.X)))
    nLine = CLng(nLine \ &H10000)
 
    ' Zeileninhalt ermitteln
    nStart = SendMessage(hWnd, EM_LINEINDEX, nLine, ByVal 0&)
    nLen = SendMessage(hWnd, EM_LINELENGTH, nStart, ByVal 0&)
    sLine = Mid$(oTextBox.Text, nStart + 1, nLen)
 
    ' Größe der TextBox
    GetClientRect hWnd, r
    nWidth = r.Right - r.Left
 
    ' Größe der Texzeile ermitteln
    nDC = GetDC(hWnd)
    hFont = SendMessage(hWnd, WM_GETFONT, 0, ByVal 0&)
    hFont = SelectObject(nDC, hFont)
    SetRect r, 0, 0, 0, 0
    DrawText nDC, sLine, -1, r, DT_CALCRECT Or DT_SINGLELINE
 
    If r.Right < nWidth Then
      ' kein ToolTip anzeigen
      sLine = ""
    End If
 
    ' Ressourcen wieder freigeben
    SelectObject nDC, hFont
    ReleaseDC hWnd, nDC
 
    ' ToolTip aktualisieren
    With oTextBox
      If .ToolTipText <> sLine Then
        .ToolTipText = sLine
      End If
    End With
  End If
End Sub
' Hilfsfunktion
Private Function Dword(ByVal Low As Integer, ByVal High As Integer) As Long
  Dim TmpLW As String, TmpHW As String
 
  TmpLW = String(4 - Len(Hex(Low)), "0") & Hex(Low)
  TmpHW = String(4 - Len(Hex(High)), "0") & Hex(High)
  Dword = CLng("&H" & TmpLW & TmpHW)
End Function

Aufrufbeispiel:
Platzieren Sie auf die Form zwei TextBox-Controls:

  • TextBox "Text1"
  • TextBox "Text2" mit MultiLine=True und ScrollBars=1-Horizontal

Im Form_Load Ereignis füllen wir die TextBox-Controls:

Private Sub Form_Load()
  Text1.Width = 2850
  Text1.Text = "Dies ist eine überlange Eingabe, die innerhalb " & _
    "der TextBox nicht vollständig angezeigt wird."
 
  Text2.Width = 2850
  Text2.Height = 1000
  Text2.Text = "Zeile1" & vbCrLf & _
    "Dies ist eine überlange Eingabe, die innerhalb der " & _
    "TextBox nicht vollständig angezeigt wird." & vbCrLf & _
    "Zeile 3"
End Sub

So... und wenn der User dann den Mauszeiger auf die TextBox bewegt, soll der überlange Text als ToolTip angezeigt werden:

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, _
  X As Single, Y As Single)
 
  ' Text ggf. als ToolTip anzeigen
  TextBox_SetAutoToolTip Text1
End Sub
Private Sub Text2_MouseMove(Button As Integer, Shift As Integer, _
  X As Single, Y As Single)
 
  ' Textzeile unter dem Mauszeiger ggf. als ToolTip anzeigen
  TextBox_SetAutoToolTip Text2
End Sub