Código:
'Declaraciones Api
'------------------------------
'Dibuja el texto
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
' Para el intervalo de tiempo
Private Declare Function GetTickCount Lib "kernel32" () As Long
'Estructura para usar con el api DrawText
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Finalizar As Boolean
Public Sub Comenzar_Scroll(Objeto_Scroll As PictureBox, _
Texto As String, _
Velocidad As Long, _
Color_Fuente As Long)
Dim r_Height_Texto As Long
Dim ObjetoRect As RECT
Dim t_Vel As Long
Dim Ret As Long
'Propiedades para el picture o form
With Objeto_Scroll
.ScaleMode = vbPixels
.AutoRedraw = True
'Cambiar las propiedades de la fuente
.ForeColor = Color_Fuente
.FontSize = 16
End With
Ret = DrawText(Objeto_Scroll.hdc, _
Texto, -1, ObjetoRect, &H400)
If Ret = 0 Then MsgBox " Error ", vbCritical: Exit Sub
With ObjetoRect
'Posición inicial del área donde dibujar el texto
.Top = Objeto_Scroll.ScaleHeight
.Left = 0
.Right = Objeto_Scroll.ScaleWidth
r_Height_Texto = .Bottom
.Bottom = .Bottom + Objeto_Scroll.ScaleHeight
End With
'Esta variable si está en True detiene el scroll
Finalizar = False
While Finalizar = False
If (GetTickCount() - t_Vel) > Velocidad Then
' Borra el contenido
Objeto_Scroll.Cls
' Dibuja el texto
Call DrawText(Objeto_Scroll.hdc, _
Texto, -1, _
ObjetoRect, &H1 Or &H10)
With ObjetoRect
.Top = .Top - 1
.Bottom = .Bottom - 1
' Si llegó arriba de todo comienza de nuevo el scroll _
reseteando los valores top y bottom
If .Top < -(r_Height_Texto) Then
.Top = Objeto_Scroll.ScaleHeight
.Bottom = r_Height_Texto + Objeto_Scroll.ScaleHeight
End If
End With
t_Vel = GetTickCount()
End If
DoEvents
Wend
End Sub
'------------------------------
'Dibuja el texto
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
' Para el intervalo de tiempo
Private Declare Function GetTickCount Lib "kernel32" () As Long
'Estructura para usar con el api DrawText
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Finalizar As Boolean
Public Sub Comenzar_Scroll(Objeto_Scroll As PictureBox, _
Texto As String, _
Velocidad As Long, _
Color_Fuente As Long)
Dim r_Height_Texto As Long
Dim ObjetoRect As RECT
Dim t_Vel As Long
Dim Ret As Long
'Propiedades para el picture o form
With Objeto_Scroll
.ScaleMode = vbPixels
.AutoRedraw = True
'Cambiar las propiedades de la fuente
.ForeColor = Color_Fuente
.FontSize = 16
End With
Ret = DrawText(Objeto_Scroll.hdc, _
Texto, -1, ObjetoRect, &H400)
If Ret = 0 Then MsgBox " Error ", vbCritical: Exit Sub
With ObjetoRect
'Posición inicial del área donde dibujar el texto
.Top = Objeto_Scroll.ScaleHeight
.Left = 0
.Right = Objeto_Scroll.ScaleWidth
r_Height_Texto = .Bottom
.Bottom = .Bottom + Objeto_Scroll.ScaleHeight
End With
'Esta variable si está en True detiene el scroll
Finalizar = False
While Finalizar = False
If (GetTickCount() - t_Vel) > Velocidad Then
' Borra el contenido
Objeto_Scroll.Cls
' Dibuja el texto
Call DrawText(Objeto_Scroll.hdc, _
Texto, -1, _
ObjetoRect, &H1 Or &H10)
With ObjetoRect
.Top = .Top - 1
.Bottom = .Bottom - 1
' Si llegó arriba de todo comienza de nuevo el scroll _
reseteando los valores top y bottom
If .Top < -(r_Height_Texto) Then
.Top = Objeto_Scroll.ScaleHeight
.Bottom = r_Height_Texto + Objeto_Scroll.ScaleHeight
End If
End With
t_Vel = GetTickCount()
End If
DoEvents
Wend
End Sub