SCROLL

USUARIO.EXCLUIDOS 11/03/2004 01:16:26
#14913 Resposta escolhida

Tente isso.

'Code by Carles (carles_pv@terra.es)

'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 Sub

CancelOpen:
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