Fatal编程技术网
  • vba/
  • Vba 在excel中平滑运行字幕文本

Vba 在excel中平滑运行字幕文本

vba excel

Vba 在excel中平滑运行字幕文本,vba,excel,smooth-scrolling,marquee,Vba,Excel,Smooth Scrolling,Marquee,我正在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 messa

我正在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中进行反射，是否有一种以毫秒为单位进行反射的方法，以便它能够显示一些平稳的运行。更重要的是，它只有在完全滚动后才会再次启动。在等待整个文本滚动的情况下，是否仍然可以使其连续滚动。

对于亚秒功能，请使用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位32位机器处于打开状态，则删除
PtrSafe
，使其变为：

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

1）许多用户注意到堆栈外空间消息会影响调用频率

@Sorceri正确地指出，您可以重新工作：

Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
2）我不知道字母部分，因此我将向您介绍他/她关于将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
考虑到@Sorceri的iWidth，您可能希望修改以下内容：；我为超链接提供了以下版本2“fudge”，针对堆栈外版本进行了修改，其中包括对32 v 64位版本的测试，以确保兼容性。更多关于兼容性的信息

第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
对于亚秒级功能，请使用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位32位机器处于打开状态，则删除
PtrSafe
，使其变为：

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

1）许多用户注意到堆栈外空间消息会影响调用频率

@Sorceri正确地指出，您可以重新工作：

Set rCell = Nothing
DoEvents
Sleep 100
Application.OnTime Now, "DoMarquee"
2）我不知道字母部分，因此我将向您介绍他/她关于将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
考虑到@Sorceri的iWidth，您可能希望修改以下内容：；我为超链接提供了以下版本2“fudge”，针对堆栈外版本进行了修改，其中包括对32 v 64位版本的测试，以确保兼容性。更多关于兼容性的信息

第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
我无法让示例停止堆栈，因为堆栈上有许多对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

选项显式
二等兵我只要
Private Declare PtrSafe子睡眠库“kernel32”（ByVal的长度为毫秒）
公共分区域（）
像弦一样的暗淡的斯玛奇
如长
变暗rCell As范围
暗淡的iCurPos，如长
暗TXT选框为字符串
sMarquee=“这是一个滚动字幕。”
设置rCell=Sheet1.范围（“M2”）
'检查单元格是否为空
如果rCell.Value=”“，则
'将当前位置设置为0，将iWidth设置为0
iCurPos=0
iWidth=0
其他的
'不是空的，因此已开始写入。获取单元格文本的位置
iCurPos=仪表（1，sMarquee，rCell.值）
如果结束
如果iCurPos=0，则
'它是零，因此获取第一个字符
rCell.Value=Mid（sMarquee，iCurPos+1，1）
其他的
如果我的宽度小于10，那么
“宽度小于10，因此我们没有写出最大字符数，
'继续，直到宽度为10
iWidth=iWidth+1
rCell.Value=Mid（sMarquee，1，iWidth）
其他的
'已将要显示的金额设置为最大，因此开始滚动
rCell.Value=Mid（sMarquee，iCurPos+1，iWidth）
如果结束
如果结束
'释放范围对象
Set rCell=无
'Application.OnTime以停止堆栈空间不足
多芬特
睡100
Application.OnTime Now，“DoMarquee”
端接头
我无法让示例停止堆栈，因为堆栈上有许多对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

选项显式
二等兵我只要
Private Declare PtrSafe子睡眠库“kernel32”（ByVal的长度为毫秒）
公共分区域（）
像弦一样的暗淡的斯玛奇
如长
变暗rCell As范围
暗淡的iCurPos，如长
暗TXT选框为字符串
sMarquee=“这是一个滚动字幕。”
设置rCell=Sheet1.范围（“M2”）
'检查单元格是否为空
如果rCell.Value=”“，则
'将当前位置设置为0，将iWidth设置为0
iCurPos=0
iWidth=0
其他的
'不是空的，因此已开始写入。获取单元格文本的位置
iCurPos=仪表（1，sMarquee，rCell.值）
如果结束
如果iCurPos=0，则
'它是零，因此获取第一个字符
rCell.Value=Mid（sMarquee，iCurPos+1，1）
其他的
如果我的宽度小于10，那么
“宽度小于10，因此我们没有写出最大字符数，
'继续，直到宽度为10
iWidth=iWidth+1
rCell.Value=Mid（sMarquee，1，iWidth）
其他的
'已将要显示的金额设置为最大，因此开始滚动
rCell.Value=Mid（sMarquee，iCurPos+1，iWidth）
如果结束
如果结束
'释放范围对象
Set rCell=无
'Application.OnTime以停止堆栈空间不足
多芬特
睡100
Application.OnTime Now，“DoMarquee”
端接头
谢谢QHarr。如果我想添加一个包含多个超链接的文本，该怎么办。如何使这些超链接工作？超链接？这是一个不同的问题吗？这个问题得到了回答还是遗漏了什么？很酷，我不知道你能做到…：）*不幸的是，它对我来说崩溃了（我在Windows 7 64位上使用的是
Office 2016 CTR 32位
。无论是否使用
PtrSafe
，它都会滚动字幕几秒钟，然后我会得到一个