Smooth running marquee text in excel

Question

I am creating a marquee text in Excel 2013. As the Microsoft Web Browser Control doesn't work in Excel 2013 and 2016, so I used the following VBA code:

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

It is reflecting in excel every second, is there a way to reflect in milliseconds so that it can show some smooth running. And more issue is, it again starts only after scrolling completely. Is there anyway to make it in a scroll continuously with waiting for the entire text to scroll.

Answer 1

For your sub second functionality use an API call.

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

Drop the PtrSafe if on 32 bit machine so becomes:

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

Edit:

1) A number of users have noted out of stack space messages to frequency of calls.

@Sorceri has correctly pointed out you can re-work as:

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

2) I was unaware of the letter by letter part so I will refer you to his/her answer on the pulling of iWidth into global variable.

That in mind, you may wish to amend the following to take account of @Sorceri's iWidth; I have the following version 2 "fudge" for the hyperlink, amended for out-of-stack, and which includes a test for 32 v 64 bit versions to ensure compatibility. More info on compatibility here.

Version 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

I couldn't get the example to stop the stack out of space as there were to many calls on the stack to the DoMarquee method. Plus I thought a marquee wrote it out character by character. So using Application.OnTime event to create the marquee. I also took out the iWidth and made it a global variable.

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