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

将PtrSafe if放在 32位 计算机上，然后变为：

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

修改：

1）许多用户已经注意到堆栈空间消息与呼叫频率不同。

@Sorceri已经正确地指出你可以重新工作：

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

2）我没有意识到逐个字母的部分，所以我将引用你关于将iWidth拉入全局变量的答案。

考虑到@ Sorceri的iWidth，您可能希望修改以下内容;我为超链接提供了以下版本2“软糖”，针对堆栈外进行了修改，其中包括32位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

我无法通过示例来阻止堆栈空间，因为堆栈上有很多调用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中平滑运行选框文本

2 个答案: