How to animate the Text
Posted on January 5, 2009
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | 'Graphics - How to animate the Text Option Explicit 'Add a PictureBox, a Command Button to your form and set the Picture Box AutoRedraw property to True. Declare Function timeGetTime Lib "winmm.dll" () As Long Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As Long, ByVal nCharExtra As Long) As Long Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal y As Long) As Long Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Public Const COLOR_BTNFACE = 15 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 Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, _ ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Public Const DT_BOTTOM = &H8 Public Const DT_CALCRECT = &H400 Public Const DT_CENTER = &H1 Public Const DT_CHARSTREAM = 4 Public Const DT_DISPFILE = 6 Public Const DT_EXPANDTABS = &H40 Public Const DT_EXTERNALLEADING = &H200 Public Const DT_INTERNAL = &H1000 Public Const DT_LEFT = &H0 Public Const DT_METAFILE = 5 Public Const DT_NOCLIP = &H100 Public Const DT_NOPREFIX = &H800 Public Const DT_PLOTTER = 0 Public Const DT_RASCAMERA = 3 Public Const DT_RASDISPLAY = 1 Public Const DT_RASPRINTER = 2 Public Const DT_RIGHT = &H2 Public Const DT_SINGLELINE = &H20 Public Const DT_TABSTOP = &H80 Public Const DT_TOP = &H0 Public Const DT_VCENTER = &H4 Public Const DT_WORDBREAK = &H10 Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, _ pccolorref As Long) As Long Public Const CLR_INVALID = -1 Public Sub TextEffect(obj As Object, 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 lhDC As Long, I As Long, X As Long, lLen As Long, hBrush As Long Dim iDir As Long, lTime As Long, lIter As Long, lCOlor As Long Dim bNotFirstTime As Boolean, bSlowDown As Boolean, bDoIt As Boolean Static tR As RECT lhDC = obj.hdc 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) SetTextColor lhDC, lCOlor bDoIt = True Do While 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 X = 32 - (I * lLen) SetTextCharacterExtra lhDC, I DrawText lhDC, sText, lLen, tR, DT_CALCRECT tR.Right = tR.Right + 4 If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = obj.ScaleWidth \ _ Screen.TwipsPerPixelX DrawText lhDC, sText, lLen, tR, DT_LEFT obj.Refresh Do DoEvents If obj.Visible = False Then Exit Sub Loop While (timeGetTime - lTime) < 20 Loop DeleteObject hBrush End Sub Private Sub Command1_Click() Call TextEffect(Picture1, "http://codeitbetter.com", 12, 12, False, 128, -1, vbBlue) End Sub |