Rubrik: Controls · TextBox & RichTextBox | VB-Versionen: VB4, VB5, VB6 | 14.01.08 |
Textlänge prüfen und mit Punkten modifizieren Ersetzt Zeichen die nicht in eine TextBox (MultiLine = False) passen, durch 3 Punkte | ||
Autor: VBMichi | Bewertung: | Views: 12.506 |
www.michael-kaupp.com | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Benötigte Controls:
Die 3 Punkte am Ende der Textanzeige werden erst gesetzt, wenn der Text länger als "MAX_Length" (Länge des Textes, der in die angegebene TextBox passt) ist.
Damit der ursprüngliche Text nicht verloren geht, wird dieser dann als ToolTipText angezeigt.
Option Explicit ' benötigte API-Deklaration 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 Const DT_CALCRECT = &H400 Private Const DT_SINGLELINE = &H20 Private MAX_Length As Integer Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Private Sub Form_Load() ' Vorgabe Text1.Width = 2745 Text1.Text = "Das ist ein etwas längerere Text, " & vbCrLf & _ "der nicht komplett sichtbar angezeigt wird!" ' max. darstellbare Breite berechnen ' 7 abziehen (Rand der TextBox) MAX_Length = (Text1.Width / Screen.TwipsPerPixelX) - 7 End Sub
Private Sub Command1_Click() ' Textinhalt prüfen und Anzeige ggf. modifizieren Call SetPoints(Text1) End Sub
' Textinhalt prüfen und ggf. mit "..." abschneiden Private Sub SetPoints(myTextBox As TextBox) ' Falls die maximale Länge kürzer ist als die Länge der 3 Punkte If MAX_Length <= 9 Then Exit Sub ' dann Funktion abbrechen ' VORSICHT! KANN SICH JE NACH SCHRIFTART ÄNDERN! End If Dim hDcT As Long Dim R As RECT Dim nFlag As Long With myTextBox hDcT = .Parent.hdc nFlag = DT_SINGLELINE Or DT_CALCRECT Call DrawText(hDcT, CStr(.Text), -1, R, nFlag) ' Falls die Länge größer als die zugelassene Länge ist If R.Right > MAX_Length Then ' ToolTipText mit komplettem Text setzen .ToolTipText = .Text .Text = .Text & "..." While R.Right > MAX_Length ' Den letzten Buchstaben entfernen .Text = Left$(.Text, Len(.Text) - 4) & "..." ' Länge neu berechnen Call DrawText(hDcT, CStr(.Text), -1, R, nFlag) Wend End If End With End Sub