如何在vba中修改TextOut函数所用的字体？

在如何在vba中用GDI在屏幕上写字？一文和如何在vba中修改TextOut函数所用字体的颜色？ 一文中我们分别介绍了如何在屏幕上用TextOut函数写字，以及如何修改用TextOut函数写字时所用的字体颜色。

但是光以上两点还不能满足所有需求，我们往往还希望可以调整字体的大小和选择显示的字体等各种与字体相关的属性。

这时候可以使用如下的步骤：

1.用CreateFont函数或者CreateFontIndirect函数创建一个需要使用的字体，设置该字体的各种属性。

2.用SelectObject函数将该字体添加到DC中，这样凡是与该DC关联的GDI函数都将使用这个新添加的字体进行字符的输出。

3.用DeleteObject函数删除添加的字体。

其中用CreateFont函数或者CreateFontIndirect函数创建一个需要使用的字体，将使用LOGFONT结构，该结构包含有字体的大小、字体的名称等各种属性，结构如下：

typedef struct tagLOGFONT {
  LONG  lfHeight;
  LONG  lfWidth;
  LONG  lfEscapement;
  LONG  lfOrientation;
  LONG  lfWeight;
  BYTE  lfItalic;
  BYTE  lfUnderline;
  BYTE  lfStrikeOut;
  BYTE  lfCharSet;
  BYTE  lfOutPrecision;
  BYTE  lfClipPrecision;
  BYTE  lfQuality;
  BYTE  lfPitchAndFamily;
  TCHAR lfFaceName[LF_FACESIZE];
} LOGFONT, *PLOGFONT;

把它转换为vb 用户自定义类型如下：

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
        lfFaceName As String
End Type

代码如下：

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
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 Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal nXStart As Long, ByVal nYStart As Long, ByVal lpString As String, ByVal cchString As Long) As Long
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
        lfFaceName As String
End Type
Sub QQ1722187970()
    Dim oFont As LOGFONT
    '设置要使用的字体的格式
    With oFont
        .lfFaceName = "微软雅黑"
        .lfHeight = 100
        .lfWidth = 100
        .lfWeight = 700
    End With
    Dim hDC As Long
    hDC = GetDC(0)
    Dim str As String
    str = "我爱你中国！！！"
    '用红色书写文字
    SetTextColor hDC, vbRed
    '创建字体
    hFont = CreateFontIndirect(oFont)
    '将创建的字体添加到DC中
    SelectObject hDC, hFont
    TextOut hDC, 100, 100, str, LenB(str)
    DeleteObject hFont
    ReleaseDC 0, hDC
End Sub

使用了以上代码后，会发现写出来的字的背景色是白色的，如果要修改背景色，可以添加SetBkColor函数，代码如下：

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
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 Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal nXStart As Long, ByVal nYStart As Long, ByVal lpString As String, ByVal cchString As Long) As Long
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
        lfFaceName As String
End Type
Sub QQ1722187970()
    Dim oFont As LOGFONT
    '设置要使用的字体的格式
    With oFont
        .lfFaceName = "微软雅黑"
        .lfHeight = 100
        .lfWidth = 100
        .lfWeight = 700
    End With
    Dim hDC As Long
    hDC = GetDC(0)
    Dim str As String
    str = "我爱你中国！！！"
    '用红色书写文字
    SetTextColor hDC, vbRed
    '设置字体的背景色
    SetBkColor hDC, vbYellow
    '创建字体
    hFont = CreateFontIndirect(oFont)
    '将创建的字体添加到DC中
    SelectObject hDC, hFont
    TextOut hDC, 100, 400, str, LenB(str)
    DeleteObject hFont
    ReleaseDC 0, hDC
End Sub