Continuously Scrolling Credits in your About Box

The code...

  Option Explicit
  Dim giLinecount As Integer
  Dim Credits(1 To 20) As String * 20
  Declare Function  SendMessage Lib "USER" (ByVal hWd%, ByVal wMsg%, ByVal wParam%, ByVal lParam&) As Long
  Const EM_LINESCROLL = &H406
  
  Sub Form_Load ()
    Dim i As Integer                              ' Load Array
    Credits(1) =Space$(20)
    Credits(2) = "This demo was"
    Credits(3) = "brought to you by"
    Credits(4) = "the Microsoft Guys &"
    Credits(5) = "Jenton Software"
    Credits(6) = Space$(20)
    For i = 6 To 20
      Credits(i) = Space$(20)
    Next i                                        ' Initialize the Text Box
    Text1 = ""
    For i = 1 To 20
      Text1 = Text1 + Credits(i) & Chr$(13) & Chr$(10)
    Next i                                        ' Initialize the Timer
    Timer1.Interval = 500
  End Sub

  Sub Form_Unload (Cancel As Integer)
    Set Form1 = Nothing
  End Sub

  Function ScrollText& (TextBox As Control, vLines As Integer, hCols As Integer)
    Dim Lines&, Success&                          ' Place values in Low & High Order bytes for Vertical and Horizontal scrolling
    Lines& = CLng(&H10000 * hCols) + vLines       ' Set focus for Text box
    Text1.SetFocus
    Success& = SendMessage(TextBox.hWnd, EM_LINESCROLL, 0, Lines&)
                                                  ' Return no. lines scrolled
    ScrollText& = Success&
  End Function

  Sub Text1_Click ()
    Timer1.Interval = 0
    Unload Me
    End
  End Sub

  Sub Timer1_Timer ()
    Dim r&
    r& = ScrollText(Text1,1,0)
    giLinecount = giLinecount+1
      If giLinecount > 19 Then
        Text1 = Mid$(Text1,  23) & Credits(giLinecount Mod 20 + 1) & Chr$(13) & Chr$(10)
      End If
    End Sub


[HOME] [TABLE OF CONTENTS] [SEARCH]