Código
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 'Aqui esta poniendo las propiedades pasa que se pueda With Objeto_Scroll ' escibir en el picture o form .ScaleMode = vbPixels 'modo pixel .AutoRedraw = True 'para que se actualizae el pintado .ForeColor = Color_Fuente 'color de fuente .FontSize = 16 'Tamano de la letra End With 'Aqui lo que hace es una primera llamada a la api para comprobar ' que puede pintar el texto sobre el objeto dado Ret = DrawText(Objeto_Scroll.hdc, Texto, -1, ObjetoRect, &H400) 'Si el retorno es 0 entonces no puede pintar correctamente el objeto 'Y por lo tanto sale If Ret = 0 Then MsgBox " Error ", vbCritical: Exit Sub With ObjetoRect 'Configura la 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 'Si no cambias el valor de variable sigue dibujando el texto 'infinitamente While Finalizar = False 'Aqui hace una comprobacion de la velocidad If (GetTickCount() - t_Vel) > Velocidad Then ' Borra el contenido ya pintado en el objeto Objeto_Scroll.Cls ' Dibuja el texto Call DrawText(Objeto_Scroll.hdc, Texto, -1, ObjetoRect, &H1 Or &H10) With ObjetoRect 'Cambia la proxima posicion donde se escribira el texto .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 'Cambia la variable para futuras comprobaciones de velocidad t_Vel = GetTickCount() End If DoEvents Wend End Sub
Salu2, Noele1995