VB 之 第四课 字体应用篇之二
首先来四个API函数，分别是DeltetObject,CreateFontIndirect,SelectOBject,TextOut.先分别对这几个函数的说明做下介绍。
DeltetObject
函数功能：该函数删除一个逻辑笔、画笔、字体、位图、区域或者调色板，释放所有与该对象有关的系统资源，在对象被删除之后，指定的句柄也就失效了。
函数原型：BOOL DeleteObject(HGDIOBJ hObject)；
参数：
hObject：逻辑笔、画笔、字体、位图、区域或者调色板的句柄。
返回值：成功，返回非零值；如果指定的句柄无效或者它已被选入设备上下文环境，则返回值为零。
CreateFontIndirect
函数功能：该函数创建一种在指定结构定义其特性的逻辑字体。这种字体可在后面的应用中被任何设备环境选作字体。
函数原型：HFONT CreateFontIndirect(CONST LOGFONT *lplf)；
参数：
lplf：指向定义此逻辑字体特性的LOGFONT结构的指针。
返回值：如果函数调用成功，返回值是逻辑字体的句柄；如果函数调用失败，返回值是NULL
SelectOBject
函数功能：该函数选择一对象到指定的设备上下文环境中，该新对象替换先前的相同类型的对象。
函数原型：HGDIOBJ SelectObject(HDC hdc, HGDIOBJ hgdiobj)
参数：
hdc：设备上下文环境的句柄。
hgdiobj：被选择的对象的句柄，该指定对象必须由如下的函数创建。
位图：CreateBitmap, CreateBitmapIndirect, CreateCompatible Bitmap, CreateDIBitmap, CreateDIBsection（只有内存设备上下文环境可选择位图，并且在同一时刻只能一个设备上下文环境选择位图）。
画刷：CreateBrushIndirect, CreateDIBPatternBrush, CreateDIBPatternBrushPt, CreateHatchBrush, CreatePatternBrush, CreateSolidBrush。
字体：CreateFont, CreateFontIndirect。
笔：CreatePen, CreatePenIndirect。
区域：CombineRgn, CreateEllipticRgn, CreateEllipticRgnIndirect, CreatePolygonRgn, CreateRectRgn,CreateRectRgnIndirect。
返回值：如果选择对象不是区域并且函数执行成功，那么返回值是被取代的对象的句柄；如果选择对象是区域并且函数执行成功，返回如下一值:
SIMPLEREGION：区域由单个矩形组成；
COMPLEXREGION：区域由多个矩形组成;
NULLREGION：区域为空。
如果发生错误并且选择对象不是一个区域，那么返回值为NULL，否则返回HGDI_ERROR。
textOut
该函数用当前选择的字体、背景颜色和正文颜色将一个字符串写到指定位置
函数原型
BOOL TextOut(
HDC hdc, // 设备描述表句柄
int nXStart, // 字符串的开始位置 x坐标
int nYStart, // 字符串的开始位置 y坐标
LPCTSTR lpString, // 字符串
int cbString // 字符串中字符的个数
);
参数
hdc
[输入] 设备环境的句柄
nXStart
[输入] 指定用于字符串对齐的基准点的逻辑X坐标。
nYStart
[输入] 指定用于字符串对齐的基准点的逻辑Y坐标。
lpString
[输入] 指向将被绘制字符串的指针。此字符串不必为以\0结束的，因为cbString中指定了字符串的长度。
cbString
[输入] 指定了字符串的长度
返回值
如果函数调用成功，返回值为非零值。
如果函数调用失败，返回值为0。
我们需要5个标签，5个编辑框，3个选择框，2个按钮和4个UPdown控件，直接上源码
Option Explicit
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Button As Long
End Type
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 * 50
End Type
Private RF As LOGFONT
Private NewFont As Long
Private OldFont As Long
Function FontOption()
RF.lfWidth = Int(Val(Me.txtWidth.Text))
RF.lfHeight = Int(Val(Me.txtHeight.Text))
RF.lfEscapement = Int(Val(Me.txtEscapement.Text))
RF.lfWeight = Int(Val(Me.txtWeight.Text))
RF.lfItalic = Me.chkItalic.Value
RF.lfUnderline = Me.chkUnderline.Value
RF.lfStrikeOut = Me.chkStrikeOut.Value
End Function
Private Sub Command1_Click()
Dim Throw As Long
Dim x, y As Long
FontOption '设置字体参数
NewFont = CreateFontIndirect(RF) '创建新字体
OldFont = SelectObject(Me.Picture1.hdc, NewFont) '应用新字体
x = Picture1.ScaleWidth / 2
y = Picture1.ScaleHeight / 2 '显示文本的位置
Throw = TextOut(Me.Picture1.hdc, x, y, Me.txtShow.Text, Len(Me.txtShow.Text)) '显示文本
NewFont = SelectObject(Me.Picture1.hdc, OldFont) '选择旧字体
Throw = DeleteObject(NewFont) '删除字体
End Sub
Private Sub Command2_Click()
Me.Picture1.Cls
End Sub
Private Sub Form_Load()
RF.lfHeight = 50 '设置字体高度
RF.lfWidth = 10 '设置字体平均宽度
RF.lfEscapement = 0 '设置文本倾斜度
RF.lfWeight = 400 '设置字体的轻重
RF.lfItalic = 0 '设置字体不倾斜
RF.lfUnderline = 0 '字体不加下划线
RF.lfStrikeOut = 0 '字体不加删除线
RF.lfOutPrecision = 0 '设置输出进度
RF.lfClipPrecision = 0 '设置剪辑精度
RF.lfQuality = 0 '设置输出质量
RF.lfPitchAndFamily = 0 '设置字体的字距和字体族
RF.lfCharSet = 0 '设置字符集
RF.lfFaceName = "Arial" + Chr(0) '设置字体名字
Me.txtEscapement.Text = RF.lfEscapement
Me.txtHeight.Text = RF.lfHeight
Me.txtWeight.Text = RF.lfWeight
Me.txtWidth.Text = RF.lfWidth
'设置文本框显示文本
End Sub
运行效果如下图
