小鸟提问：如何实现文本自动卷动？

Question

用timer控件,一定时间触发滚动条滚动一次!

Answer 1

--回复得分 25 --
在 form 的声明部分：
Const EM_LINESCROLL = &HB6
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
然后使用一个timer定时触发下面的函数：
SendMessageLong Richtextbox.hwnd, EM_LINESCROLL, 0, 1
这里的1如果改成2可以向下滚2行，类推。改成负的可以向上滚动。--回复得分 0 --
我想textstar是不是想让RICHTEXTBOX自动往上滚屏（指满屏了以后，自动往上滚)，如果是的，应该是这样实现：'添加你的文本信息
txtDialog.Text = txtDialog.Text + vbCrLf + YourMsg'把选择的焦点设置为文本的最后一行(实现自动滚屏)
txtDialog.SelStart = Len(txtDialog.Text)'去掉文本后面的回车换行符，以求更加美观
If Mid(txtDialog.Text, 1, Len(vbCrLf)) = vbCrLf Then
   txtDialog.Text = Mid(txtDialog.Text, Len(vbCrLf) + 1, Len(txtDialog.Text))
End If注：txtDialog是RichTextBox控件的名字。
(以上仅供参考，如有不妥，请多多指教）  郭子--回复得分 0 --
我以前写的过程，应该可以帮忙：
'--------------------------------------------------------------------
'显示彩色文字的函数
'Public Sub richShowText(ByVal Control As Object, ByVal StrS As String, ByVal Color As Long)
'--- Control    用于操作的控件名
'--- Str        输出文本内容
'--- Color      输出颜色
'--- Enter      输出是否换行
'--------------------------------------------------------------------------------------
Public Sub richShowText(ByVal Control As Object, ByVal StrS As String, Optional Color As Long = 0, Optional Enter As Boolean = True)
On Error Resume Next
    Control.SelColor = Color
    Control.SelText = "(" & Time & ") " & StrS
    Control.UpTo vbEOF
    If Enter Then Control.SelText = vbCrLf
End Sub--回复得分 25 --
SendMessage Text1.hwnd, EM_LINESCROLL, 0, ByVal -1
这里的-1以是向下，如果是1则向上(指文字滚动的方向)，看你希望它怎么滚动(看字要向上还是要向下)。这个只有在文本满一屏以上才行，就是说这个功能和你按滚动条一样。--回复得分 0 --
唉！直接设SelStart算了。

Answer 2

2:pp616(平平)
就是想实现文本框中（TextBox或RichTextBox）的文本自下而上循环卷动。
就像网页上的那种卷动。

Answer 3

2:jisheng(古朴的狼)　
你的代码可真多啊!放到我们可以够得着的地方好吗?

Answer 4

小鸟又笨了：不知道用一个PictureBox+Label是不是比代码浪费资源？呵呵……多蠢的问题：）

Answer 5

PictureBox+Label比用文本滚动平滑~

Answer 6

譬如文本有100行
你设个timer控件，每单位时间显示他的N-M行不就行了？或者如果有滚动条，你让滚动条每单位时间滚动多少VALUE不就得了？或者调整他的SELSTART属性不就行了？

Answer 7

在窗体上放上两个option，一个richtextbox，一个timer，试试吧，根据鼠标的位置不同，快慢也不同
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Const WM_VSCROLL = &H115
Const SB_LINEDOWN = 1
Const SB_LINEUP = 0
Private Const SB_THUMBPOSITION = 4
Dim DirectoryUoDown As StringPrivate Sub Option1_Click()
  Timer1.Enabled = True
End SubPrivate Sub Option2_Click()
  Timer1.Enabled = False
End SubPrivate Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim H As Integer
  Dim i As Integer
  i = 10
  H = RichTextBox1.Height / 2
  If y < H Then
    DirectoryUoDown = "up"
    H = H / 10
    Timer1.Interval = ((y / H) + 1) * 30
  Else
    DirectoryUoDown = "down"
    H = H / 10
    Timer1.Interval = (((RichTextBox1.Height - y) / H) + 1) * 30
    'Timer1.Interval = (y - H) * 10
  End If
  MouseOut RichTextBox1, x, y
End SubPrivate Sub Timer1_Timer()
  SendMsg RichTextBox1, WM_VSCROLL, DirectoryUoDown
  
End SubPrivate Sub SendMsg(Rch As RichTextBox, WM As String, D As String)
  If D = "up" Then SendMessage Rch.hwnd, WM_VSCROLL, SB_LINEUP, 0
  If D = "down" Then SendMessage Rch.hwnd, WM_VSCROLL, SB_LINEDOWN, 0
End SubPrivate Sub MouseOut(RC As Variant, x As Single, y As Single)
  Dim MouseOut As Boolean
  If (x >= 0) And (x <= RC.Width) And (y >= 0) And (y < RC.Height) Then
    MouseOut = False
  Else
    MouseOut = True
  End If
  If Not MouseOut Then
    SetCapture (RC.hwnd)
    If Option1.Value Then Timer1.Enabled = True
  Else
    ReleaseCapture
    Timer1.Enabled = False
  End IfEnd Sub

Answer 8

忘说了，程序运行后要单击option1，当option1被选中文本就开始移动（根据鼠标位置，把鼠标放在richtextbox中上下移动就可以看出效果了）

Answer 9

2:xzm2000(不是云)这个跟我想的不太一样，我想要的是自动滚屏，不过也挺有用的啊：）