CodeItBetter Programming Another VB Programming Blog

'Forms - How to make text on a form scroll upward.
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
    ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
 
'Add a Timer and 2 picture boxes in a control array to a form.
Private Sub Form_Load()
    Dim i&
    Me.AutoRedraw = True
    Me.ScaleMode = vbPixels
    Me.Move Left, Top, 3600, 1900
    Picture1(0).Move 300, 0, 227, 745
    Picture1(1).Move 0, 300, 227, 120
    For i = 0 To 1
        With Picture1(i)
            .AutoRedraw = True
            .ScaleMode = vbPixels
            .BackColor = vbWhite
            .BorderStyle = vbEmpty
            .Visible = False
        End With
    Next i
    DrawMessage
    'Draw background
    Me.FillStyle = vbSolid
    Me.FillColor = vbYellow
    Me.DrawWidth = 3
    Me.Circle (110, 48), 40, vbBlack
    Me.ForeColor = &H30C0C0
    Me.Font.Name = "arial"
    Me.Font.Size = 44
    Me.Font.Bold = True
    PSet (80, 8), Me.BackColor
    Me.Print "@";
    Me.AutoRedraw = False
    Timer1.Interval = 30
End Sub
 
Private Sub DrawMessage()
    Dim p As PictureBox
    Dim y&, m$, midline&
    Set p = Picture1(0)
    With p
        midline = .ScaleWidth \ 2
        .CurrentY = 128
        .Font.Bold = True
        For y = 0 To 30
            If (y Mod 8) = 0 Then
                p.Print
                If y = 16 Then .CurrentY = .CurrentY + 40
            End If
            m = RndMsg()
            .CurrentX = midline - (.TextWidth(m)) \ 2
            p.Print m
        Next
        .Font.Size = .Font.Size + 8
        .Font.Bold = True
        m = "Some Random Text"
        y = midline - .TextWidth(m) \ 2
        p.PSet (y, 104), .BackColor
        p.Print m
        Mid(m, 1, 4) = "More"
        p.PSet (y, 380), .BackColor
        p.Print m
        .Font.Size = .Font.Size + 8
        .Font.Bold = True
    End With
    Set p = Nothing
End Sub
 
Private Function RndMsg() As String
    Dim i&
    RndMsg = String((Rnd * 5) * 5 + 4, " ")
    For i = 1 To Len(RndMsg)
        If Rnd < 0.8 Then
            Mid(RndMsg, i, 1) =  chr ( Rnd * 25 + 65)
        Else
            Mid(RndMsg, i, 1) =  chr ( 32)
        End If
    Next
End Function
 
Private Sub Form_Unload(Cancel As Integer)
    Timer1.Enabled = False
End Sub
 
Private Sub Timer1_Timer()
    Static Scroll&
    Dim r&
    Scroll = (Scroll + 1) Mod 630
    'Get the backgroud
    AutoRedraw = True
    r = BitBlt(Picture1(1).hDC, 0, 0, 227, 120, Me.hDC, 0, 0, vbSrcCopy)
    'Add the text
    r = BitBlt(Picture1(1).hDC, 0, 0, 230, 100, Picture1(0).hDC, 0, Scroll, vbSrcAnd)
    'Move to display
    AutoRedraw = False
    r = BitBlt(Me.hDC, 0, 0, 227, 120, Picture1(1).hDC, 0, 0, vbSrcCopy)
End Sub