在VB中利用Windows的API函数可以实现很多的VB无法实现的扩展功能，下面的程序介绍的是如何通过调用Windows中的API函数实现文本旋转显示的特级效果。
首先建立一个工程文件，然后选菜单中的Project
| Add Class Module 加入一个新的类文件，并将这个类的Name属性改变为APIFont，然后在类的代码窗口中加入以下的代码：
Option Explicit
Private Declare Function
SelectClipRgn Lib “gdi32”(ByVal hdc As Long, ByVal hRgn As Long) As
Long
Private Declare Function CreateRectRgn Lib “gdi32”(ByVal X1 As
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As
Long
Private Declare Function SetTextColor Lib “gdi32”(ByVal hdc As
Long, ByVal crColor As Long) As Long
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 Declare
Function SetTextAlign Lib “gdi32”(ByVal hdc As Long, ByVal wFlags As Long)
As Long
Private Type RECT
Left As Long
Top As
Long
Right As Long
Bottom As Long
End
Type
Private Const TA_LEFT = 0
Private Const TA_RIGHT =
2
Private Const TA_CENTER = 6
Private Const TA_TOP =
0
Private Const TA_BOTTOM = 8
Private Const TA_BASELINE =
24
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 m_LF
As LOGFONT
Private NewFont As Long
Private OrgFont As
Long
Public Sub CharPlace(o As Object, txt＄, X, Y)
Dim Throw As
Long
Dim hregion As Long
Dim R As RECT
R.Left =
X
R.Right = X ＋ o.TextWidth(txt＄) ＊ 2
R.Top = Y
R.Bottom
= Y ＋ o.TextHeight(txt＄) ＊ 2
hregion = CreateRectRgn(R.Left,
R.Top, R.Right, R.Bottom)
Throw = SelectClipRgn(o.hdc,
hregion)
Throw = TextOut(o.hdc, X, Y, txt＄, Len(txt＄))
DeleteObject (hregion)
End Sub
Public Sub SetAlign(o As Object,
Top, BaseLine, Bottom, Left, Center, Right)
Dim Vert As Long
Dim Horz As Long
If Top = True Then Vert = TA_TOP
If
BaseLine = True Then Vert = TA_BASELINE
If Bottom = True Then Vert =
TA_BOTTOM
If Left = True Then Horz = TA_LEFT
If Center = True
Then Horz = TA_CENTER
If Right = True Then Horz = TA_RIGHT
SetTextAlign o.hdc, Vert Or Horz
End Sub
Public Sub setcolor(o
As Object, Cvalue As Long)
Dim Throw As Long
Throw =
SetTextColor(o.hdc, Cvalue)
End Sub
Public Sub SelectOrg(o As
Object)
Dim Throw As Long
NewFont = SelectObject(o.hdc,
OrgFont)
Throw = DeleteObject(NewFont)
End Sub
Public Sub
SelectFont(o As Object)
NewFont = CreateFontIndirect(m_LF)
OrgFont = SelectObject(o.hdc, NewFont)
End Sub
Public Sub
FontOut(text＄, o As Control, XX, YY)
Dim Throw As Long
Throw = TextOut(o.hdc, XX, YY, text＄, Len(text＄))
End
Sub
Public Property Get Width() As Long
Width =
m_LF.lfWidth
End Property
Public Property Let Width(ByVal
W As Long)
m_LF.lfWidth = W
End Property
Public
Property Get Height() As Long
Height = m_LF.lfHeight
End
Property
Public Property Let Height(ByVal vNewValue As
Long)
m_LF.lfHeight = vNewValue
End Property
Public
Property Get Escapement() As Long
Escapement =
m_LF.lfEscapement
End Property
Public Property Let
Escapement(ByVal vNewValue As Long)
m_LF.lfEscapement =
vNewValue
End Property
Public Property Get Weight() As
Long
Weight = m_LF.lfWeight
End Property
Public
Property Let Weight(ByVal vNewValue As Long)
m_LF.lfWeight =
vNewValue
End Property
Public Property Get Italic() As
Byte
Italic = m_LF.lfItalic
End Property
Public
Property Let Italic(ByVal vNewValue As Byte)
m_LF.lfItalic =
vNewValue
End Property
Public Property Get UnderLine() As
Byte
UnderLine = m_LF.lfUnderline
End
Property
Public Property Let UnderLine(ByVal vNewValue As
Byte)
m_LF.lfUnderline = vNewValue
End
Property
Public Property Get StrikeOut() As Byte
StrikeOut = m_LF.lfStrikeOut
End Property
Public Property
Let StrikeOut(ByVal vNewValue As Byte)
m_LF.lfStrikeOut =
vNewValue
End Property
Public Property Get FaceName() As
String
FaceName = m_LF.lfFaceName
End
Property
Public Property Let FaceName(ByVal vNewValue As
String)
m_LF.lfFaceName = vNewValue
End
Property
Private Sub Class_Initialize()
m_LF.lfHeight =
30
m_LF.lfWidth = 10
m_LF.lfEscapement = 0
m_LF.lfWeight
= 400
m_LF.lfItalic = 0
m_LF.lfUnderline = 0
m_LF.lfStrikeOut = 0
m_LF.lfOutPrecision = 0
m_LF.lfClipPrecision = 0
m_LF.lfQuality = 0
m_LF.lfPitchAndFamily = 0
m_LF.lfCharSet = 0
m_LF.lfFaceName =
"Arial" ＋ Chr(0)
End
Sub
在工程文件的Form1中加入一个PictureBox和一个CommandButton控件，然后在Form1的代码窗口中加入以下的代码：
Option Explicit
Dim AF As
APIFont
Dim X, Y As Integer
Private Sub
Command1_Click()
Dim I As Integer
Set AF = Nothing
Set AF = New APIFont
Picture2.Cls
For I = 0 To 3600
Step 360
AF.Escapement = I
AF.SelectFont Picture2
X =
Picture2.ScaleWidth / 2
Y = Picture2.ScaleHeight /
2
在字符串后面要加入7个空格
AF.FontOut “电脑商情报第42期 ”, Picture2, X, Y
AF.SelectOrg Picture2
Next I
End Sub
Private Sub
Form_Load()
Picture2.ScaleMode = 3
End Sub
运行程序，点击Form上的Command1按钮，在窗口的图片框就会出现旋转的文本显示，程序的效果如图所示：
值得注意的问题是，由于Windows的动态连接库的中英文版本的关系，在一些系统中显示中文可能会有一些问题，大家可能看到，上面程序中的语句：AF.FontOut
“脑商情报第42期”，Picture2, X,
Y中的字符串后面有7个空格，这是对于“电脑商情报第42期”中的7个中文字符，中文系统计算的是7个字符，但是实际它们占据的是14个字节的空间，所以在输出时要在后面添加7个空格做“替身”。上面的程序在中文Win98，VB6下运行通过。
156
|
