TextEffect

				
'**************************************
' Name: TextEffect
' Description:The following code will add great text effect to your applications. It changes the spacing between the characters. By changing spaces, the characters move on the screen.
' By: Waty Thierry
'
' Inputs: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
'
' Assumes:Nothing.
Ex :
TextEffect Picture1, "", 12, 12, , 128, 0, RGB(&H80, 0, 0)
TextEffect Me, "", 12, 12, , 128, 0, RGB(&H80, 0, 0)
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=1069&lngWId=1'for details.'**************************************

' #VBIDEUtils#************************************************************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail: waty.thierry@usa.net
' * Date : 24/09/98
' * Time : 15:38
' * Module Name : TextEffect_Module
' * Module Filename : TextEffect.bas
' **********************************************************************
' * Comments : Try this text effect, great effects
' *Ex :
' * TextEffect Picture1, "", 12, 12, , 128, 0, RGB(&H80, 0, 0)
' * TextEffect Me, "", 12, 12, , 128, 0, RGB(&H80, 0, 0)
' *
' *
' **********************************************************************
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)
' #VBIDEUtils#************************************************************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail: waty.thierry@usa.net
' * Date : 24/09/98
' * Time : 15:39
' * Module Name : TextEffect_Module
' * Module Filename : TextEffect.bas
' * Procedure Name: TextEffect
' * Parameters:
' *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
' **********************************************************************
' * Comments :
' *** Kerning describes the spacing between characters when a font is written out.
' *** By default, fonts have a preset default kerning, but this very easy to modify
' *** under the Win32 API.
' *
' *** The following (rather unusally named?) API function is all you need:
' *
' *** Private Declare Function SetTextCharacterExtra Lib "gdi32" () (ByVal hdc As Long, ByVal nCharExtra As Long) As Long
' *
' *** By setting nCharExtra to a negative value, you bring the characters closer together,
' *** and by setting to a positive values the characters space out.
' *** It works with VB's print methods too.
' *
' *
' **********************************************************************
Dim lhDC As Long
Dim iAs Long
Dim xAs Long
Dim lLen As Long
Dim hBrushAs Long
Static tRAs RECT
Dim iDir As Long
Dim bNotFirstTimeAs Boolean
Dim lTimeAs Long
Dim lIterAs Long
Dim bSlowDownAs Boolean
Dim lCOlorAs Long
Dim bDoItAs 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
' Stop
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