在VB中建立可旋转的文本特效

在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

标签：

版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有