TextEffect
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.
AI
สรุปโดย AI: This codebase represents a historical implementation of the logic described in the metadata. Our preservation engine analyzes the structure to provide context for modern developers.
ซอร์สโค้ด
' #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 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
ความคิดเห็นดั้งเดิม (3)
กู้คืนจาก Wayback Machine