Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ppfont10/ppfont.frm

Visual Basic Form | 1995-05-08 | 11.1 KB | 347 lines

VERSION 2.00
Begin Form fontform
   Caption         =   "PPFont Demo"
   ClientHeight    =   5490
   ClientLeft      =   135
   ClientTop       =   1455
   ClientWidth     =   9375
   Height          =   5895
   Left            =   75
   LinkTopic       =   "Form2"
   ScaleHeight     =   5490
   ScaleWidth      =   9375
   Top             =   1110
   Width           =   9495
   Begin ListBox List5
      Height          =   3150
      Left            =   6960
      TabIndex        =   8
      Top             =   600
      Width           =   2355
   End
   Begin ListBox List4
      Height          =   3150
      Left            =   4920
      TabIndex        =   6
      Top             =   600
      Width           =   1995
   End
   Begin ListBox List3
      Height          =   1395
      Left            =   3480
      TabIndex        =   5
      Top             =   2280
      Width           =   1395
   End
   Begin ListBox List2
      Height          =   1395
      Left            =   3480
      TabIndex        =   1
      Top             =   600
      Width           =   1395
   End
   Begin ListBox List1
      Height          =   3150
      Left            =   60
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   600
      Width           =   3375
   End
   Begin Label Label6
      Alignment       =   2  'Center
      Caption         =   "AaBbCcDdEeFfGgHhIiJjKkLlMm NnOoPpQqRrSsTtUuVvWwXxYyZz 1234567890"
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   18
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   1635
      Left            =   60
      TabIndex        =   10
      Top             =   3840
      Width           =   9135
   End
   Begin Label Label5
      Alignment       =   2  'Center
      Caption         =   "TEXTMETRIC (physical)"
      Height          =   375
      Left            =   7560
      TabIndex        =   9
      Top             =   180
      Width           =   1275
   End
   Begin Label Label4
      Alignment       =   2  'Center
      Caption         =   "LOGFONT (logical)"
      Height          =   375
      Left            =   5100
      TabIndex        =   7
      Top             =   180
      Width           =   1575
   End
   Begin Label Label3
      Caption         =   "Style"
      Height          =   315
      Left            =   3480
      TabIndex        =   4
      Top             =   2040
      Width           =   1515
   End
   Begin Label Label2
      Caption         =   "Full Name"
      Height          =   195
      Left            =   3480
      TabIndex        =   3
      Top             =   360
      Width           =   1575
   End
   Begin Label Label1
      Caption         =   "Family"
      Height          =   315
      Left            =   60
      TabIndex        =   2
      Top             =   300
      Width           =   1515
   End
Declare Function PPFontFam Lib "PPFONT.DLL" (ByVal hwnd As Integer, alf As NEWLOGFONT, atm As NEWTEXTMETRIC, aft As Integer) As Integer
Declare Function PPFontFamNum Lib "PPFONT.DLL" (ByVal hwnd As Integer) As Integer
Declare Function PPFont Lib "PPFONT.DLL" (ByVal hwnd As Integer, alf As NEWLOGFONT, atm As NEWTEXTMETRIC, aft As Integer, ByVal acharset As String) As Integer
Declare Function PPFontNum Lib "PPFONT.DLL" (ByVal hwnd As Integer, ByVal acharset As String) As Integer
Function chst (testitem As String)
    Select Case Asc(testitem)
           Case 0
                chst = "ANSI"
           Case 1
                chst = "Default"
           Case 2
                chst = "Symbol"
           Case 128
                chst = "SHIFTJIS"
           Case 129
                chst = "HANGEUL"
           Case 136
                chst = "ChineseBig5"
           Case 255
                chst = "OEM"
           Case Else
                chst = "Unknown"
    End Select
