在VB中建立可旋轉的文本特效
在VB中利用Windows的API函數可以實現很多的VB無法實現的擴展功能，下面的程序介紹的是如何通過調用Windows中的API函數實現文本旋轉顯示的特級效果。
首先建立一個工程文件，然后選菜單中的Project | Add Class Module 加入一個新的類文件，并將這個類的Name屬性改變為APIFont，然后在類的代碼窗口中加入以下的代碼：
在工程文件的Form1中加入一個PictureBox和一個CommandButton控件，然后在Form1的代碼窗口中加入以下的代碼：
在字符串后面要加入7個空格
運行程序，點擊Form上的Command1按鈕，在窗口的圖片框就會出現旋轉的文本顯示，程序的效果如圖所示：
值得注意的問題是，由于Windows的動態連接庫的中英文版本的關系，在一些系統中顯示中文可能會有一些問題，大家可能看到，上面程序中的語句：AF.FontOut “腦商情報第42期”，Picture2, X, Y中的字符串后面有7個空格，這是對于“電腦商情報第42期”中的7個中文字符，中文系統計算的是7個字符，但是實際它們占據的是14個字節的空間，所以在輸出時要在后面添加7個空格做“替身”。上面的程序在中文Win98，VB6下運行通過。
首先建立一個工程文件，然后選菜單中的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下運行通過。