Scrolling Text

N

neo2

New Member
Joined
Jul 22, 2010
Messages
33
Is it possible to get scrolling text like a marquee effect in excel ?
 
Sort by date Sort by votes
This works for me. It works best with a non-porportional font. Even so, its 1 sec interval?????
Code: 
Dim scrollCell As Boolean

Sub trial()
    Static startChr As Long
    Dim cellWidth As Single
    Dim substring As String
    If startChr < 1 Then startChr = 1

    With Range("A1")
        cellWidth = .ColumnWidth
        substring = Mid(Space(cellWidth) & CStr(.Value) & Space(cellWidth), startChr, .ColumnWidth)
        substring = Chr(34) & substring & Chr(34)

        .NumberFormat = substring & Application.Rept(";" & substring, 3)
    End With

    startChr = (startChr Mod ((3 * cellWidth) - 1)) + 1

    If scrollCell Then
        Application.OnTime Now() + TimeValue("00:00:01"), "trial"
    End If
End Sub

Sub stopScroll()
    scrollCell = False
End Sub

Sub startScroll()
    scrollCell = True
    Call trial
End Sub
 
Last edited:
Upvote 0

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Jaafar Tribak said:
Thanks Jasonb75 for your help with this.

Unfortunatly having a constant recalculation like you said is not a practical solution. Also, the visual effect is still not the Stock Ticker one.
Click to expand...

I think the visual defintion of stock ticker could vary with country / broadcaster/ etc.

The original request was for a marquee scrolling effect, which as far as I can remember is text scrolling from right to left in a continuous loop, broken only by a blank space to mark end of message.

What I would class as a stock ticker is text that appears as if it was being typed at a consistant rate, (see solution provided by gauntletxg back in post #2) which the OP said in #3 is not what they were looking for.

To be honest I'm now at a loss as to exactly what it is we're trying to achieve :confused:

I went for the option of disabling calculation until the user edits a cell and breaks the loop to try and reduce processing load, but just realised that the event code would enable when the ticker refreshes.

Should have used something like
Code: 
Sub worksheet_change(ByVal target As Range)
If target.Address <> Range("A1").Address Then
Application.Calculation = xlCalculationAutomatic
End If
End Sub
to re enable calculation.
 
Last edited:
Upvote 0
mikerickson said:
This works for me. It works best with a non-porportional font. Even so, its 1 sec interval?????
Code: 
Dim scrollCell As Boolean
 
Sub trial()
    Static startChr As Long
    Dim cellWidth As Single
    Dim substring As String
    If startChr < 1 Then startChr = 1
 
    With Range("A1")
        cellWidth = .ColumnWidth
        substring = Mid(Space(cellWidth) & CStr(.Value) & Space(cellWidth), startChr, .ColumnWidth)
        substring = Chr(34) & substring & Chr(34)
 
        .NumberFormat = substring & Application.Rept(";" & substring, 3)
    End With
 
    startChr = (startChr Mod ((3 * cellWidth) - 1)) + 1
 
    If scrollCell Then
        Application.OnTime Now() + TimeValue("00:00:01"), "trial"
    End If
End Sub
 
Sub stopScroll()
    scrollCell = False
End Sub
 
Sub startScroll()
    scrollCell = True
    Call trial
End Sub
Click to expand...

Hi Mike.

The code errored out at the ligne :
.NumberFormat = substring & Application.Rept(";" & substring, 3)

"Unable to set the NuumberFormat Property of the Class Range."

When I place a On Error Resume Next at the top , after a while , the text just disappears.
 
Upvote 0
To be honest I'm now at a loss as to exactly what it is we're trying to achieve :confused:
Click to expand...

Ok here is what I got :- It works very smoothly but the code is rather involved.


Workbook Example.


Code :

Code: 
Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDc As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hDc As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDc As Long) As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hDc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
 
Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hDc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
 
 
Private Declare Function ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
 
 
Private Const SRCCOPY As Long = &HCC0020
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72
 
Private tPrevRect As RECT
Private oTargetCell As Range
Private bStop As Boolean
Private bRangeRectHasChanged As Boolean
Private vNumberFormat As String
Private vHorzAlignment As Long
Private lMemoryDC As Long
Private lWBHwnd As Long
Private i As Long

