.NET开发

本类阅读TOP10

·NHibernate快速指南(翻译)
·vs.net 2005中文版下载地址收藏
·【小技巧】一个判断session是否过期的小技巧
·VB/ASP 调用 SQL Server 的存储过程
·?dos下编译.net程序找不到csc.exe文件
·通过Web Services上传和下载文件
·学习笔记(补)《.NET框架程序设计(修订版)》--目录
·VB.NET实现DirectDraw9 (2) 动画
·VB.NET实现DirectDraw9 (1) 托管的DDraw
·建站框架规范书之——文件命名

分类导航
VC语言Delphi
VB语言ASP
PerlJava
Script数据库
其他语言游戏开发
文件格式网站制作
软件工程.NET开发
VB中用API实现字体公用对话框例子

作者:未知 来源:月光软件站 加入时间:2005-2-28 月光软件站

Private Const LF_FACESIZE = 32
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_EFFECTS = &H100&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const REGULAR_FONTTYPE = &H400

'charset Constants

Private Const ANSI_CHARSET = 0
Private Const ARABIC_CHARSET = 178
Private Const BALTIC_CHARSET = 186
Private Const CHINESEBIG5_CHARSET = 136
Private Const DEFAULT_CHARSET = 1
Private Const EASTEUROPE_CHARSET = 238
Private Const GB2312_CHARSET = 134
Private Const GREEK_CHARSET = 161
Private Const HANGEUL_CHARSET = 129
Private Const HEBREW_CHARSET = 177
Private Const JOHAB_CHARSET = 130
Private Const MAC_CHARSET = 77
Private Const OEM_CHARSET = 255
Private Const RUSSIAN_CHARSET = 204
Private Const SHIFTJIS_CHARSET = 128
Private Const SYMBOL_CHARSET = 2
Private Const THAI_CHARSET = 222
Private Const TURKISH_CHARSET = 162

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 As String * 31
End Type
Private Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hDC As Long                '  printer DC/IC or NULL
        lpLogFont As Long          '  ptr. to a LOGFONT struct
        iPointSize As Long         '  10 * size in points of selected font
        flags As Long              '  enum. type flags
        rgbColors As Long          '  returned text color
        lCustData As Long          '  data passed to hook fn.
        lpfnHook As Long           '  ptr. to hook function
        lpTemplateName As String     '  custom template name
        hInstance As Long          '  instance handle of.EXE that
                                       '    contains cust. dlg. template
        lpszStyle As String          '  return the style field here
                                       '  must be LF_FACESIZE or bigger
        nFontType As Integer          '  same value reported to the EnumFonts
                                       '    call back with the extra FONTTYPE_
                                       '    bits added
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long           '  minimum pt size allowed &
        nSizeMax As Long           '  max pt size allowed if
                                       '    CF_LIMITSIZE is used
End Type

Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" _
                                  (ByRef pChoosefont As CHOOSEFONT) As Long
Private Sub Command1_Click()
    Dim cf As CHOOSEFONT, lfont As LOGFONT
    Dim fontname As String, ret As Long
    cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.lpLogFont = VarPtr(lfont)
    cf.lStructSize = LenB(cf)
    'cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = Form1.hWnd  ' window Form1 is opening this dialog box
    cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
    cf.rgbColors = RGB(0, 0, 0)  ' black
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 10  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ret = CHOOSEFONT(cf) 'brings up the font dialog
    If ret <> 0 Then  ' success
        fontname = StrConv(lfont.lfFaceName, vbUnicode, &H804) 'Retrieve chinese font name in english version os
        fontname = Left$(fontname, InStr(1, fontname, vbNullChar) - 1)
        'Assign the font properties to text1
        With Text1.Font
             .Charset = lfont.lfCharSet 'assign charset to font
             .Name = fontname
             .Size = cf.iPointSize / 10 'assign point size
             Text1.Text = .Name & ":" & .Charset & ":" & .Size 'display data in chosen Font
        End With
    End If
End Sub


 




相关文章

相关软件