Fonts mit gleicher Zeichenbreite auflisten

16/01/2010 - 12:18 von Peter Gast | Report spam
Hallo,
ich benötige eine Liste aller Schriftarten auf dem Rechner, bei denen die
Zeichen immer gleich breit sind, zB das "i" also so breit ist wie das "o".
Wenn ich mit diesem Snippet versuche die Liste zu erstellen, bekomme ich nur
"Courier New". Auf meinem Rechner habe zB noch "Lucida Console" oder "OCR A
Extended", beide haben die gleiche Schriftzeichenbreite werden aber nicht
aufgelistet. Hab ich da etwas übersehen?

Dim monospaceListe As New List(Of FontFamily)
Dim vorhandeneFonts As New
System.Drawing.Text.InstalledFontCollection
For Each familie As FontFamily In vorhandeneFonts.Families
Dim neueFamilie As FontFamily = familie
neueFamilie = FontFamily.GenericMonospace
If Not monospaceListe.Contains(neueFamilie) Then
monospaceListe.Add(neueFamilie)
Next familie

Peter
 

Lesen sie die antworten

#1 Martin H.
16/01/2010 - 14:54 | Warnen spam
Hallo Peter,

das Problem ist, dass GenericMonospace nur eine Familie zurückgibt
(standardmàßig Courier New).

Mit folgender Routine klappt's:

Dim monospaceListe As New List(Of FontFamily)
Dim vorhandeneFonts As New System.Drawing.Text.InstalledFontCollection()
Dim fnt As Font
Dim gr As Graphics = Me.CreateGraphics()

Dim siWidthCapitalI As Single
Dim siWidthLowercaseI As Single
Dim siWidthCapitalO As Single
Dim siwidthLowercaseO As Single
Dim siWidthCapitalW As Single
Dim siWidthLowercaseW As Single

For Each familie As FontFamily In vorhandeneFonts.Families
fnt = Nothing
Try
fnt = New Font(familie, 8, FontStyle.Bold, GraphicsUnit.Point)
Catch
Try
fnt = New Font(familie, 8, FontStyle.Bold, GraphicsUnit.Point)
Catch
Try
fnt = New Font(familie, 8, FontStyle.Italic, GraphicsUnit.Point)
Catch
Try
fnt = New Font(familie, 8, FontStyle.Strikeout, _
GraphicsUnit.Point)
Catch
Try
fnt = New Font(familie, 8, FontStyle.Underline, _
GraphicsUnit.Point)
Catch
fnt = Nothing
End Try
End Try
End Try
End Try
End Try

If Not fnt Is Nothing Then
siWidthCapitalI = gr.MeasureString("I", fnt).Width
siWidthLowercaseI = gr.MeasureString("i", fnt).Width
siWidthCapitalO = gr.MeasureString("O", fnt).Width
siwidthLowercaseO = gr.MeasureString("o", fnt).Width
siWidthCapitalW = gr.MeasureString("W", fnt).Width
siWidthLowercaseW = gr.MeasureString("w", fnt).Width

If siWidthCapitalI = siWidthCapitalO AndAlso _
siWidthCapitalI = siWidthCapitalW AndAlso _
siWidthCapitalI = siWidthLowercaseI AndAlso _
siWidthCapitalI = siwidthLowercaseO AndAlso _
siWidthCapitalI = siWidthLowercaseW AndAlso _
Not monospaceListe.Contains(familie) Then
monospaceListe.Add(familie)
End If
End If
Next

Hinweis: In meinen Tests war der Vergleich von Single-Werten kein
Problem. Wenn Du aber 1000% sicher sein willst, kannst Du die
Single-Werte noch nach Integer wandeln (CInt (siWidthCapitalI * 100))
und dann den Vergleich durchführen. In meinem Fall hat aber beides zu
den gleichen Resultaten geführt.


Beste Grüße,

Martin

Ähnliche fragen