基于VB的文字动画特效

基于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