長沙 陳銳

在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下運行通過。