Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0211: Größe und Fonts der Systemschriften

 von 

Beschreibung 

Die Größen der eingestellten Systemschriftarten können auf jedem Rechner anders sein. Dies kann fatale Folgen für positionskritische Operationen sein, z.B. bei Bitmaps in Menüs. Daher sollte dies berücksichtigt werden. Hier wird gezeigt wie an die entsprechenden Werte zu gelangen ist.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

GetDeviceCaps, SystemParametersInfoA (SystemParametersInfo)

Download:

Download des Beispielprojektes [2,42 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "List1"

Option Explicit

Private Declare Function SystemParametersInfo Lib _
        "user32" Alias "SystemParametersInfoA" (ByVal _
        uAction As Long, ByVal uParam As Long, _
        lpvParam As Any, ByVal fuWinIni As Long) As Long
               
Private Declare Function GetDeviceCaps Lib "gdi32" _
        (ByVal hDC As Long, ByVal nIndex As Long) As _
        Long

Const SPI_GETICONTITLELOGFONT = 31
Const SPI_GETNONCLIENTMETRICS = 41
Const LF_FACESIZE = 32
Const LOGPIXELSY = 90

Private Type NMLOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName(LF_FACESIZE - 4) As Byte
End Type

Private Type NONCLIENTMETRICS
  cbSize As Long
  iBorderWidth As Long
  iScrollWidth As Long
  iScrollHeight As Long
  iCaptionWidth As Long
  iCaptionHeight As Long
  lfCaptionFont As NMLOGFONT
  iSMCaptionWidth As Long
  iSMCaptionHeight As Long
  lfSMCaptionFont As NMLOGFONT
  iMenuWidth As Long
  iMenuHeight As Long
  lfMenuFont As NMLOGFONT
  lfStatusFont As NMLOGFONT
  lfMessageFont As NMLOGFONT
End Type

Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName(LF_FACESIZE) As Byte
End Type

Private Sub Form_Load()
  Dim NCM As NONCLIENTMETRICS, ITLF As LOGFONT, Result&
  
    NCM.cbSize = 340
    Result = SystemParametersInfo(SPI_GETNONCLIENTMETRICS, _
                                  0, NCM, 0)
    If Result Then
     Call SystemParametersInfo(SPI_GETICONTITLELOGFONT, 0, _
                               ITLF, 0)
     Call GetNMLogFont(NCM.lfCaptionFont, "Caption")
     Call GetNMLogFont(NCM.lfSMCaptionFont, "SMCaption")
     Call GetNMLogFont(NCM.lfMenuFont, "Menü")
     Call GetNMLogFont(NCM.lfStatusFont, "Status")
     Call GetNMLogFont(NCM.lfMessageFont, "Message")
     Call GetLogFont(ITLF, "Icon")
   End If
End Sub

Private Sub GetNMLogFont(NMLF As NMLOGFONT, Dscr$)
  Call GetFontInfo(NMLF.lfFaceName, NMLF.lfHeight, Dscr$)
End Sub

Private Sub GetLogFont(LF As LOGFONT, Dscr$)
  Call GetFontInfo(LF.lfFaceName, LF.lfHeight, Dscr$)
End Sub

Private Sub GetFontInfo(ByVal FName$, ByVal FSize&, Dscr$)
  FName = StrConv(FName, vbUnicode)
  FName = Left$(FName, InStr(1, FName, Chr$(0)) - 1)
  If FSize < 1 Then FSize = Abs((72 / GetDeviceCaps(Me.hDC, _
                                 LOGPIXELSY)) * FSize)
  List1.AddItem Dscr & ": " & FName & " " & FSize
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Peter Topfmeyer am 01.09.2009 um 16:36

Kann es sein, dass Fonts in ihrer eigenschaft dadurch verändert werden, z.B. Underline wird plötzlich aktiv.
Kann sogar im schlimmsten Fall der Font selber wechsel z.B. Arial zu System?
Wie kann man dieses verhindern?
Wir haben den Fall, dass Font.Name oder Font.Underline oder Font.Italic sich laufend ändern.

Herzlichen Dank
Peter

Kommentar von Semertzidis am 03.10.2003 um 03:30

Hallo,

wenn man eine eigene Schriftart installiert kann die Grösse
dieser auch von Rechner zu Rechner verschieden sein ???