长沙 陈锐

在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下运行通过。