End Function
Function clipprecision (testitem As String)
    Select Case Asc(testitem)
           Case 0
                clipprecision = "Default"
           Case 1
                clipprecision = "Character"
           Case 2
                clipprecision = "Stroke"
           Case &HF
                clipprecision = "Mask"
           Case &H10
                clipprecision = "LH Angles"
           Case &H20
                clipprecision = "TT Angles"
           Case &H80
                clipprecision = "Embedded"
           Case Else
                clipprecision = "Unknown"
    End Select
End Function
Function family (testitem As String)
    f% = Asc(testitem) / 16
    Select Case f%
           Case 0
                family = "Don't Care"
           Case 1
                family = "Roman"
           Case 2
                family = "Swiss"
           Case 3
                family = "Modern"
           Case 4
                family = "Script"
           Case 5
                family = "Decorative"
           Case Else
                family = "Unknown"
    End Select
End Function
Sub Form_Load ()
    Static lf() As NEWLOGFONT
    Static tm() As NEWTEXTMETRIC
    Static ftype() As Integer
    n = PPFontFamNum(hwnd)
    ReDim lf(n), tm(n), ftype(n)
    i = PPFontFam(hwnd, lf(1), tm(1), ftype(1))
    For j = 1 To i
        If ftype(j) And DEVICE_FONTTYPE Then
           ft$ = "Device  "
        Else
           ft$ = "GDI  "
        End If
        If ftype(j) And TRUETYPE_FONTTYPE Then
           ft$ = ft$ + "TrueType"
        Else
           If ftype(j) And RASTER_FONTTYPE Then
              ft$ = ft$ + "Raster"
           Else
              ft$ = ft$ + "Vector"
           End If
        End If
        font$ = lf(j).lfFacename
        For k = 1 To LF_FACESIZE
            If Asc(Mid$(font$, k, 1)) = 0 Then
               Exit For
            End If
        Next
        font$ = Mid$(font$, 1, k - 1)
        l = Len(ft$)
        list1.AddItem font$ + "   * " + ft$
    Next
    list1.ListIndex = 4
    List1_Click
