在用户窗体中创建垂直滚动文本

Question

尝试在 VBA Excel 中创建用户窗体，其中文本可以垂直滚动以显示我在 Excel 的特定单元格中添加的内容。我使用的是 2016 版本的 excel。

从谷歌获取了VBA代码，如下所示：

Private Sub UserForm_Initialize()
    Me.Label1.Caption = Sheet1.Range("b4").Value
    
    Me.Label2.Caption = Sheet1.Range("E9").Value & _
    vbCrLf & vbCrLf & Sheet1.Range("E10").Value & _
    vbCrLf & vbCrLf & Sheet1.Range("E11").Value & _
    vbCrLf & vbCrLf & Sheet1.Range("E12").Value & _
    vbCrLf & vbCrLf & Sheet1.Range("E13").Value
    
    Me.Label2.Top = Me.Height
End Sub

当我评论这部分代码时，这部分代码运行良好。

代码的第二部分是垂直滚动，其中发生滚动，但是必须重复滚动的循环不起作用。代码如下：

Me.Label2.Top = Me.Height

尝试在 VBA Excel 中创建用户窗体，其中文本可以垂直滚动以显示我在 Excel 的特定单元格中添加的内容。我使用的是 2016 版本的 excel。

代码的第二部分是垂直滚动，其中滚动发生，但是必须重复滚动的循环，这是不起作用的，或者其他选项是停止用户表单上的垂直滚动。

如果任何人都可以帮助编写代码或任何其他方式将非常感激。

Answer 1

水平滚动（像自动收报机一样）

将其粘贴到用户表单代码模块中。

Sub verti_scroll()
    Call UserForm1.Show(vbModeless)

    Do
        i = UserForm1.Height - 42
        Do
            i = i - 1
            DoEvents
            For a = i To 5000000
                a = a + 1
            Next
            UserForm1.Label2.Top = i
            If i = 100 Then GoTo Nextz
        Loop
Nextz:
        x = x + 1
        If x = 2 Then GoTo nextx
    Loop
nextx:
End Sub

在行动

垂直滚动（如电影片尾字幕）

垂直滚动与水平滚动略有不同。

相应地安排您的表格。

向用户窗体添加一个框架控件。这将充当滚动文本的容器。

1. 在框架内添加一个标签控件。根据需要设置其属性（字体大小、字体颜色等）。确保标签足够大以显示文本。
类似这样的事情。

用户表单代码模块

Option Explicit

Dim ExitLoop As Boolean

Private Sub UserForm_Activate()
    '~~> Sample scrolling text. Chnage as applicable
    Me.Label1.Caption = "Your scrolling text goes here. "
    ScrollText
End Sub

Private Sub ScrollText()
    Dim text As String
    
    text = Me.Label1.Caption
    
    '~~> Infinite loop to scroll the text
    Do
        '~~> This is required if user tries to close the userform
        If ExitLoop = True Then Exit Do
        
        '~~> Move the first character to the end
        text = Mid(text, 2) & Left(text, 1)
        
        Me.Label1.Caption = text
        
        Wait 0.1
    Loop
End Sub

Private Sub UserForm_Terminate()
    ExitLoop = True
End Sub

Private Sub Wait(ByVal nSec As Double)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

在行动