Home > How-To Library > Forms

How to make text on a form scroll upward.

****************************************************************
*       © 2007 CodeItBetter http://www.codeitbetter.com        *
*          This notice MUST stay intact for legal use          *
****************************************************************

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

If you would like to submit your code here please us. Do not forget to mention your name. We are always thankful to each and everyone of you who submitted their code here.