VB6的默认字体是从哪里获取的?
它是从系统字体获取的吗?
它是由区域设置确定的吗?
无论实际字体大小如何,它的大小是否始终相同?
应用程序的字体在控件的 Font 属性中设置。VB6 默认使用大小为 8 的 MS Sans Serif 字体,这是 Windows 95/98 中的默认系统字体,并且该名称已经硬编码在 VB6 中。Windows XP 使用大小为 8 的 Tahoma 字体,而 Windows Vista 及更高版本使用大小为 9 的 Segoe UI 字体。因此,如果您需要所有表单和其他控件具有现代外观,请根据 Windows 版本更改字体。检测它可能比较困难,所以此子程序从列表中获取第一个存在的字体:
'fonts and sizes
Const MODERN_FONTS_CSV = "Segoe UI/9,Tahoma/8,MS Sans Serif/8"
Sub ChangeFont(oFrm As VB.Form)
Dim i As Long
Dim mf() As String
Dim fontSize As Long
Dim fontName As String
Dim oCtrl As VB.Control
Dim oFont As New stdole.StdFont
mf = Split(MODERN_FONTS_CSV, ",") 'list of fonts and sizes as CSV
'trying if the font exists
i = 0
Do
fontName = Split(mf(i), "/")(0)
fontSize = CLng(Split(mf(i), "/")(1))
oFont.Name = Trim(fontName) 'does the font exist?
i = i + 1
'font exists or end of the list (last name is the default whether exists or not)
Loop Until StrComp(fontName, oFont.Name, vbTextCompare) = 0 Or i > UBound(mf)
'at first change font in the form
With oFrm.Font
.Name = fontName 'name
.size = fontSize 'size
'.charset = 238 - you can set charset, in some cases it could be necessary
End With
'loop through all controls in the form
'some controls doesn't have font property (timer, toolbar) - ignore error
On Error Resume Next
For Each oCtrl In oFrm.Controls
With oCtrl.Font
.Name = fontName 'name
.size = fontSize 'size
'.charset = 238 - charset, if you want
Err.Clear
End With
Next
On Error GoTo 0
End Sub
解决方案2 - 获取系统字体名称
这段代码与之前的相似,但是通过API读取系统字体名称和大小(感谢Bob77)。但是,它也有一些缺点:
代码:
Option Explicit
Declare Function SystemParametersInfo Lib "USER32.DLL" _
Alias "SystemParametersInfoA" (ByVal uAction As Long, _
ByVal uiParam As Long, pvParam As Any, _
ByVal fWinIni As Long) As Long
Private Const LOGPIXELSY = 90
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
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(1 To 32) As Byte
End Type
Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Public Sub ChangeFont(oFrm As VB.Form)
Dim i As Long
Dim ncm As NONCLIENTMETRICS
Dim fontSize As Long
Dim fontName As String
Dim oCtrl As VB.Control
Dim oFont As New stdole.StdFont
'get font properties
ncm.cbSize = Len(ncm)
SystemParametersInfo SPI_GETNONCLIENTMETRICS, 0, ncm, 0
For i = 1 To 32
fontName = fontName & Chr(ncm.lfMessageFont.lfFaceName(i))
Next i
'name
fontName = Replace(fontName, Chr(0), "") 'trim
'size
fontSize = -(ncm.lfMessageFont.lfHeight * (72 / GetDeviceCaps(oFrm.hDC, LOGPIXELSY)))
'at first change font in the form
With oFrm.Font
.Name = fontName 'name
.Size = fontSize 'size
'.charset = 238 - you can set charset, in some cases it could be necessary
End With
'loop through all controls in the form
'some controls doesn't have font property (timer, toolbar) - ignore error
On Error Resume Next
For Each oCtrl In oFrm.Controls
With oCtrl.Font
.Name = fontName 'name
.Size = fontSize 'size
'.charset = 238 - charset, if you want
Err.Clear
End With
Next
On Error GoTo 0
End Sub
对于其他字体操作,请参见此模块。
其他问题
这是否由语言环境决定?
不是的,但当Windows设置为不同的语言环境(例如德国Windows环境和捷克语环境)时,我遇到了特定于国家/地区的字符问题。我必须为所有控件强制使用代码页(请参见上面的代码)。
无论实际字体大小如何,它的大小是否始终相同?
如果您在Windows环境中更改字体大小,则文本大小会以适当的方式更改。 我强烈建议:测试所有组合-从MODERN_FONTS_CSV常量和Windows文本大小100-150%的字体。
Windows 7笔记本电脑可以安装125%更大的字体。以下是一篇很棒的文章和解决方法:http://www.rlvision.com/misc/windows_7_font_bug.asp
如果VB6应用程序只使用默认字体,则会使用这些更大的字体。
MS Shell Dlg
也会获取系统字体,因为存在字体别名。 - DeannaSystemParametersInfo(SPI_GETNONCLIENTMETRICS)
是正确的方法,使用返回的lfMessageFont
作为基本字体。 - Bob77SystemParametersInfo
(带有一些警告)。 - Roman Plischke