Hiệu ứng Text

Các thủ thuật liên quan đến xử lý chuỗi và thời gian
Post Reply
User avatar
truongphu
VIP
VIP
Posts: 4780
Joined: Sun 04/11/2007 10:57 am
Location: Cam Đức, Khánh hòa
Has thanked: 14 times
Been thanked: 525 times

Hiệu ứng Text

Post by truongphu »

Thủ thuật: Hiệu ứng Text
Tác giả: Sưu tầm từ diễn đàn cũ, không rõ tác giả
Mô tả: Hiệu ứng text, rất cool
Bù cho bài nguyên tố, đã có

Module1:

Code: Select all

Option ExplicitPublic Declare Function timeGetTime Lib "winmm.dll" () As LongPublic Declare Function SetTextCharacterExtra Lib "gdi32" _(ByVal hdc As Long, ByVal nCharExtra As Long) As Long Public Type RECTLeft As LongTop As LongRight As LongBottom As LongEnd Type Public Declare Function OffsetRect Lib "user32" (lpRect _As RECT, ByVal x As Long, ByVal y As Long) As Long Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc _As Long, ByVal crColor As Long) As Long Public Declare Function FillRect Lib "user32" (ByVal hdc As _Long, lpRect As RECT, ByVal hBrush As Long) As Long Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal _crColor As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal _hObject As Long) As Long Public Declare Function GetSysColor Lib "user32" (ByVal _nIndex As Long) As Long Public Const COLOR_BTNFACE = 15 Public 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 Public 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 Public Const DT_BOTTOM = &H8Public Const DT_CALCRECT = &H400Public Const DT_CENTER = &H1Public Const DT_CHARSTREAM = 4Public Const DT_DISPFILE = 6Public Const DT_EXPANDTABS = &H40Public Const DT_EXTERNALLEADING = &H200Public Const DT_INTERNAL = &H1000Public Const DT_LEFT = &H0Public Const DT_METAFILE = 5Public Const DT_NOCLIP = &H100Public Const DT_NOPREFIX = &H800Public Const DT_PLOTTER = 0Public Const DT_RASCAMERA = 3Public Const DT_RASDISPLAY = 1Public Const DT_RASPRINTER = 2Public Const DT_RIGHT = &H2Public Const DT_SINGLELINE = &H20Public Const DT_TABSTOP = &H80Public Const DT_TOP = &H0Public Const DT_VCENTER = &H4Public Const DT_WORDBREAK = &H10 Public Declare Function OleTranslateColor Lib "olepro32.dll" _(ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As LongPublic Const CLR_INVALID = -1 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 = 0, Optional ByVal oColor _As OLE_COLOR = vbWindowText) Dim lhDC As LongDim i As LongDim x As LongDim lLen As LongDim hBrush As LongStatic tR As RECTDim iDir As LongDim bNotFirstTime As BooleanDim lTime As LongDim lIter As LongDim bSlowDown As BooleanDim lCOlor As LongDim bDoIt As Boolean lhDC = obj.hdciDir = -1i = lStartSpacingtR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lYOleTranslateColor oColor, 0, lCOlor hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))lLen = Len(sText) SetTextColor lhDC, lCOlorbDoIt = True Do While bDoItlTime = timeGetTimeIf (i < -3) And Not (bLoop) And Not (bSlowDown) ThenbSlowDown = TrueiDir = 1lIter = (i + 4)End IfIf (i > 128) Then iDir = -1If Not (bLoop) And iDir = 1 ThenIf (i = lEndSpacing) Then' StopbDoIt = FalseElselIter = lIter - 1If (lIter <= 0) Theni = i + iDirlIter = (i + 4)End IfEnd IfElsei = i + iDirEnd If FillRect lhDC, tR, hBrushx = 32 - (i * lLen)SetTextCharacterExtra lhDC, iDrawText lhDC, sText, lLen, tR, DT_CALCRECTtR.Right = tR.Right + 4If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then _tR.Right = obj.ScaleWidth \ Screen.TwipsPerPixelXDrawText lhDC, sText, lLen, tR, DT_LEFTobj.Refresh DoDoEventsIf obj.Visible = False Then Exit SubLoop While (timeGetTime - lTime) < 20 LoopDeleteObject hBrush End Sub
Form1:

Code: Select all

Private Sub Command1_Click()Call TextEffect(Me, "Hieu ung Text ne, Cool hong!", 15, 15, False, 128)End Sub
Attachments
Hieu Ung Text.rar
(6.23 KiB) Downloaded 1285 times
o0o--truongphu--o0o

.........
Ghé thăm:
Chuyện Linh Tinh
Post Reply

Return to “[VB] Chuỗi và Thời gian”