Public Sub StartScrolling()
 
    Call ScrollCell(ByVal Range("b4"), 0.01)
 
End Sub
 
Public Sub StopScrolling()
 
    '// Set flg to exit the loop.
    bStop = True
    i = 0
    
    '//Reset this flag.
    bRangeRectHasChanged = False
    
    '//Reset Cell's settings.
    oTargetCell.NumberFormat = vNumberFormat
    oTargetCell.HorizontalAlignment = vHorzAlignment
 
End Sub
 
Private Sub TakeCellSnapShot(Target As Range)
 
    Dim lDC As Long
    Dim lXLDeskhwnd As Long
    Dim lBmp As Long
    
    '//Get the workbook Wnd hwnd.
    lXLDeskhwnd = _
    FindWindowEx(FindWindow("XLMAIN", Application.Caption) _
    , 0, "XLDESK", vbNullString)
    lWBHwnd = FindWindowEx _
    (lXLDeskhwnd, 0, "EXCEL7", vbNullString)
    
    '//Get the Wbk window DC.
    lDC = GetDC(lWBHwnd)
    
    '//Create a memory DC.
    lMemoryDC = CreateCompatibleDC(lDC)
    
    '//Get the target cell metrics in pixels.
    tPrevRect = GetRangeRect(ByVal Target)
    
    With tPrevRect
    
        '//create a compatible Bmp the same size as the target cell.
        lBmp = CreateCompatibleBitmap _
        (lDC, (.Right - 1 - .Left), .Bottom - 1 - .Top)
        
        '//Select the Bmp onto our mem DC.
        DeleteObject SelectObject(lMemoryDC, lBmp)
        
        '//Copy the target cell image onto the Mem DC.
        BitBlt lMemoryDC, 0, 0, (.Right - .Left), .Bottom - .Top, _
        lDC, .Left, .Top, SRCCOPY
    
    End With
    
    '//CleanUp.
    ReleaseDC 0, lDC
    ReleaseDC lMemoryDC, 0
 
End Sub

Private Sub ScrollCell _
(ByVal Target As Range, ByVal Delay As Single)
 
    '//Make sure the target range is one Cell.
    If Target.Cells.Count > 1 Then Exit Sub
    
    bStop = False
    
    '//Store the target cell for later use.
    Set oTargetCell = Target
    
    '//Unselect the target cell to avoid the selection borders.
    If ActiveCell.Address = _
    Target.Address Then oTargetCell.Offset(1).Select
    
    If Not bRangeRectHasChanged Then
    
        vHorzAlignment = Target.HorizontalAlignment
        
        Target.HorizontalAlignment = xlLeft
    
    End If
    
    '//copy the target cell image onto memory.
    Call TakeCellSnapShot(Target)
    
    If Not bRangeRectHasChanged Then
    
        vNumberFormat = Target.NumberFormat
        
        Target.NumberFormat = ";;;"
        
        '//call the text scrolling routine.
        Call UpdateCell(Target, Delay)
    
    End If
 
 
End Sub

Private Sub UpdateCell _
(ByVal Target As Range, ByVal Delay As Single)
 
    Dim lDC As Long
    
    '//store the Wbk window DC.
    lDC = GetDC(lWBHwnd)
    
    '//Scroll the Target Cell Text
    Do
    
        '//Do nothing if not on the target sheet.
        If ActiveSheet Is oTargetCell.Parent Then
            '//Update the tPrevRect Struct if the Target Cell
            '//screen location/size have changed.
            If tPrevRect.Left <> GetRangeRect(Target).Left Or _
            tPrevRect.Top <> GetRangeRect(Target).Top Or _
            tPrevRect.Right <> GetRangeRect(Target).Right Or _
            tPrevRect.Bottom <> GetRangeRect(Target).Bottom Then
                bRangeRectHasChanged = True
                tPrevRect = GetRangeRect(Target)
                Target.NumberFormat = vNumberFormat
                ScrollCell oTargetCell, Delay
                Target.NumberFormat = ";;;"
            End If
            
            '//do the actual text scrolling here.
            With tPrevRect
            
                StretchBlt _
                lDC, .Left, .Top, _
                (.Right - .Left) - 1, (.Bottom - .Top), _
                lMemoryDC, tPrevRect.Left - i, 0, (.Right - .Left), _
                (.Bottom - .Top), SRCCOPY
                
                If i >= (.Right) Then i = 0
            
            End With
            
            i = i + 1
            SetDelay Delay  'Secs.
        
        End If
        
        DoEvents
        
    Loop Until bStop
    
    ReleaseDC 0, lDC
 
 
