Access911.net   |   a9BBS   |   OTaA System  
  搜索文章:  
Access911欢迎您光临  
   主页      上传      繁體版       论坛     
设为首页  |  加入收藏   
  
你现在的位置:文章索引 -> 文章分类 -> API  
 首页|  近日更新|  下载  |  文章索引  |  搜索|  术语|  承接工程|  
 
系统正在加载内容,请耐心等待...
 
 查询
 窗体
 报表
 
 
 VBA
 函数
 ADO/DAO/ADO.NET
 API
 ADP
 安全
 发布
 OA
 ASP/ASP.NET
 其他语言
 控件
 DELPHI
 C#/.Net
 本站
 其他
 小例程
 常用软件
 参考文档
 业主作品
 网友大作
 
 
友情链接
 access911.net
 
访问人次
 1702202
 
站长 E-Mail
 net911@sina.com
 access911@gmail.com
 
RSS 订阅

显示附加信息 >>>

如何列举出系统中所有字体?

作者:MS  摘自:www.mvps.org  :cg1  更新日期:2004-9-8  浏览人次:

 

问题:

如何列举出系统中所有字体?

 


回答:

请参考帮助中有关 “AddressOf 运算符” 的示例

Private Sub Command2_Click()
    '在窗体上建立一个列表控件,并且命名为 LIST0 ,更改行来源类型为值列表
    '再加一个命令控件在控件的单击事件里面写下列代码

    FillListWithFonts LIST0
End Sub

Private Sub Command2_Click()
    '在窗体上建立一个命令按钮控件,
    '在控件的单击事件里面写下列代码

    strAllFont = ""
    FillListWithFontsCG ActiveControl
    Debug.Print strAllFont
    'strAllFont 中就列举出系统安装的所有字体
End Sub

'新建一个模块,将下列代码 COPY 进去
Public strAllFont As String
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private 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

Private 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

' ntmFlags field flags
Private Const NTM_REGULAR = &H40&
Private Const NTM_BOLD = &H20&
Private Const NTM_ITALIC = &H1&

'  tmPitchAndFamily flags
Private Const TMPF_FIXED_PITCH = &H1
Private Const TMPF_VECTOR = &H2
Private Const TMPF_DEVICE = &H8
Private Const TMPF_TRUETYPE = &H4

Private Const ELF_VERSION = 0
Private Const ELF_CULTURE_LATIN = 0

'  EnumFonts Masks
Private Const RASTER_FONTTYPE = &H1
Private Const DEVICE_FONTTYPE = &H2
Private Const TRUETYPE_FONTTYPE = &H4

Private Declare Function EnumFontFamilies Lib "gdi32" Alias _
     "EnumFontFamiliesA" _
     (ByVal hDC As Long, _
     ByVal lpszFamily As String, _
     ByVal lpEnumFontFamProc As Long, _
     LParam As Any) _
     As Long

Private Declare Function GetDC Lib "user32" _
        (ByVal hWnd As Long) _
        As Long

Private Declare Function ReleaseDC Lib "user32" _
        (ByVal hWnd As Long, _
        ByVal hDC As Long) _
        As Long

Private Declare Function apiGetFocus Lib "user32" _
        Alias "GetFocus" _
         () As Long

Function fhWnd(ctl As Control) As Long
    On Error Resume Next
    ctl.SetFocus
    If Err Then
        fhWnd = 0
    Else
        fhWnd = apiGetFocus
    End If
    On Error GoTo 0
End Function

Function EnumFontFamProc(lpNLF As LOGFONT, _
                                    lpNTM As NEWTEXTMETRIC, _
                                    ByVal FontType As Long, _
                                    LParam As Control) _
                                    As Long
Dim FaceName As String
Dim FullName As String
Dim strOut As String, strFont As String
    On Error Resume Next
    FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
    strOut = LParam.RowSource
    strFont = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
    If strOut = vbNullString Then
        strOut = strFont
    Else
        strOut = strOut & ";" & strFont
    End If
    LParam.RowSource = strOut
    EnumFontFamProc = 1
End Function

Sub FillListWithFonts(ctl As Control)
Dim hDC As Long
    hDC = GetDC(fhWnd(ctl))
    ctl.RowSource = vbNullString
    EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, ctl
    ReleaseDC fhWnd(ctl), hDC
End Sub

Sub FillListWithFontsCG(ctl As Control)
Dim hDC As Long
    hDC = GetDC(fhWnd(ctl))
    EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProcCG, ctl
    ReleaseDC fhWnd(ctl), hDC
End Sub
Function EnumFontFamProcCG(lpNLF As LOGFONT, _
                                    lpNTM As NEWTEXTMETRIC, _
                                    ByVal FontType As Long, _
                                    ByRef LParam As Control) _
                                    As Long
Dim FaceName As String
Dim FullName As String
Dim strOut As String, strFont As String
    On Error Resume Next
    FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
    strOut = strAllFont
    strFont = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
    If strOut = vbNullString Then
        strOut = strFont
    Else
        strOut = strOut & ";" & strFont
    End If
    strAllFont = strOut
    EnumFontFamProcCG = 1
End Function


 

 

 
相关文章
     没有手动相关文章
     如何调用系统中的选择字体公共对话框
 
评论
     查看或发表更多的评论,请单击这里。
 
 
 
 
 
   
  Access911.net   |   a9BBS   |   OTaA System   |
建站日期:2000年4月2日  |  设计施工:陈格 ( access911 & cg1 )
 Copyright © 2000 - 2003 COMET, 陈格 保留所有权利