如何做滚动的字幕

timmer控件加  循环啊。
以下代码绝对经典，就是你这5分有点对不起这代码了，呵呵不过解决问题第一嘛
'Code by Carles ([email protected])'This example requires the following controls on a form:
' - PictureBox (name=Picture1, ClipControls=False)
' - TextBox (name=Text1)
' - CheckBox (name=Check1)
' - Three command buttons (Command1, Command2 and Command3)
' - A Common Dialog Box (CommonDialog1)'*** In a form
' -----------------------------------------------------
' S C R O L L E R
' -----------------------------------------------------
' Note:
' Be sure that PictureBox font is same as TextBox font!
' ... and width.
' Set TextBox Multiline = True
' -----------------------------------------------------
Private TextLine() As String    'Text lines array
Private Scrolling As Boolean    'Scroll flag
Private Alignment As Long       'Text alignment
Private t As Long               'Timer counter (frame delay)
Private Index As Long           'Actual line index
Private RText As RECT           'Rectangle into each new text line will be drawed
Private RClip As RECT           'Rectangle to scroll up
Private RUpdate As RECT         'Rectangle to update (not used)
Private Sub Form_Load()
       'Locate and resize controls
        Me.Caption = "Scroller up"
        Me.ScaleMode = vbPixels
        Me.Move Me.Left, Me.Top, Screen.TwipsPerPixelX * 425, Screen.TwipsPerPixelX * 400
        Picture1.ScaleMode = vbPixels
        Picture1.Move 10, 10, 400, 300
        Picture1.AutoRedraw = True
        Text1.Move 10, 10, 400
        Text1.Visible = False
        Command1.Caption = "&Load txt file..."
        Command1.Move 10, 320, 100, 25
        Command2.Caption = "&Start"
        Command2.Move 200, 320, 100, 25
        Command3.Caption = "S&top"
        Command3.Move 310, 320, 100, 25
        Check1.Caption = "L&oop"
        Check1.Move 200, 350
        With Picture1
            'Set rectangles
             SetRect RClip, 0, 1, _
                           .ScaleWidth, .ScaleHeight
             SetRect RText, 0, .ScaleHeight, _
                           .ScaleWidth, .ScaleHeight + .TextHeight("")
        End With
       'Center text (&H0 = Left, &H2 = Right)
        Alignment = &H1
End Sub
Private Sub Command2_Click()
            If Trim(Text1) = "" Then
               MsgBox "Nothing to scroll", vbInformation, "Scroll"
               Exit Sub
            End If
           'Start scroll
            Command1.Enabled = False
            Scrolling = True
            Index = 0
            Call Scroll
End Sub
Private Sub Command3_Click()
            Scrolling = False
            Command2.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
            Scrolling = False '!
            End
End Sub
Private Sub Scroll()
        Dim txt As String 'Text to be drawed
        With Picture1
            Do
               'Periodic frames
                If GetTickCount - t > 25 Then 'Set your delay here [ms]
                  'Reset timer counter
                   t = GetTickCount
                  'Line ( + spacing ) totaly scrolled ?
                   If RText.Bottom < .ScaleHeight Then
                     'Move down Text area out scroll area...
                      OffsetRect RText, 0, .TextHeight("") ' + space between lines [Pixels]
                     'Get new line
                      If Alignment = &H1 Then
                        'If alignment = Center, remove spaces
                         txt = Trim(TextLine(Index))
                      Else
                        'Case else, preserve them
                         txt = TextLine(Index)
                      End If
                     'Source line counter...
                      Index = Index + 1
                   End If
                  'Draw text
                   DrawText .hdc, txt, Len(txt), RText, Alignment
                  'Move up one pixel Text area
                   OffsetRect RText, 0, -1
                  'Finaly, scroll up (1 pixel)...
                   ScrollDC .hdc, 0, -1, RClip, RClip, 0, RUpdate
                  '...and draw a bottom line to prevent... (well, don't draw it and see what happens)
                   Picture1.Line (0, .ScaleHeight - 1)-(.ScaleWidth, .ScaleHeight - 1), .BackColor
                  '(Refresh doesn't needed: any own PictureBox draw method calls Refresh method)
                 End If
                 DoEvents
            Loop Until Scrolling = False Or Index > UBound(TextLine)
        End With
        If Check1 And Scrolling Then Command2 = True
        Command1.Enabled = True
End Sub
Private Sub Command1_Click()
   'Choose file...
    CommonDialog1.Filter = "Text files (*.txt)|*.txt"
    CommonDialog1.DefaultExt = "*.txt"
    CommonDialog1.Flags = cdlOFNHideReadOnly Or _
                         cdlOFNPathMustExist Or _
                         cdlOFNOverwritePrompt Or _
                         cdlOFNNoReadOnlyReturn
    CommonDialog1.DialogTitle = "Select a file"
    CommonDialog1.CancelError = True
    On Error GoTo CancelOpen
    CommonDialog1.ShowOpen
    DoEvents
    MousePointer = vbHourglass
   'Load selected file...
    Dim srcFile As String
    Dim txtLine As String
    Dim FF As Integer
    FF = FreeFile
    Open (CommonDialog1.FileName) For Input As #FF
    While Not EOF(FF)
          Line Input #FF, txtLine
          srcFile = srcFile & txtLine & vbCrLf
    Wend
    Close #FF
   'srcFile is passed to srcTextBox to set correct line breaks
    Text1 = srcFile
    SendMessage Text1.hwnd, EM_FMTLINES, True, 0  'Enables line adjusment
    TextLine() = Split(Text1, vbCrLf)
    SendMessage Text1.hwnd, EM_FMTLINES, False, 0 'Disables line adjusment
    Picture1.Cls
    MousePointer = vbCustom
    Exit SubCancelOpen:
    If Err.Number <> 7 Then Exit Sub
    MousePointer = vbCustom
    MsgBox "Unable to load file." & vbNewLine & vbNewLine & _
           "Probably size exceeds TextBox maximum lenght (64Kb)", _
            vbCritical, "Error"
End Sub'*** In a module
Option Explicit
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Function SetRect Lib "user32" _
                (lpRect As RECT, _
                 ByVal X1 As Long, ByVal Y1 As Long, _
                 ByVal X2 As Long, ByVal Y2 As Long) As Long

Declare Function OffsetRect Lib "user32" _
                (lpRect As RECT, _
                 ByVal X As Long, _
                 ByVal Y As Long) As Long
Declare Function ScrollDC Lib "user32" _
                (ByVal hdc As Long, _
                 ByVal dx As Long, ByVal dy As Long, _
                 lprcScroll As RECT, _
                 lprcClip As RECT, _
                 ByVal hrgnUpdate As Long, _
                 lprcUpdate As RECT) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" _
                (ByVal hdc As Long, _
                 ByVal lpStr As String, _
                 ByVal nCount As Long, _
                 lpRect As RECT, _
                 ByVal wFormat As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                (ByVal hwnd As Long, _
                 ByVal wMsg As Long, _
                 ByVal wParam As Long, lParam As Any) As Long
Public Const EM_FMTLINES = &HC8
Public Type RECT
            Left As Long
            Top As Long
            Right As Long
            Bottom As Long
End Type
Private Sub Timer1_Timer()
Label1.Left = Label1.Left + 50
Label2.Left = Label2.Left + 50
If Label1.Left >= 4800 Then
Label1.Left = -4800
End If
If Label2.Left >= 4800 Then
Label2.Left = 4800
End If
End SubPrivate Sub Form_Load()
Label2.Left = -4800
Label2.Left = 0
End Sub

调试易

如何做滚动的字幕

解决方案 »