End Sub

Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
 
    ScreenDPI = lDPI(Abs(bVert))
 
End Function
 
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
 
End Function
 
 
Private Function GetRangeRect(ByVal rng As Range) As RECT
 
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    Dim OWnd  As Window
    On Error Resume Next
    Set OWnd = rng.Parent.Parent.Windows(1)
    With rng
        GetRangeRect.Left = _
        PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = _
        PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = _
        PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = _
        PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
     With GetRangeRect
         tPt1.x = .Left
         tPt1.y = .Top
         tPt2.x = .Right
         tPt2.y = .Bottom
         ScreenToClient lWBHwnd, tPt1
         ScreenToClient lWBHwnd, tPt2
        .Left = tPt1.x
        .Top = tPt1.y
        .Right = tPt2.x
        .Bottom = tPt2.y
    End With
 
End Function

Private Sub SetDelay(TimeOut As Single)
 
    Dim t As Single
    
    t = Timer
    
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut
 
End Sub
 
Upvote 0
Jafar, when it errors, what is the value of subString?

I realize that my code, that runs on a Mac, where 1 sec is the minimum time interval recognized, is clunkier that the API calls, but I still don't see why the code would be erroring there.
 
Upvote 0
Mike, without disecting your code, I'm thinking it could be something with the cellwidth / columnwidth parameters.

When I tried it, if the column was too narrow it only scrolled part of the message, or too wide it gave an error.

I found it was only working as desired when the column was around 60% of the autofit width.

Jaafar, your solution is way beyond my level of knowledge, maybe something for me to look at and learn from later :)
 
Upvote 0
mikerickson said:
Jafar, when it errors, what is the value of subString?

I realize that my code, that runs on a Mac, where 1 sec is the minimum time interval recognized, is clunkier that the API calls, but I still don't see why the code would be erroring there.
Click to expand...

Mike.

I have slightly amended your code as follows and worked without error but the text appears/vanishes around the middle of the cell according to the cell initial horizontal alignement. ie the text doesn't scroll from one end to another.

If you could make your much simpler approach work , it would be nice.
 
Upvote 0
mikerickson said:
Jafar, when it errors, what is the value of subString?

I realize that my code, that runs on a Mac, where 1 sec is the minimum time interval recognized, is clunkier that the API calls, but I still don't see why the code would be erroring there.
Click to expand...

EDIT:

A variation of your code :

Code: 
Dim scrollCell As Boolean
Sub trial()
    Static startChr As Long
    Dim cellWidth As Single
    Dim substring As String
    
    Dim t As Single
    
    If startChr < 1 Then startChr = 1
Do While scrollCell
    With Range("A1")
        cellWidth = .ColumnWidth
        substring = Mid(Space(cellWidth) & CStr(.Value) & Space(cellWidth), startChr, .ColumnWidth)
        substring = Chr(34) & substring & Chr(34)
        .NumberFormat = substring & Application.Rept(";" & substring, 3)
    End With
    startChr = (startChr Mod ((3 * cellWidth) - 1)) + 1
    
t = Timer
Do
    DoEvents
Loop Until Timer - t >= 0.5

DoEvents
Loop
End Sub
Sub stopScroll()
    scrollCell = False
End Sub
Sub startScroll()
    scrollCell = True
    Call trial
End Sub
 
Upvote 0
Here is a much better version of the previous API based solution.

The code now works more accuratly and gives a Scroll Direction choice as well.

Workbook example.


Code in a standard module :

