UNKNOWN '************************************** 'Windows API/Global Declarations for :Te ' xtEffect '************************************** ' #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) ' * ' * ' ************************************** ' ******************************** Option Explicit Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Declare Function SetTextCharacterExtra Lib "GDI32" (ByVal hDC As Long, ByVal nCharExtra As Long) As Long Private Type RECT LeftAs Long TopAs Long Right As Long Bottom As Long End Type Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function SetTextColor Lib "GDI32" (ByVal hDC As Long, ByVal crColor As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function CreateSolidBrush Lib "GDI32" (ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const COLOR_BTNFACE = 15 Private 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 Private 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 Private Const DT_BOTTOM = &H8; Private Const DT_CALCRECT = &H400; Private Const DT_CENTER = &H1; Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP Private Const DT_DISPFILE = 6' Display-file Private Const DT_EXPANDTABS = &H40; Private Const DT_EXTERNALLEADING = &H200; Private Const DT_INTERNAL = &H1000; Private Const DT_LEFT = &H0; Private Const DT_METAFILE = 5' Metafile, VDM Private Const DT_NOCLIP = &H100; Private Const DT_NOPREFIX = &H800; Private Const DT_PLOTTER = 0 ' Vector plotter Private Const DT_RASCAMERA = 3' Raster camera Private Const DT_RASDISPLAY = 1 ' Raster display Private Const DT_RASPRINTER = 2 ' Raster printer Private Const DT_RIGHT = &H2; Private Const DT_SINGLELINE = &H20; Private Const DT_TABSTOP = &H80; Private Const DT_TOP = &H0; Private Const DT_VCENTER = &H4; Private Const DT_WORDBREAK = &H10; Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long Private Const CLR_INVALID = -1 '************************************** ' 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 ' ' Returns:None ' 'Assumes:Nothing. Ex : TextEffect Picture1, "", 12, 12, , 128, 0, RGB(&H80;, 0, 0) TextEffect Me, "", 12, 12, , 128, 0, RGB(&H80;, 0, 0) ' 'Side Effects:None 'This code is copyrighted and has limite ' d warranties. 'Please see http://www.Planet-Source-Cod ' e.com/xq/ASP/txtCodeId.1069/lngWId.1/qx/ ' vb/scripts/ShowCode.htm '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