Die Community zu .NET und Classic VB.

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

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

 von ActiveVB

Schwierigkeitsgrad:

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 --------------

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.