VB调用CreateFont后整个界面的字体都变了

首先在窗体添加1个picturebox(必须的)，再添加一些按钮，checkbox等其他控件，运行下面代码后，所有控件的字体都受到影响，该怎么解决？

Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const LOGPIXELSY = 90

Private Sub Form_Load()
 Dim FontObj As Long
 FontObj = CreateFont(-MulDiv(FontSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, 0, 0, 0, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "宋体")
 If FontObj <> 0 Then DeleteObject SelectObject(Picture1.hdc, FontObj)
End Sub

4 个解决方案

#1

用CreateFontIndirect。。

#2

按照你的方法，还是不行

Option Explicit
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const LOGPIXELSY = 90
Private Const LF_FACESIZE = 32
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 Sub Form_Load()
 Dim FontObj As Long, lf As LOGFONT, tfn() As Byte, i As Long
 tfn = StrConv("宋体", 128)
 With lf
  .lfHeight = -MulDiv(FontSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
  .lfWidth = 0
  .lfEscapement = 0
  .lfOrientation = 0
  .lfWeight = 0
  .lfItalic = 0
  .lfUnderline = 0
  .lfStrikeOut = 0
  .lfCharSet = DEFAULT_CHARSET
  .lfOutPrecision = OUT_DEFAULT_PRECIS
  .lfClipPrecision = CLIP_DEFAULT_PRECIS
  .lfQuality = PROOF_QUALITY
  .lfPitchAndFamily = DEFAULT_PITCH
  For i = 0 To UBound(tfn)
   .lfFaceName(i) = tfn(i)
  Next i
  .lfFaceName(i) = 0
 End With
 FontObj = CreateFontIndirect(lf)
 DeleteObject SelectObject(Picture1.hdc, FontObj)
End Sub

#3

'*王国荣先生的例子
'module：
Option Explicit

Public Const LF_FACESIZE = 32
Public Const DEFAULT_CHARSET = 1
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(0 To LF_FACESIZE - 1) As Byte
End Type
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


'code in form1：
Option Explicit

Private Sub Command1_Click()
    Dim font As LOGFONT
    Dim hOldFont As Long, hFont As Long
     
    RtlMoveMemory font.lfFaceName(0), _
                   ByVal CStr(cmbFontName), _
                   LenB(StrConv(cmbFontName, vbFromUnicode)) + 1
                   
    font.lfHeight = (Val(txtHeight) * -20) / Screen.TwipsPerPixelY
    font.lfWidth = (Val(txtWidth) * -20) / Screen.TwipsPerPixelY
    font.lfEscapement = Val(txtRotate) * 10
    font.lfWeight = IIf(chkBold, 700, 400)
    font.lfItalic = chkItalic
    font.lfUnderline = chkUnderline
    font.lfStrikeOut = chkStrikeThrough
    font.lfCharSet = DEFAULT_CHARSET
     
    hFont = CreateFontIndirect(font)
    hOldFont = SelectObject(Picture1.hDC, hFont)
     
    Picture1.Cls
    Picture1.CurrentX = Picture1.ScaleWidth / 2
    Picture1.CurrentY = Picture1.ScaleHeight / 2
    Picture1.Print txtString.Text
          
    SelectObject Picture1.hDC, hOldFont
    DeleteObject hFont
    
End Sub

Private Sub Form_Load()
    Dim i As Integer
    
    For i = 0 To Screen.FontCount - 1
        cmbFontName.AddItem Screen.Fonts(i)
    Next
    
    cmbFontName.Text = "Times New Roman"
End Sub

#4

没问题了，谢谢

只是一直疑惑为什么要Select回旧的Font object，理论上每个控件的字体都是独立的，不会影响到其他控件

谢谢