在 excel 中平滑运行选取框文本

Question

我正在 Excel 2013 年创建一个 选取框文本。由于 Microsoft Web 浏览器控件在 Excel 2013 年和 2016 年不工作，所以我使用了以下 VBA 代码：

Sub DoMarquee()
    Dim sMarquee As String
    Dim iWidth As Integer 
    Dim iPosition As Integer
    Dim rCell As Range 
    Dim iCurPos As Integer 

    'Set the message to be displayed in this cell
    sMarquee = "This is a scrolling Marquee." 

    'Set the cell width (how many characters you want displayed at once
    iWidth = 10

    'Which cell are we doing this in?
    Set rCell = Sheet1.Range("M2") 

    'determine where we are now with the message. InStr will return the position
    ' of the first character where the current cell value is in the marquee message 
    iCurPos = InStr(1, sMarquee, rCell.Value)

    'If we are position 0, then there is no message, so start over 
    ' otherwise, bump the message to the next characterusing mid 
    If iCurPos = 0 Then 
        'Start it over 
        rCell.Value = Mid(sMarquee, 1, iWidth) Else 
        'bump it
        rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth) 
    End If 

    'Set excel up to run this thing again in a second or two or whatever 
    Application.OnTime Now + TimeValue("00:00:01"), "DoMarquee" 

End Sub

每一秒都在excel反映，有没有办法以毫秒为单位反映，这样可以显示的更流畅一些运行。而且更多的问题是，它只有在完全滚动后才会再次启动。有没有办法让它连续滚动，等待整个文本滚动。

Answer 1

对于亚秒级功能，请使用 API 调用。

Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub DoMarquee()

    Dim sMarquee As String
    Dim iWidth As Long
    Dim iPosition As Long
    Dim rCell As Range
    Dim iCurPos As Long

    sMarquee = "This is a scrolling Marquee."
    iWidth = 10

    Set rCell = Sheet1.Range("M2")

    iCurPos = InStr(1, sMarquee, rCell.Value)

    If iCurPos = 0 Then
        rCell.Value = Mid(sMarquee, 1, iWidth)
    Else
        rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
    End If

    Sleep 100
    Application.Run "DoMarquee"

End Sub

如果在 32 位 机器上，则删除 PtrSafe，因此变为：

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

编辑：

1) 许多用户注意到堆栈外 space 消息与调用频率有关。

@Sorceri 已正确指出您可以 re-work 作为：

Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"

2) 我不知道逐个字母的部分，所以我会向您推荐 his/her 关于将 iWidth 拉入全局变量的答案。

考虑到这一点，您可能希望修改以下内容以考虑@Sorceri 的 iWidth；我有以下超链接版本 2 "fudge"，修改为 out-of-stack，其中包括对 32 v 64 位版本的测试以确保兼容性。有关兼容性的更多信息 here.

版本 2：

Option Explicit

#If Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub DoMarquee()

    Dim sMarquee As String
    Dim iWidth As Long
    Dim iPosition As Long
    Dim rCell As Range
    Dim iCurPos As Long

    sMarquee = "This is a scrolling Marquee."
    iWidth = 10   
    Set rCell = Sheet1.Range("M2")

    rCell.Parent.Hyperlinks.Add Anchor:=rCell, Address:="https://www.google.co.uk/", TextToDisplay:=rCell.Text      
    rCell.Font.ThemeColor = xlThemeColorDark1 
    iCurPos = InStr(1, sMarquee, rCell.Value)

    If iCurPos = 0 Then
        rCell.Value = Mid(sMarquee, 1, iWidth)
        rCell.Hyperlinks(1).TextToDisplay = rCell.Text
        FormatCell rCell
    Else
        rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
        On Error Resume Next
        rCell.Hyperlinks(1).TextToDisplay = rCell.Text
        On Error GoTo 0
        FormatCell rCell
    End If

    Set rCell = Nothing      
    DoEvents
    Sleep 100
    Application.OnTime Now, "DoMarquee"

End Sub

Public Sub FormatCell(ByVal rng As Range)

    With rng.Font
        .Name = "Calibri"
        .Size = 11
        .Underline = xlUnderlineStyleSingle
        .Color = 16711680
    End With

End Sub

Answer 2

我无法从 space 中获取停止堆栈的示例，因为堆栈上有许多对 DoMarquee 方法的调用。另外，我认为字幕是一个字符一个字符地写出来的。所以使用 Application.OnTime 事件来创建选取框。我也把iWidth去掉了，让它成为全局变量。

Option Explicit
Private iWidth As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub DoMarquee()

    Dim sMarquee As String

    Dim iPosition As Long
    Dim rCell As Range
    Dim iCurPos As Long
    Dim txtMarquee As String

    sMarquee = "This is a scrolling Marquee."


    Set rCell = Sheet1.Range("M2")
    'check to see if the cell is empty
    If rCell.Value = "" Then
        'set the current position to 0 and iWidth to 0
        iCurPos = 0
        iWidth = 0
    Else
        'not blank so writing has started.  Get the position of the cell text
        iCurPos = InStr(1, sMarquee, rCell.Value)
    End If


    If iCurPos = 0 Then
        'it is zero so get the first character
        rCell.Value = Mid(sMarquee, iCurPos + 1, 1)
    Else
        If iWidth < 10 Then
            'width is less then ten so we have not written out the max characters,
            'continue until width is 10
            iWidth = iWidth + 1
            rCell.Value = Mid(sMarquee, 1, iWidth)

        Else
            'maxed the amount to show so start scrolling
            rCell.Value = Mid(sMarquee, iCurPos + 1, iWidth)
        End If

    End If
    'release range object
    Set rCell = Nothing
    'Application.OnTime to stop the stack out of space
    DoEvents
    Sleep 100
    Application.OnTime Now, "DoMarquee"
End Sub

在 excel 中平滑运行选取框文本

Smooth running marquee text in excel

excel

vba

marquee

smooth-scrolling

在 excel 中平滑 运行 选取框文本

Smooth running marquee text in excel

excel

vba

marquee

smooth-scrolling

在 excel 中平滑运行选取框文本