Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples4/ch11/enmfntx.frm

Visual Basic Form | 1997-02-16 | 5.7 KB | 170 lines

VERSION 4.00
Begin VB.Form enmfntx
   Caption         =   "Enum Font Example"
   ClientHeight    =   3690
   ClientLeft      =   1095
   ClientTop       =   1500
   ClientWidth     =   7215
   BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4095
   Left            =   1035
   LinkTopic       =   "Form1"
   ScaleHeight     =   3690
   ScaleWidth      =   7215
   Top             =   1155
   Width           =   7335
   Begin VB.ListBox List2
      Height          =   1395
      Left            =   60
      TabIndex        =   4
      Top             =   600
      Width           =   6975
   End
   Begin VB.CommandButton cmdListTrueType
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "List All TrueType"
      Height          =   435
      Left            =   1560
      TabIndex        =   3
      Top             =   120
      Width           =   1755
   End
   Begin VB.CommandButton CmdListVariations
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "List Variations"
      Height          =   435
      Left            =   5280
      TabIndex        =   2
      Top             =   120
      Width           =   1755
   End
   Begin VB.CommandButton CmdListFonts
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "List All Fonts"
      Height          =   435
      Left            =   3420
      TabIndex        =   1
      Top             =   120
      Width           =   1755
   End
   Begin VB.ListBox List1
      Height          =   1200
      Left            =   60
      TabIndex        =   0
      Top             =   2280
      Width           =   6975
   End
   Begin VB.Label Label2
      BackStyle       =   0  'Transparent
      Caption         =   "Font variations with a family:"
      Height          =   255
      Left            =   60
      TabIndex        =   6
      Top             =   2040
      Width           =   2595
   End
   Begin VB.Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Font families:"
      Height          =   255
      Left            =   60
      TabIndex        =   5
      Top             =   300
      Width           =   1395
   End
   Begin Cbkd.Callback Callback1
      Left            =   6540
      Top             =   1740
      _Version        =   262144
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      Type            =   2
   End
Attribute VB_Name = "enmfntx"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved.
Private Sub Callback1_EnumFonts(lpLogFont As Long, lpTextMetrics As Long, nFontType As Long, lpData As Long, retval As Long)
    Dim fullname$, stylename$, facename$
    ' agCopyData copies the data referenced by the pointer
    ' provided into a structure
    agCopyData ByVal lpLogFont, nlf, Len(nlf)
    agCopyData ByVal lpTextMetrics, ntm, Len(ntm)
    ' Only look at TrueType fonts.
    If (lpData = 1) And ((nFontType And TRUETYPE_FONTTYPE) = 0) Then Exit Sub
    If (nFontType And TRUETYPE_FONTTYPE) <> 0 Then
        fullname$ = GetNameFromByteArray(nlf.elfFullName)
        stylename$ = GetNameFromByteArray(nlf.elfStyle)
    End If
    If lpData = 2 And (nFontType And RASTER_FONTTYPE) <> 0 Then
        fullname$ = " Height,Width: " & ntm.tmHeight & "," & ntm.tmAveCharWidth
    End If
    ' Non truetype fonts do not have a valid lfFullname and lfStyle field
    facename$ = GetNameFromByteArray(nlf.elfLogFont.lfFaceName)
    If lpData = 2 Then
        list1.AddItem facename$ & " -- " & fullname$ & " " & stylename$
    Else
        List2.AddItem facename$ & " -- " & fullname$ & " " & stylename$
    End If
End Sub
Private Sub CmdListVariations_Click()
    Dim di&
    Dim fname$
    Dim f%
    list1.Clear
    fname$ = List2.Text
    f% = InStr(fname$, " -- ")
    If f% > 0 Then
        fname$ = Left$(fname$, f% - 1)
    End If
    ' This gets Arial only (all styles)
    di = EnumFontFamilies(hdc, fname$, callback1.ProcAddress, 2)
End Sub
Private Sub CmdListFonts_Click()
    Dim di&
    list1.Clear
    List2.Clear
    ' This gets one font for each family
    di = EnumFontFamilies(hdc, vbNullString, callback1.ProcAddress, 0)
End Sub
Private Sub cmdListTrueType_Click()
    Dim di&
    list1.Clear
    List2.Clear
    ' This gets one font for each family
    ' Danger - be sure to use vbNullString, not 0!  Nasty VB type conversion!
    di = EnumFontFamilies(hdc, vbNullString, callback1.ProcAddress, 1)
End Sub
' Retrieves a string from a byte array which contains
' a null terminated ANSI string
Public Function GetNameFromByteArray$(src() As Byte)
    Dim t$, zeropos%
    ' The array is ANSI, and needs to be converted into Unicode
    ' to fit VB's internal format
    t$ = StrConv(CStr(src), vbUnicode)
    ' And remove the null terminating character and any trailing characters
    zeropos% = InStr(t$, Chr$(0))
    If zeropos% > 1 Then t$ = Left$(t$, zeropos% - 1)
    GetNameFromByteArray$ = t$
End Function
Private Sub Form_Load()
End Sub
Private Sub List2_Click()
    CmdListVariations_Click
End Sub