GFSetFont/GFSetFont.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Form1"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4590
   LinkTopic       =   "Form1"
   ScaleHeight     =   3075
   ScaleWidth      =   4590
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.PictureBox GFSetFontPicture
      Enabled         =   0 'False
      Height          =   315
      Left            =   960
      ScaleHeight     =   255
      ScaleWidth      =   135
      TabIndex        =   2
      Top             =   60
      Visible         =   0 'False
      Width           =   195
   End
   Begin VB.CommandButton Command1
      Caption         =   "Set Font"
      Height          =   375
      Left            =   2460
      TabIndex        =   1
      Top             =   60
      Width           =   2115
   End
   Begin VB.ListBox List1
      Height          =   2595
      Left            =   0
      TabIndex        =   0
      Top             =   480
      Width           =   4575
   End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Use to change the font of any control. Also copy GFSetFontPicture to target project.
'GFSetFont
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'GFSetFont
Const WM_GETFONT = &H31
Const WM_SETFONT = &H30

Private Sub Form_Load()
    'on error resume next
    Dim Temp As Long
    List1.Clear 'reset
    For Temp = 1 To 20
        List1.AddItem "This is the GFSetFont() test"
    Next Temp
End Sub

Private Sub Command1_Click()
    'on error resume next
    Call GFSetFont(List1.hwnd, "Courier", 8, False, False, False, False, GFSetFontPicture)
End Sub

Private Sub GFSetFont(ByVal hwnd As Long, ByVal FontName As String, ByVal FontSize As Integer, ByVal FontBoldFlag As Boolean, ByVal FontItalicFlag As Boolean, ByVal FontUnderlineFlag As Boolean, ByVal FontStrikeThroughFlag As Boolean, ByRef GFSetFontPicture As PictureBox)
    'on error resume next
    Dim FontHandle As Long
    '
    'NOTE: there are many ways to get a font handle.
    'A font can be created using CreateFont[(Indirect)](), but the
    'trick below is much easier (The Trick (c)2001 by Louis.).
    '
    'preset
    GFSetFontPicture.Font.Name = FontName
    GFSetFontPicture.Font.Size = FontSize
    GFSetFontPicture.Font.Bold = FontBoldFlag
    GFSetFontPicture.Font.Italic = FontItalicFlag
    GFSetFontPicture.Font.Underline = FontUnderlineFlag
    GFSetFontPicture.Font.Strikethrough = FontStrikeThroughFlag
    'begin
    FontHandle = SendMessageLong(GFSetFontPicture.hwnd, WM_GETFONT, 0, 0)
    Call SendMessageLong(hwnd, WM_SETFONT, FontHandle, 1) '1 for redraw; no return value existing
End Sub


[END OF FILE]