VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)
首页 - 经验之谈 - 取得各字型的信息
发表评论(0)作者:不详, 平台:VB6.0+Win98, 阅读:9088, 日期:2001-09-28
取得各字型的信息


作者: cww 

  这个例子取得系统中字型的TypeFace、FamilyName、字型种类、字型大小之信息

  以前在bbs上曾见过有人问到系统的字型是Large Font或Small Font该如何判定,
其实Check一下System Font中,字型大小是12点者为Large Font, 10点为Small Font
所以在CallBack Function改成以下便可得知

Public Function FontFamily(ELGFont As ENUMLOGFONT, ByVal ntm As Long, ByVal fonttype As Long, ByVal lparam As Long) As Long
Dim str5 As String, ff As Byte
Dim hi As Long, ii As Long
str5 = StrConv(ELGFont.elfLogFont.lfFaceName, vbUnicode)
str5 = Left(str5, InStr(1, str5, Chr(0)) - 1)
ii = GetDeviceCaps(hdc, LOGPIXELSY)
hi = MulDiv(ELGFont.elfLogFont.lfHeight, 72, ii) 注释:字型大小更改成点数来看
If str5 = "System" Then 注释:System字型
   If hi = 12 Then
      Debug.Print "Large Font"
   Else
      If hi = 10 Then
         Debug.Print "Small Font"
      Else
         Debug.Print "User Defined"
      End If
   End If
   FontFamily = 0 注释:不再找了
Else
   FontFamily = 1 注释:再找下去
End If
End Function


fumi Write:

  一般萤幕的驱动程式会预设两种字型大小:大字型为 120dpi,小字型为 96dpi,
VB 有个很方便的方法使用 Screen.TwipsPerPixelX、Screen.TwipsPerPixelY(通常这两
个值会相同)可以得知是大字型或是小字型,由於 1 in = 1440 twips, 所以,
如果 Screen.TwipsPerPixelX 的值为 12 的话, 就是大字型, 如果其值为 15 就是小
字型,如果为其他的数值则是自订字型大小

注释: below is in .Bas
Option Explicit
Public Const LF_FULLFACESIZE = 64
Public Const LF_FACESIZE = 32
Public Const DEVICE_FONTTYPE = &H1
Public Const RASTER_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const FF_DECORATIVE = 80
Public Const FF_DONTCARE = 0
Public Const FF_MODERN = 48
Public Const FF_ROMAN = 16
Public Const FF_SCRIPT = 64
Public Const FF_SWISS = 32
Public Const LOGPIXELSY = 90

Type NEWTEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
        ntmFlags As Long
        ntmSizeEM As Long
        ntmCellHeight As Long
        ntmAveWidth As Long
End Type


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
Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type
Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hdc As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, ByVal lparam As Long) As Long
Type ENUMLOGFONT
        elfLogFont As LOGFONT
        elfFullName(LF_FULLFACESIZE) As Byte
        elfStyle(LF_FACESIZE) As Byte
End Type
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function ReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private hdc As Long

Public Sub EnumFontInfo()
Dim i As Long
i = 1
hdc = GetDC(0)
Call EnumFontFamilies(hdc, vbNullString, AddressOf FontFamily, 0)
Call ReleaseDC(0,hdc)
End Sub

Public Function FontFamily(ELGFont As ENUMLOGFONT, ByVal ntm As Long, ByVal fonttype As Long, ByVal lparam As Long) As Long
Dim str5 As String, ff As Byte
Dim hi As Long, ii As Long
str5 = StrConv(ELGFont.elfLogFont.lfFaceName, vbUnicode)
str5 = Left(str5, InStr(1, str5, Chr(0)) - 1)
ii = GetDeviceCaps(hdc, LOGPIXELSY)
hi = MulDiv(ELGFont.elfLogFont.lfHeight, 72, ii)
Debug.Print "FontFace = "; str5, " Height (point) = "; hi
If (fonttype And DEVICE_FONTTYPE) <> 0 Then
   Debug.Print "   Type is Vector"
End If
If (fonttype And RASTER_FONTTYPE) <> 0 Then
   Debug.Print "   Type is Raster"
End If
If (fonttype And TRUETYPE_FONTTYPE) <> 0 Then
   Debug.Print "   Type is TrueType"
End If
ff = ELGFont.elfLogFont.lfPitchAndFamily And &HF0
If ff = FF_DECORATIVE Then
   Debug.Print "   Family = Decorative"
End If
If ff = FF_DONTCARE Then
   Debug.Print "   Family = Do Not Care"
End If
If ff = FF_MODERN Then
   Debug.Print "   Family = Modern"
End If
If ff = FF_ROMAN Then
   Debug.Print "   Family = Roman"
End If
If ff = FF_SCRIPT Then
   Debug.Print "   Family = Script"
End If
If ff = FF_SWISS Then
   Debug.Print "   Family = Swiss"
End If
FontFamily = 1
End Function

注释:Below is in Form

Private Sub Form_Load()
Call EnumFontInfo
End Sub