Code: 
'// Written by Jaafar Tribak on 28/07/10
'// API based code that enables to scroll the
'// text in a Worksheet Cell giving it the visual
'// effect of a "Stock Ticker".
'//
'// Results accuracy may be affected by the
'// current Zoom factor.
 
Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
 
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
 
Private Declare Function ScreenToClient Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
 
 
Private Const SRCCOPY As Long = &HCC0020
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72
 
Private tPrevRect As RECT
Private oTargetCell As Range
Private bStop As Boolean
Private bRangeRectHasChanged As Boolean
Private vNumberFormat As String
Private vHorzAlignment As Long
Private lMemoryDC As Long
Private lWBHwnd As Long
Private i As Long

Public Sub StartScrolling()
 
    '//Scroll the text in Cell B4 from Right to Left.
    Call ScrollCell(Range("B4"), 0.01, True)
 
End Sub
 
Public Sub StopScrolling()
 
    '// Set flg to exit the loop.
    bStop = True
    i = 0
    
    '//Reset this flag.
    bRangeRectHasChanged = False
    
    '//Reset Cell's settings.
    oTargetCell.NumberFormat = vNumberFormat
    oTargetCell.HorizontalAlignment = vHorzAlignment
 
End Sub
 
Private Sub TakeCellSnapShot(Target As Range)
 
    Dim lDC As Long
    Dim lXLDeskhwnd As Long
    Dim lBmp As Long
    
    '//Get the workbook Wnd hwnd.
    lXLDeskhwnd = _
    FindWindowEx(FindWindow("XLMAIN", Application.Caption) _
    , 0, "XLDESK", vbNullString)
    lWBHwnd = FindWindowEx _
    (lXLDeskhwnd, 0, "EXCEL7", vbNullString)
    
    '//Get the Wbk window DC.
    lDC = GetDC(lWBHwnd)
    
    '//Create a memory DC.
    lMemoryDC = CreateCompatibleDC(lDC)
    
    '//Get the target cell metrics in pixels.
    tPrevRect = GetRangeRect(ByVal Target)
    
    With tPrevRect
    
        '//create a compatible Bmp the same size as the target cell.
        lBmp = CreateCompatibleBitmap _
        (lDC, (.Right - 1 - .Left), (.Bottom - .Top))
        
        '//Select the Bmp onto our mem DC.
        DeleteObject SelectObject(lMemoryDC, lBmp)
        
        '//Copy the target cell image onto the Mem DC.
        BitBlt lMemoryDC, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        lDC, .Left, .Top, SRCCOPY
    
    End With
    
    '//CleanUp.
    ReleaseDC 0, lDC
    ReleaseDC lMemoryDC, 0
 
End Sub

Private Sub ScrollCell _
(ByVal Target As Range, ByVal Delay As Single, _
Optional ByVal RightToLeft As Boolean)
 
    '//Make sure the target range is one Cell.
    If Target.Cells.Count > 1 Then Exit Sub
    
    bStop = False
    
    '//Store the target cell for later use.
    Set oTargetCell = Target
    
    '//Unselect the target cell to avoid the selection borders.
    If ActiveCell.Address = _
    Target.Address Then oTargetCell.Offset(1).Select
    
    If Not bRangeRectHasChanged Then
    
        vHorzAlignment = Target.HorizontalAlignment
        
        Target.HorizontalAlignment = xlLeft
    
    End If
    
    '//copy the target cell image onto memory.
    Call TakeCellSnapShot(Target)
    
    If Not bRangeRectHasChanged Then
    
        vNumberFormat = Target.NumberFormat
        
        Target.NumberFormat = ";;;"
        
        '//call the text scrolling routine.
        Call UpdateCell(Target, Delay, RightToLeft)
    
    End If
 
 
End Sub

