基于VB的文字动画特效代码Private Sub TextEffect( _
ByVal sText As String, _
ByVal lX As Long, ByVal lY As Long, _
Optional ByVal bLoop As Boolean = False, _
Optional ByVal lStartSpacing As Long = 128, _
Optional ByVal lEndSpacing As Long = -1, _
Optional ByVal oColor As OLE_COLOR = vbWindowText _
)
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim lHDC As Long
Dim hBrush As Long '定义各种变量
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean
iDir = -1
i = lStartSpacing '为变量赋值
tR.left = lX: tR.tOp = lY: tR.Right = lX: tR.Bottom = lY
OleTranslateColor oColor, 0, lCOlor
hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
lLen = Len(sText)
lHDC = Me.hdc
SetTextColor lHDC, lCOlor '设置文字颜色
bDoIt = True
Do While m_bDoEffect And bDoIt
lTime = timeGetTime
If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
bSlowDown = True
iDir = 1
lIter = (i + 4)
End If
If (i > 128) Then iDir = -1
If Not (bLoop) And iDir = 1 Then
If (i = lEndSpacing) Then
bDoIt = False
Else
lIter = lIter - 1
If (lIter <= 0) Then
i = i + iDir
lIter = (i + 4)
End If
End If
Else
i = i + iDir
End If
FillRect lHDC, tR, hBrush '调用FillRect函数
x = 32 - (i * lLen)
SetTextCharacterExtra lHDC, i
DrawText lHDC, sText, lLen, tR, DT_CALCRECT '调用API函数DrawText
tR.Right = tR.Right + 4
If (tR.Right > Me.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = Me.ScaleWidth \ Screen.TwipsPerPixelX
DrawText lHDC, sText, lLen, tR, DT_LEFT
Me.Refresh '窗体刷新
Do
DoEvents '后台运行
Loop While (timeGetTime - lTime) < 20
Loop
DeleteObject hBrush
End Sub