End Sub
Sub List1_Click ()
    Static lf() As NEWLOGFONT
    Static tm() As NEWTEXTMETRIC
    Static ftype() As Integer
    list2.Clear
    list3.Clear
    list4.Clear
    list5.Clear
    selfont$ = list1.List(list1.ListIndex)
    n = InStr(selfont$, "*")
    selfont$ = Trim(Mid$(selfont$, 1, n - 4))
    n = PPFontNum(hwnd, selfont$)
    ReDim lf(n), tm(n), ftype(n)
    i = PPFont(hwnd, lf(1), tm(1), ftype(1), selfont$)
    If ftype(1) And TRUETYPE_FONTTYPE Then
       For j = 1 To i
           list2.AddItem lf(j).lfFacename
           list3.AddItem lf(j).lfStyle
       Next
    End If
    ' display logical info
    list4.AddItem "Height:  " + Str$(lf(1).lfHeight)
    list4.AddItem "Width:  " + Str$(lf(1).lfWidth)
    list4.AddItem "Escapement:  " + Str$(lf(1).lfEscapement)
    list4.AddItem "Orientation:  " + Str$(lf(1).lfOrientation)
    list4.AddItem "Weight:  " + weight(lf(1).lfWeight)
    list4.AddItem "Italic:  " + yn(lf(1).lfItalic)
    list4.AddItem "Underline:  " + yn(lf(1).lfUnderline)
    list4.AddItem "Strike-out:  " + yn(lf(1).lfStrikeOut)
    list4.AddItem "Pitch:  " + pitch(lf(1).lfPitchAndFamily)
    list4.AddItem "Family:  " + family(lf(1).lfPitchAndFamily)
    list4.AddItem "CharSet:  " + chst(lf(1).lfCharSet)
    list4.AddItem "OutPrecision:  " + outprecision(lf(1).lfOutPrecision)
    list4.AddItem "ClipPrecision:  " + clipprecision(lf(1).lfClipPrecision)
    list4.AddItem "Quality:  " + quality(lf(1).lfQuality)
    list5.AddItem "Height:  " + Str$(tm(1).tmHeight)
    list5.AddItem "Ascent:  " + Str$(tm(1).tmAscent)
    list5.AddItem "Descent:  " + Str$(tm(1).tmDescent)
    list5.AddItem "Int. Leading:  " + Str$(tm(1).tmInternalLeading)
    list5.AddItem "Ext. Leading:  " + Str$(tm(1).tmExternalLeading)
    list5.AddItem "Ave. Width:  " + Str$(tm(1).tmAveCharWidth)
    list5.AddItem "Max. Width:  " + Str$(tm(1).tmMaxCharWidth)
    list5.AddItem "Weight:  " + Str$(tm(1).tmWeight)
    list5.AddItem "Italic:  " + yn(tm(1).tmItalic)
    list5.AddItem "Underline:  " + yn(tm(1).tmUnderlined)
    list5.AddItem "Strike-out:  " + yn(tm(1).tmStruckOut)
    list5.AddItem "First Char:  " + Str$(Asc(tm(1).tmFirstChar))
    list5.AddItem "Last Char:  " + Str$(Asc(tm(1).tmLastChar))
    list5.AddItem "Default Char:  " + Str$(Asc(tm(1).tmDefaultChar))
    list5.AddItem "Break Char:  " + Str$(Asc(tm(1).tmBreakChar))
    list5.AddItem "Pitch:  " + pitch(tm(1).tmPitchAndFamily)
    list5.AddItem "Family:  " + family(tm(1).tmPitchAndFamily)
    list5.AddItem "Char Set:  " + chst(tm(1).tmCharSet)
    list5.AddItem "Overhang:  " + Str$(tm(1).tmOverhang)
    list5.AddItem "Digitized X:  " + Str$(tm(1).tmDigitizedAspectX)
    list5.AddItem "Digitized Y: " + Str$(tm(1).tmDigitizedAspectY)
    list5.AddItem "Size EM:  " + Str$(tm(1).ntmSizeEM)
    list5.AddItem "Cell Height:  " + Str$(tm(1).ntmCellHeight)
    list5.AddItem "Avg. Width - notional:  " + Str$(tm(1).ntmAvgWidth)
    label6.FontName = selfont$
End Sub
Function outprecision (testitem As String)
    Select Case Asc(testitem)
           Case 0
                outprecision = "Default"
           Case 1
                outprecision = "String"
           Case 2
                outprecision = "Character"
           Case 3
                outprecision = "Stroke"
           Case 4
                outprecision = "TT"
           Case 5
                outprecision = "Device"
           Case 6
                outprecision = "Raster"
           Case 7
                outprecision = "TT Only"
           Case Else
                outprecision = "Unknown"
    End Select
End Function
Function pitch (testitem As String)
    i = Asc(testitem) Mod 16
    Select Case i
        Case 0
            pitch = "Default"
        Case 1
            pitch = "Fixed"
        Case 2
            pitch = "Variable"
        Case Else
            pitch = "Unknown"
    End Select
End Function
Function quality (testitem As String)
    Select Case Asc(testitem)
        Case 0
            quality = "Default"
        Case 1
            quality = "Draft"
        Case 2
            quality = "Proof"
        Case Else
            quality = "Unknown"
    End Select
End Function
Function weight (testitem As Integer)
    Select Case i
        Case 0
            weight = "Don't care"
        Case 100
            weight = "Thin"
        Case 200
            weight = "Extra Light"
        Case 300
            weight = "Light"
        Case 400
            weight = "Normal"
        Case 500
            weight = "Medium"
        Case 600
            weight = "Semi-bold"
        Case 700
            weight = "Bold"
        Case 800
            weight = "Extra Bold"
        Case 900
            weight = "Heavy"
        Case Else
            weight = "Unknown"
    End Select
End Function
Function yn (testitem As String)
    If Asc(testitem) = 0 Then
       yn = "Yes"
    Else
       yn = "No"
    End If
End Function