TextEffect

' #VBIDEUtils#************************************************************
' * Programmer Name : Waty Thierry
' * Web Site     : www.geocities.com/ResearchTriangle/6311/
' * E-Mail      : [email protected]
' * 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      : [email protected]
  ' * 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 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
      ' 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