VBA Tipp: Laufweite einer Schrift ermitteln

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

Ich möchte die Laufweite (Breite) eines Textes ohne GDI (Graphics Device Interface) in der Schriftart Arial ermitteln, um z.B. die Breite eines Text-Steuerelements an die Textgröße anzupassen.

Lösung

Das geht mit der folgenden Funktion, die in einem globalen Modul hinterlegt wird.

Public Function LaufweiteArial(Text As String, Schriftgröße As Long) As Long
 
 'Quelle: http://www.dbwiki.net/
 
 Dim arr As Variant
 Dim i As Long
 Dim LW As Double
 
 arr = Array( _
 0.5838, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 1.1676, 18.6809, 18.6809, 18.6809, 18.6809, 18.6809, 0.3221, _
 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.3221, 0.1394, 0.0929, _
 0.1044, 0.1394, 0.1698, 0.2076, 0.2076, 0.3459, 0.3221, 0.0929, 0.1394, 0.1394, 0.2076, 0.2365, 0.1044, 0.1394, 0.1044, 0.116, _
 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.116, 0.116, 0.2365, 0.2365, 0.2365, 0.185, _
 0.3812, 0.3013, 0.2788, 0.2788, 0.3013, 0.2559, 0.2306, 0.3013, 0.3013, 0.1394, 0.1624, 0.3013, 0.2559, 0.3663, 0.3013, 0.3013, _
 0.2306, 0.3013, 0.2788, 0.2306, 0.2559, 0.3013, 0.3013, 0.3892, 0.3013, 0.3013, 0.2559, 0.1394, 0.116, 0.1394, 0.1966, 0.2076, _
 0.1394, 0.185, 0.2076, 0.185, 0.2076, 0.185, 0.1394, 0.2076, 0.2076, 0.116, 0.116, 0.2076, 0.116, 0.3221, 0.2076, 0.2076, _
 0.2076, 0.2076, 0.1394, 0.1624, 0.116, 0.2076, 0.2076, 0.3013, 0.2076, 0.2076, 0.185, 0.2009, 0.0929, 0.2009, 0.2251, 0.3221, _
 0.2076, 0.3221, 0.1394, 0.2076, 0.185, 0.4151, 0.2076, 0.2076, 0.1394, 0.4151, 0.2306, 0.1394, 0.3663, 0.3221, 0.2559, 0.3221, _
 0.3221, 0.1394, 0.1394, 0.185, 0.185, 0.1459, 0.2076, 0.4151, 0.1394, 0.4061, 0.1624, 0.1394, 0.3013, 0.3221, 0.185, 0.3013, _
 0.1044, 0.1394, 0.2076, 0.2076, 0.2076, 0.2076, 0.0929, 0.2076, 0.1394, 0.3166, 0.1153, 0.2076, 0.2365, 0.1394, 0.3166, 0.2076, _
 0.1668, 0.2278, 0.1254, 0.1254, 0.1394, 0.2395, 0.1887, 0.1044, 0.1394, 0.1254, 0.1297, 0.2076, 0.3113, 0.3113, 0.3113, 0.185, _
 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.3663, 0.2788, 0.2559, 0.2559, 0.2559, 0.2559, 0.1394, 0.1394, 0.1394, 0.1394, _
 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.2365, 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.3013, 0.2306, 0.2076, _
 0.185, 0.185, 0.185, 0.185, 0.185, 0.185, 0.2788, 0.185, 0.185, 0.185, 0.185, 0.185, 0.116, 0.116, 0.116, 0.116, _
 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2278, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076, 0.2076)
 
 For i = 1 To Len(Text)
   LW = LW + arr(Asc(Mid(Text, i, 1)))
 Next i
 
 'Laufweite in Twips
 LaufweiteArial = CLng((LW * Schriftgröße) / 10 * 567)
 
End Function

Aufruf

 Dim lngSchriftgröße As Long
 Dim strMeldung As String
 Dim lngErgebnis As Long
 
 lngSchriftgröße = 14
 strMeldung = "Mein Text"
 
 lngErgebnis = LaufweiteArial(strMeldung, lngSchriftgröße)
 
 MsgBox "Textbreite: " & lngErgebnis & " Twips"

Wiki-Links