Помогите, пожалуйста, господа!!!

[Salte]

Соотечественники!
Вот какую задачку я поставил перед собой: необходимо иметь либо RichTextbox, либо просто TextBox, либо Label; но задача состоит в том, чтобы при запуске проги в них загружался некий текст (это элементарно), потом всё поле данного контрола медленно прокручивалось до конца текста. Вот именнно прокрутка мне и не удаётся. Вроде бы количество строк через АПИ могу подсчитать... а вот прокрутку никак родить не могу.
Нижайше прошу, если кто знает решение, подскажите, плиз!

моё: administrator@saimaalines.ru

[Space-akg]

Я передаю в оригинале , то, что сам как-то хотел сделать и нашел этот совет (не помню где)

Автоскролинг текста.
Данный пример покажет, как можно организовать автоскролинг элемента RichTextBox.
Для проверки выполнения кода вам надо добавить на форму элементы RichTextBox, Picture и CommandButton. Не забудьте указать правильную ссылку на файл mydoc.rtf


Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const SIF_RANGE = &H1
Const SB_VERT = 1

Dim lHeight As Long, OnePixel As Long
Dim S As SCROLLINFO
Private Sub Command1_Click()
Do
DoEvents
ScrollUp 50
Loop
End Sub

Private Sub Form_Load()
rtb1(0).LoadFile App.Path & "\mydoc.rtf", rtfRTF
Picture1.Move rtb1(0).Left, rtb1(0).Top, rtb1(0).Width, rtb1(0).Height
Set rtb1(0).Container = Picture1
OnePixel = Screen.TwipsPerPixelY
S.cbSize = Len(S)
S.fMask = SIF_RANGE
Do
Call GetScrollInfo(rtb1(0).hwnd, SB_VERT, S)
If S.nMax = 0 Then Exit Do
lHeight = S.nMax * OnePixel
rtb1(0).Height = lHeight
Loop
If lHeight = 0 Then lHeight = rtb1(0).Height
Text1 = lHeight / OnePixel
rtb1(0).Move 0, 0
Load rtb1(1)
rtb1(1).Visible = False
End Sub

Private Sub ScrollUp(delay As Long)
Sleep delay
With rtb1(0)
.Top = .Top - OnePixel
If .Top + .Height = 0 Then
.Move 0, 0
rtb1(1).Visible = False
End If
If .Top + .Height <= Picture1.Height Then
rtb1(1).Top = .Top + .Height
rtb1(1).Visible = True
End If
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

[Salte]

Пардоньте, но причём тут Picture???

Неужели нет более простого решения, вроде помещения невидимого Слайдера и чего-то подобного:

Slider1.Value=RichTextBox1.SelIndent*Slider1.Max/Slider1.Value ???

[alibek]

Код: Выделить всё

'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


[Salte]

Алибек!!! Драгоценный ты человечище!!!

Огромное тебе ПАСИБКИ!

Только одно: если это твоё - позволь, я его доработаю под мои задачи, ладно?

С искренним уважением и благодарностью...

[alibek]

Всегда пожалуйста Только это не мое

[Salte]

Всё равно, драгоценный, большое тебе человеческое спасибо!!!
Дай тебе Бог здоровья и удачи!!!