Make your own free website on Tripod.com

Make Text Animation

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 PictureBox and 1 Command Button to your form. Set the
'Picture Box AutoRedraw property to True.
'Insert this code to the module :

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

'Insert the following code to your form:

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
Dim i As Long
Dim x As Long
Dim lLen 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
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()
'Replace 'MyText' with the text you want to animate.
'Replace 12,12 with the x and y coordinates, where the text will be displayed.
'Replace '128' with the initial spacing between the text characters.
'Replace '-1' with the final spacing between the text characters.
'Replace 'vbBlue' with the text color (you can put here the hex value of  a color. To
'get the color hex value, choose your desirable color in Form Backcolor property and
'copy & Paste the color value from the BackColor cell).
'You can choose the kind and the size of the font in the Picture Box Font property.
'You can animate the text straight on the form, instead of the Picture Box. To do that
'replace the 'Picture1' below with your form name, and make the same changes in the Form's
'properties as you did with the Picture Box

Call TextEffect(Picture1, "MyText", 12, 12, False, 128, -1, vbBlue)
End Sub

Go Back