Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Return true system fonts

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Return true system fonts

    Code:
    ' -----------------------------------------------------------------------------
    ' FontFace.bas
    ' ------------
    ' A series of functions to obtain (from the registry), the fonts currently used
    ' for various user interface objects.
    '
    ' Use how you please at your own risk.
    ' ------------------------------------
    '
    ' Notes.
    ' I have been toying around for a bit, wondering how you access the UI fonts,
    ' after a while I found them stored as binary values in the registry.
    ' The below code (which works on Win '98) allows you access the values.
    '
    ' Each function returns the font face with point size and bold & italic flags
    ' Simply use the built-in Parse$ to parse the string, like so:
    '
    ' sTypeFace = Parse$("Arial,8,1", 1)
    '
    '
    ' Please make comments, etc to- [email protected], thank you.
    ' -----------------------------------------------------------------------------
    
    $Dim All
    $Register None
    $Compile Exe
    $Include "Win32api.inc"
    
    
    Type LOGFONT2
       lfHeight     As Long
       lfUnknown1   As Long
       lfUnknown2   As Byte
       lfUnknown3   As Byte
       lfItalic     As Byte
       lfWeight     As Long
       lfUnknown4   As Byte
       lfUnknown5   As Byte
       lfUnknown6   As Byte
       lfFaceName   As Asciiz * %LF_FACESIZE
    End Type
    
    
    ' ---------------------------------------------------------
    ' Main function to retreive information from the registry
    ' ---------------------------------------------------------
    
    Function GetRegFont(ByVal sType As String) As String
     Dim hKey As Long, lf As LOGFONT2
    
     If RegOpenKeyEx(%HKEY_CURRENT_USER, "Control Panel\Desktop\WindowMetrics", 0, %KEY_READ, hKey) = %ERROR_SUCCESS Then
        If RegQueryValueEx(hKey, ByCopy sType, 0, %REG_BINARY, ByVal VarPtr(lf), SizeOf(lf)) = %ERROR_SUCCESS Then
           ' Return face name, size, bold and italic attributes...
           If lf.lfWeight => %FW_BOLD Then lf.lfWeight = 1 Else lf.lfWeight = 0
           Function = lf.lfFaceName + "," + Format$(lf.lfHeight) + "," + Format$(lf.lfWeight) + "," + Format$(lf.lfItalic)
        Else
           GoTo RegFailedEx
        End If
        RegCloseKey hKey
     Else
        RegFailedEx:
        ' State a default font...
        Function = "MS Sans Serif,8,0,0"
     End If
    End Function
    ' ---------------------------------------------------------
    ' Multiple functions for obtaining various fonts
    ' ---------------------------------------------------------
    
    Function Font_GetCaptionFace As String
     Function = GetRegFont("CaptionFont")
    End Function
    
    Function Font_GetIconFace As String
     Function = GetRegFont("IconFont")
    End Function
    
    Function Font_GetStatusFace As String
     Function = GetRegFont("StatusFont")
    End Function
    
    Function Font_GetMenuFace As String
     Function = GetRegFont("MenuFont")
    End Function
    
    Function Font_GetMessageFace As String
     Function = GetRegFont("MessageFont")
    End Function
    ' ---------------------------------------------------------
    ' Small tester function
    ' ---------------------------------------------------------
    
    Function pbmain
    
     Messagebox 0, _
     Font_GetMessageFace + "  [Message Font]"   + Chr$(13,13) + _
     Font_GetMenuFace    + "  [Menu Font]"      + Chr$(13,13) + _
     Font_GetCaptionFace + "  [Caption Font]"   + Chr$(13,13) + _
     Font_GetIconFace    + "  [Icon Font]"      + Chr$(13,13) + _
     Font_GetStatusFace  + "  [Status Font]"    + Chr$(13,13), _
     "System Fonts Example", %MB_OK
    
    End Function

    - Updated Oct 2001 with a modified LOGFONT2 structure.

    [This message has been edited by K Peel (edited October 07, 2001).]
Working...
X