Private Sub UpdateCell _
(ByVal Target As Range, ByVal Delay As Single, _
Optional ByVal RightToLeft As Boolean)
 
    Dim lDC As Long
    
    '//store the Wbk window DC.
    lDC = GetDC(lWBHwnd)
    
    '//Scroll the Target Cell Text.
    Do
    
        '//Do nothing if not on the target sheet.
        If ActiveSheet Is oTargetCell.Parent Then
            '//Update the tPrevRect Struct if the Target Cell
            '//screen location/size have changed.
            If tPrevRect.Left <> GetRangeRect(Target).Left Or _
            tPrevRect.Top <> GetRangeRect(Target).Top Or _
            tPrevRect.Right <> GetRangeRect(Target).Right Or _
            tPrevRect.Bottom <> GetRangeRect(Target).Bottom Then
                bRangeRectHasChanged = True
                tPrevRect = GetRangeRect(Target)
                Target.NumberFormat = vNumberFormat
                ScrollCell oTargetCell, Delay
                Target.NumberFormat = ";;;"
            End If
            
            '//do the actual text scrolling here.
            With tPrevRect
            
                If RightToLeft Then
                    BitBlt lDC, .Left + 1, .Top, (.Right - .Left), _
                    (.Bottom - .Top), _
                    lMemoryDC, i - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt lDC, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    lMemoryDC, (.Right - .Left) - i, 0, SRCCOPY
                End If
                
                If i >= (.Right - .Left) * 2 Then i = 0
                
            End With
            
            i = i + 1
            SetDelay Delay  'Secs.
        
        End If
        
        DoEvents
        
    Loop Until bStop
    
    ReleaseDC 0, lDC
 
 
End Sub
 
'//===============================
'// Other Supporting routines...
'//===============================
Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
 
    ScreenDPI = lDPI(Abs(bVert))
 
End Function
 
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
 
End Function
 
 
Private Function GetRangeRect(ByVal rng As Range) As RECT
 
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    Dim OWnd  As Window
 
    On Error Resume Next
 
    Set OWnd = rng.Parent.Parent.Windows(1)
 
    With rng
        GetRangeRect.Left = _
        PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = _
        PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = _
        PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = _
        PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
 
     With GetRangeRect
         tPt1.x = .Left
         tPt1.y = .Top
         tPt2.x = .Right
         tPt2.y = .Bottom
         ScreenToClient lWBHwnd, tPt1
         ScreenToClient lWBHwnd, tPt2
        .Left = tPt1.x + 2
        .Top = tPt1.y
        .Right = tPt2.x - 2
        .Bottom = tPt2.y
    End With
    
End Function

Private Sub SetDelay(TimeOut As Single)
 
    Dim t As Single
    
    t = Timer
    
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut
 
End Sub

One annoying limitation is when the worksheet zoom is less than 75 the the text precision may be dimished.
 
Upvote 0
The key to my approach seems to be that the Normal style has to be set to a non-porportional type font.

With that condition, this seems to have most of the bugs out.

Sub trial()
Static startChr As Long
Dim cellWidth As Single, maxL As Long
Dim subString As String
If startChr < 1 Then startChr = 1

With Range("A1")
cellWidth = .ColumnWidth

subString = CStr(.Value)
maxL = Len(subString) + cellWidth

subString = Space(cellWidth) & subString & Space(cellWidth) & subString
subString = Mid(subString, startChr, cellWidth)

.Offset(5, 1) = "'." & subString & "."
subString = Chr(34) & subString & Chr(34)

.NumberFormat = subString & Application.Rept(";" & subString, 3)
End With

startChr = (startChr Mod (maxL)) + 1

If scrollCell Then
Application.OnTime Now() + TimeValue("00:00:01"), "trial"
Else
Range("A1").NumberFormat = "general"
End If
End Sub

Sub stopScroll()
scrollCell = False
End Sub

Sub startScroll()
scrollCell = True
Call trial
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Keep text within a merged row centered on screen when scrolling horizontally
Replies
1
Views
100
ISY
I
R
  • Solved
Arrow controls on side of Scroller missing
Replies
2
Views
79
RodneyW
R
R
  • Question
Calculate Now function until button press
Replies
4
Views
276
offthelip
O
S
  • Question
Frozen panes scrolling a whole 2nd spreadsheet in the one pane. On a mac
Replies
0
Views
190
sambee66
S
G
  • Question
Scroll Bar
Replies
1
Views
336
Georgiboy
Georgiboy

Forum statistics

Threads
1,214,522
Messages
6,120,022
Members
448,939
Latest member
Leon Leenders

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top