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
![]()