'**************************************
' Name: TextEffect
' Description:The following code will ad
'     d great text effect to your applications
'     . It changes the spacing between the cha
'     racters. By changing spaces, the charact
'     ers 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://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=1069&lngWId;=1'for details.'**************************************

' #VBIDEUtils#**************************
'     **********************************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/Researc
'     hTriangle/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, gre
'     at effects
' *Ex :
' * TextEffect Picture1, "", 12, 12, , 1
'     28, 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/Researc
    '     hTriangle/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 = Fal
    '     se
    ' *Optional ByVal lStartSpacing As Long 
    '     = 128
    ' *Optional ByVal lEndSpacing As Long = 
    '     -1
    ' *Optional ByVal oColor As OLE_COLOR = 
    '     vbWindowText
    ' **************************************
    '     ********************************
    ' * Comments :
    ' *** Kerning describes the spacing betw
    '     een characters when a font is written ou
    '     t.
    ' *** By default, fonts have a preset de
    '     fault kerning, but this very easy to mod
    '     ify
    ' *** under the Win32 API.
    ' *
    ' *** The following (rather unusally nam
    '     ed?) API function is all you need:
    ' *
    ' *** Private Declare Function SetTextCh
    '     aracterExtra Lib "gdi32" () (ByVal hdc A
    '     s Long, ByVal nCharExtra As Long) As Lon
    '     g
    ' *
    ' *** By setting nCharExtra to a negativ
    '     e value, you bring the characters closer
    '     together,
    ' *** and by setting to a positive value
    '     s the characters space out.
    ' *** It works with VB's print methods t
    '     oo.
    ' *
    ' *
    ' **************************************
    '     ********************************
    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