Scrolling Text

neo2 · Jul 22, 2010

Is it possible to get scrolling text like a marquee effect in excel ?

Jaafar Tribak · Mar 2, 2021

Flamesteel said:
@Jaafar Tribak thank you, it works perfectly.
Question, is it possible to add a second scroll which would run simultaneously?
In the example, I am wanting to scroll both Gross and Net scores/leaders.
The scores are on sheet #2.
The Net Leaders would scroll in cell B7

That is going to require rethinking the entire code layout... In addition, even if we can make this work with multiple cells simultanously, I am not sure it will run smoothly enaough because the code is based on a continious loop running in the background. Adding a second scroll-cell will only add more strain to the application.

Maybe replacing the Do DoEvents Loop with a windows timer would work better... If I have a time, I will take a look and see.

Jaafar Tribak · Mar 2, 2021

hakanfa said:
Wow, very impressive, thank you!
One question, would it be hard to convert to scroll in vertical direction? Going from bottom to top?

Best regards,
Hakan

I am not sure what you mean.
You can make the scrollbar vertical if you want. That souldn't be a problem or impact the code in any way ... Just right-click the scrollbar in order to select it and make it bottom to top.

hakanfa · Mar 3, 2021

Jaafar Tribak said:
I am not sure what you mean.
You can make the scrollbar vertical if you want. That souldn't be a problem or impact the code in any way ... Just right-click the scrollbar in order to select it and make it bottom to top.

Hi Jaafar,
well I thought of getting the text scrolling from bottom to top in the same way it no scrolls from right-to-left (or vice versa).. like the end text in movies.

br,
Hakan

Jaafar Tribak · Mar 3, 2021

hakanfa said:
Hi Jaafar,
well I thought of getting the text scrolling from bottom to top in the same way it no scrolls from right-to-left (or vice versa).. like the end text in movies.

br,
Hakan

You guys crack me up with the things you come up with .

This sounds like a fun thing to try... Throwing a bunch of text inside a multi-line cell and making it nicely scroll from bottom to top will probably require a slightly different approach.

I will give this a go later, and see if anything interesting comes up.

hakanfa · Mar 4, 2021

Jaafar Tribak said:
You guys crack me up with the things you come up with .

This sounds like a fun thing to try... Throwing a bunch of text inside a multi-line cell and making it nicely scroll from bottom to top will probably require a slightly different approach.

I will give this a go later, and see if anything interesting comes up.

Sorry Jaafar,
one get exited when you came up with the REALLY impressive solution for vertical scrolling. I have tried several solution and your approach is just great!

Br,
Hakan

Jaafar Tribak · Mar 7, 2021

@hakanfa

Sorry for the late response. It was a busy week.

Demo file:
ScrollText_Vertical.xlsm

Achieving a smooth vertical text-scrolling, turned out to be more difficult than I initially anticipated.

Please, note that the following code won't work properly in Multiple Document Interface excel (MDI). The code, should howover work as expected in excel 2013 (and higher) which use Single Document Interface (SDI)

The ScrollCell routine allows you to set the speed of the scrolling (Very slow, Slow,and Fast), as well as the scroll direction (Up or Down) (BottomToTop is the default)

VBA Code:

Private Sub ScrollCell _
    (ByVal TargetCell As Range, _
    ByVal eSpeed As ScrollSpeed, _
    Optional ByVal BottomToTop As Boolean = True)

The slight flicker in the scrolling text that appears in the below gif is due to the screen capture software I used for making the gif. The actual text scrolling is much smoother.

Code in a Standard Module

VBA Code:

Option Explicit

Private Enum ScrollSpeed
    °VerySlow = 1
    °Slow = 2
    °Fast = 3
End Enum

Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

Private Type MemDc
    #If Win64 Then
        hDC As LongLong
    #Else
        hDC As Long
    #End If
    Width As Long
    Height As Long
End Type


#If VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As Rect, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As Rect, lpRect2 As Rect) As Long
    Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As Rect, lpSrc1Rect As Rect, lpSrc2Rect As Rect) As Long
    Private Declare PtrSafe Function SubtractRect Lib "user32" (lprcDst As Rect, lprcSrc1 As Rect, lprcSrc2 As Rect) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) As Long
    Private Declare PtrSafe Function GetClipBox Lib "gdi32" (ByVal hDC As LongPtr, lpRect As Rect) As Long
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    
    Private hMemoryDC As LongPtr, hBmpPtr As LongPtr

#Else
    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 DeleteDC 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 GetForegroundWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare  Function SubtractRect Lib "user32" (lprcDst As Rect, lprcSrc1 As Rect, lprcSrc2 As Rect) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClipBox Lib "gdi32" (ByVal hDC As Long, lpRect As RECT) As Long
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    
    Private hMemoryDC As Long, hBmpPtr As Long

#End If

Private e_Speed As ScrollSpeed
Private oTargetCell As Range
Private bBottomToTop As Boolean
Private bScrolling As Boolean
Private bCellRectHasChanged As Boolean
Private sNumberFormat As String
Private vPrevCellValue As Variant
Private lBMPHeight As Long


Public Sub Start()
    If bScrolling = False Then
        Call ScrollCell(TargetCell:=Sheet1.Range("B6"), eSpeed:=°Slow, BottomToTop:=True)
    End If
End Sub

Public Sub Finish()
    Call Reset
End Sub


'_____________________________PRIVATE ROUTINES__________________________________________


Private Sub ScrollCell(ByVal TargetCell As Range, ByVal eSpeed As ScrollSpeed, Optional ByVal BottomToTop As Boolean = True)
    Set oTargetCell = TargetCell
    vPrevCellValue = TargetCell.Value
    TargetCell.RowHeight = TargetCell.RowHeight
    e_Speed = eSpeed
    If e_Speed > °Fast Then e_Speed = °Fast
    If e_Speed < °VerySlow Then e_Speed = °VerySlow
    bBottomToTop = BottomToTop
    Call ScrollCellNow
End Sub

Private Sub ScrollCellNow()

    Const WM_KEYDOWN = &H100
    Const WM_KEYUP = &H101
    Const VK_ESCAPE = &H1B
    
    Dim iAtom_ID As Integer

    Call PostMessage(Application.hwnd, WM_KEYDOWN, VK_ESCAPE, &H0)
    Call PostMessage(Application.hwnd, WM_KEYUP, VK_ESCAPE, &H0)

    If bScrolling = False Then
        bScrolling = True
        Set oTargetCell = Range(oTargetCell.Address)
        iAtom_ID = GlobalAddAtom(oTargetCell.Address)
        Call SetProp(Application.hwnd, "CellAddress", iAtom_ID)
        If Not bCellRectHasChanged Then
            sNumberFormat = oTargetCell.NumberFormat
            iAtom_ID = GlobalAddAtom(oTargetCell.NumberFormat)
            Call SetProp(Application.hwnd, "NumberFormat", iAtom_ID)
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell
        End If
    End If
    
    Call TakeCellSnapShot(oTargetCell)
    
End Sub

Private Function TakeCellSnapShot(ByVal Target As Range)

    Const SRCCOPY = &HCC0020

    #If Win64 Then
        Static hPrevBmp As LongLong
        Dim hDC As LongLong, hTmpMemDC As LongLong, hBmp As LongLong, hBrush As LongLong, hRgn As LongLong
    #Else
        Static hPrevBmp As Long
        Dim hDC As Long, hTmpMemDC As Long, hBmp As Long, hBrush As Long, hRgn As Long
    #End If
    
    Dim tRect As Rect, oStdPic As StdPicture, tBM As BITMAP

    Set oStdPic = PicFromRange(Target)
    If Not oStdPic Is Nothing Then
        Call GetObjectAPI(oStdPic.Handle, LenB(tBM), tBM)
        Call SetRect(tRect, 0, 0, tBM.bmWidth, tBM.bmHeight)
        hDC = GetDC(0)
        hTmpMemDC = CreateCompatibleDC(hDC)
        Call SelectObject(hTmpMemDC, oStdPic.Handle)
        Call SelectObject(hMemoryDC, hPrevBmp)
        Call DeleteDC(hMemoryDC)
        hMemoryDC = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, tBM.bmWidth, tBM.bmHeight)
        hPrevBmp = SelectObject(hMemoryDC, hBmp)
        hBrush = CreateSolidBrush(Target.Interior.Color)
        Call FillRect(hMemoryDC, tRect, hBrush)
        Call GetClipBox(hTmpMemDC, tRect)
        With tRect
            Call SetRect(tRect, .Left + 4, .Top + 4, .Right - 4, .Bottom - 4)
            hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        End With
        Call SelectClipRgn(hMemoryDC, hRgn)
        Call BitBlt(hMemoryDC, 0, 0, tBM.bmWidth, tBM.bmHeight, hTmpMemDC, 0, 0, SRCCOPY)
        Call ReleaseDC(0, hDC)
        Call DeleteDC(hTmpMemDC)
        Call DeleteObject(hBmp)
        Call DeleteObject(hBrush)
        Call DeleteObject(hRgn)
    End If

End Function

Private Sub UpdateCell()

    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Const SM_CYBORDER = 6
    Const SM_CXVSCROLL = 2
    Const SM_CYDLGFRAME = 8
    Const SRCCOPY = &HCC0020

    #If Win64 Then
        Dim hDC As LongLong
    #Else
        Dim hDC As Long
    #End If
    
    Dim tCellRect As Rect, tPrevCellRect As Rect
    Dim tGridRect As Rect, tPrevGridRect As Rect, tVisibleRect As Rect, tTaskBarRect As Rect, tAppRect As Rect
    Dim tDestRect1 As Rect, tDestRect2 As Rect
    Dim lYOffset As Long, lMemDcHeight As Long, lVertScrollBarWidth As Long
    

    On Error Resume Next
    Application.EnableCancelKey = xlDisabled
    
    hDC = GetDC(0)
    Do
        DoEvents
        With oTargetCell
            If .Value <> vPrevCellValue Then
                .NumberFormat = sNumberFormat
                Call ScrollCellNow
                .NumberFormat = ";;;"
                vPrevCellValue = .Value
            End If
        End With
        tCellRect = GetRangeRect(oTargetCell)
        Call GetWindowRect(Application.hwnd, tAppRect)
        With tCellRect
            If CellOnScreen Then
                If EqualRect(tCellRect, tPrevCellRect) = 0 Or EqualRect(tAppRect, tPrevGridRect) = 0 Then
                    bCellRectHasChanged = True
                    tPrevCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    Call GetWindowRect(FindWindow("Shell_TrayWnd", vbNullString), tTaskBarRect)
                    With tTaskBarRect
                        .Left = .Left - GetSystemMetrics(SM_CXSCREEN)
                        .Right = .Right + GetSystemMetrics(SM_CXSCREEN)
                        .Bottom = .Bottom + GetSystemMetrics(SM_CYSCREEN)
                    End With
                    tGridRect = GetGridRect
                    Call IntersectRect(tDestRect1, tGridRect, tCellRect)
                    Call SubtractRect(tDestRect2, tDestRect1, tTaskBarRect)
                    Call ScrollCellNow
                    Call Sleep(200)
                    oTargetCell.NumberFormat = ";;;"
                End If
                tVisibleRect = GetRangeRect(Application.ActiveWindow.VisibleRange)
                If ActiveWindow.DisplayVerticalScrollBar And tCellRect.Right >= tVisibleRect.Right Then
                    lVertScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL) + _
                    GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYDLGFRAME)
                End If
                If lBMPHeight >= (.Bottom - .Top) Then
                    lMemDcHeight = lBMPHeight
                Else
                    lMemDcHeight = (.Bottom - .Top)
                End If
                If bBottomToTop Then
                    Call BitBlt(hDC, .Left, .Top, (tDestRect2.Right - tDestRect2.Left) - lVertScrollBarWidth - 2, _
                    (tDestRect2.Bottom - tDestRect2.Top) - 4, _
                   hMemoryDC, 0, lYOffset - lMemDcHeight, SRCCOPY)
                Else
                    Call BitBlt(hDC, .Left, .Top, (tDestRect2.Right - tDestRect2.Left) - lVertScrollBarWidth - 2, _
                    (tDestRect2.Bottom - tDestRect2.Top) - 4, _
                    hMemoryDC, 0, lMemDcHeight - lYOffset, SRCCOPY)
                End If
                If e_Speed <= °Fast Then
                    Call SetSpeed(e_Speed)
                Else
                    Call Reset
                    Exit Do
                End If
                If lYOffset = 0 Then lYOffset = lMemDcHeight
                If lYOffset > lMemDcHeight * 2 Then lYOffset = 0
                lYOffset = lYOffset + 1
            End If
        End With
        Call GetWindowRect(Application.hwnd, tPrevGridRect)
    Loop Until bScrolling = False
    
    lYOffset = 0
    Call ReleaseDC(0, hDC)

End Sub

Private Sub SetSpeed(ByVal eSpeed As ScrollSpeed)
    Dim t As Single
    t = Timer
    Do: Loop Until (Timer - t) >= eSpeed / Switch(eSpeed = °VerySlow, 10, eSpeed = °Slow, 100, eSpeed = °Fast, 800)
End Sub


Private Function PicFromRange(ByVal rCell As Range) As StdPicture

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long

    On Error GoTo ErrHandler

    Call DeleteObject(hBmpPtr)
    Call CopyRange(rCell)
    Call OpenClipboard(0)
    hBmpPtr = GetClipboardData(CF_BITMAP)
    
    If hBmpPtr Then
        hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hBmpPtr
            .hPal = CF_BITMAP
        End With
        lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
        If lRet = S_OK Then
            Set PicFromRange = IPic
        End If
    End If
    
ErrHandler:
    Call EmptyClipboard
    Call CloseClipboard
    
End Function

Private Function GetBMPHeight() As Long

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    #If Win64 Then
        Dim hBmpPtr As LongLong
    #Else
        Dim hBmpPtr As Long
    #End If

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long
    Dim tBM As BITMAP

    On Error GoTo ErrHandler
    
    Call OpenClipboard(0)
    hBmpPtr = GetClipboardData(CF_BITMAP)
    If hBmpPtr Then
        hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        Call GetObjectAPI(hBmpPtr, LenB(tBM), tBM)
        GetBMPHeight = tBM.bmHeight
    End If
    
ErrHandler:

    Call DeleteObject(hBmpPtr)
    Call EmptyClipboard
    Call CloseClipboard

End Function

Private Sub CopyRange(ByVal rCell As Range)
    
    Dim oTempRange As Range
    
    rCell.VerticalAlignment = xlTop
    Set oTempRange = HiddenCopySheet.Range("A1")
    With oTempRange
        .EntireRow.AutoFit
        .VerticalAlignment = xlTop
        .ColumnWidth = rCell.ColumnWidth
        rCell.Copy oTempRange
        oTempRange.Copy
        On Error Resume Next
            lBMPHeight = GetBMPHeight
            oTempRange.RowHeight = PXtoPT(lBMPHeight, True)
            oTempRange.Copy
        On Error GoTo 0
    End With

End Sub

Private Function GetGridRect() As Rect

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_CLIENT = &HFFFFFFFC
    Const ROLE_SYSTEM_CLIENT = &HA&
    Const ROLE_SYSTEM_WINDOW = &H9&
    Const S_OK = &H0&
    
    Dim tGUID(0 To 3) As Long, oAccClient  As IAccessible, vAccContainer As Variant, vArrChildren As Variant
    Dim l As Long, t As Long, w As Long, h As Long
    Dim l2 As Long, t2 As Long, w2 As Long, h2 As Long
    Dim tTmpRect As Rect, i As Long

    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0)), oAccClient) = S_OK Then
            oAccClient.accLocation l, t, w, h, 0&
            Set vAccContainer = oAccClient
        End If
    End If
    
    If Not vAccContainer Is Nothing Then
        If ActiveWindow.DisplayWorkbookTabs Then
            Do
                Call AccessibleChildren(vAccContainer, i, 1, vArrChildren, 1)
                i = i + 1
            Loop Until vArrChildren.accRole(0&) = ROLE_SYSTEM_CLIENT
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h) - (h2))
        ElseIf ActiveWindow.DisplayHorizontalScrollBar Then
            Do
                Call AccessibleChildren(vAccContainer, i, 1, vArrChildren, 1)
                i = i + 1
            Loop Until (vArrChildren.accRole(0&) = ROLE_SYSTEM_WINDOW And InStr(1, vArrChildren.accName(0&), "Hori", 0))
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h) - (h2 + 10))
        ElseIf Application.DisplayStatusBar Then
            Set oAccClient = Application.CommandBars("Status Bar")
            Set vAccContainer = oAccClient
            Set vArrChildren = vAccContainer
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h))
        Else
            Call GetWindowRect(Application.hwnd, tTmpRect)
        End If
        GetGridRect = tTmpRect
    End If

End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hDC

    If lDPI(0) = 0 Then
        hDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(0, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH As Long = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function

Private Function GetRangeRect(ByVal obj As Object) As Rect
    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1).ActivePane

    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left)
        .Top = oPane.PointsToScreenPixelsY(obj.Top)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width - 2)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

Private Function IsCellVisible(ByVal Cell As Range) As Boolean
    With Application.ActiveWindow.VisibleRange
        IsCellVisible = Cell.Left >= .Left And Cell.Top >= .Top And _
            Cell.Top + Cell.Height <= .Top + .Height And _
            Cell.Left + Cell.Width <= .Left + .Width
    End With
End Function

Private Function CellOnScreen() As Boolean
    CellOnScreen = (ActiveSheet Is oTargetCell.Parent) And (IsCellVisible(oTargetCell)) _
    And (GetForegroundWindow = Application.hwnd)
End Function

Private Sub Reset()

    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    Dim sRangeAddr As String, sNumberFormat As String

    bScrolling = False
    bCellRectHasChanged = False
    Call DeleteDC(hMemoryDC)
    Call DeleteObject(hBmpPtr)

    If GetProp(Application.hwnd, "CellAddress") Then
        Atom_ID = CInt(GetProp(Application.hwnd, "CellAddress"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        sRangeAddr = Left(sBuffer, lRet)
        Atom_ID = CInt(GetProp(Application.hwnd, "NumberFormat"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        sNumberFormat = Left(sBuffer, lRet)
        Range(sRangeAddr).NumberFormat = sNumberFormat
        Call RemoveProp(Application.hwnd, "CellAddress")
        Call RemoveProp(Application.hwnd, "NumberFormat")
    End If

End Sub

Private Sub Auto_Close()
    Call Reset
End Sub

Note that the code uses a supporting hidden sheet (HiddenCopySheet) which is needed to temporarly hold a copy of the actual scrolling cell.

hakanfa · Mar 18, 2021

Jaafar Tribak said:

@hakanfa

Sorry for the late response. It was a busy week.

Demo file:
ScrollText_Vertical.xlsm

Achieving a smooth vertical text-scrolling, turned out to be more difficult than I initially anticipated.

Please, note that the following code won't work properly in Multiple Document Interface excel (MDI). The code, should howover work as expected in excel 2013 (and higher) which use Single Document Interface (SDI)

The ScrollCell routine allows you to set the speed of the scrolling (Very slow, Slow,and Fast), as well as the scroll direction (Up or Down) (BottomToTop is the default)

VBA Code:

Private Sub ScrollCell _
    (ByVal TargetCell As Range, _
    ByVal eSpeed As ScrollSpeed, _
    Optional ByVal BottomToTop As Boolean = True)

The slight flicker in the scrolling text that appears in the below gif is due to the screen capture software I used for making the gif. The actual text scrolling is much smoother.

Code in a Standard Module

VBA Code:

Option Explicit

Private Enum ScrollSpeed
    °VerySlow = 1
    °Slow = 2
    °Fast = 3
End Enum

Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

Private Type MemDc
    #If Win64 Then
        hDC As LongLong
    #Else
        hDC As Long
    #End If
    Width As Long
    Height As Long
End Type


#If VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As Rect, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As Rect, lpRect2 As Rect) As Long
    Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As Rect, lpSrc1Rect As Rect, lpSrc2Rect As Rect) As Long
    Private Declare PtrSafe Function SubtractRect Lib "user32" (lprcDst As Rect, lprcSrc1 As Rect, lprcSrc2 As Rect) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Rect) As Long
    Private Declare PtrSafe Function GetClipBox Lib "gdi32" (ByVal hDC As LongPtr, lpRect As Rect) As Long
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
   
    Private hMemoryDC As LongPtr, hBmpPtr As LongPtr

#Else
    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 DeleteDC 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 GetForegroundWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare  Function SubtractRect Lib "user32" (lprcDst As Rect, lprcSrc1 As Rect, lprcSrc2 As Rect) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClipBox Lib "gdi32" (ByVal hDC As Long, lpRect As RECT) As Long
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
   
    Private hMemoryDC As Long, hBmpPtr As Long

#End If

Private e_Speed As ScrollSpeed
Private oTargetCell As Range
Private bBottomToTop As Boolean
Private bScrolling As Boolean
Private bCellRectHasChanged As Boolean
Private sNumberFormat As String
Private vPrevCellValue As Variant
Private lBMPHeight As Long


Public Sub Start()
    If bScrolling = False Then
        Call ScrollCell(TargetCell:=Sheet1.Range("B6"), eSpeed:=°Slow, BottomToTop:=True)
    End If
End Sub

Public Sub Finish()
    Call Reset
End Sub


'_____________________________PRIVATE ROUTINES__________________________________________


Private Sub ScrollCell(ByVal TargetCell As Range, ByVal eSpeed As ScrollSpeed, Optional ByVal BottomToTop As Boolean = True)
    Set oTargetCell = TargetCell
    vPrevCellValue = TargetCell.Value
    TargetCell.RowHeight = TargetCell.RowHeight
    e_Speed = eSpeed
    If e_Speed > °Fast Then e_Speed = °Fast
    If e_Speed < °VerySlow Then e_Speed = °VerySlow
    bBottomToTop = BottomToTop
    Call ScrollCellNow
End Sub

Private Sub ScrollCellNow()

    Const WM_KEYDOWN = &H100
    Const WM_KEYUP = &H101
    Const VK_ESCAPE = &H1B
   
    Dim iAtom_ID As Integer

    Call PostMessage(Application.hwnd, WM_KEYDOWN, VK_ESCAPE, &H0)
    Call PostMessage(Application.hwnd, WM_KEYUP, VK_ESCAPE, &H0)

    If bScrolling = False Then
        bScrolling = True
        Set oTargetCell = Range(oTargetCell.Address)
        iAtom_ID = GlobalAddAtom(oTargetCell.Address)
        Call SetProp(Application.hwnd, "CellAddress", iAtom_ID)
        If Not bCellRectHasChanged Then
            sNumberFormat = oTargetCell.NumberFormat
            iAtom_ID = GlobalAddAtom(oTargetCell.NumberFormat)
            Call SetProp(Application.hwnd, "NumberFormat", iAtom_ID)
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell
        End If
    End If
   
    Call TakeCellSnapShot(oTargetCell)
   
End Sub

Private Function TakeCellSnapShot(ByVal Target As Range)

    Const SRCCOPY = &HCC0020

    #If Win64 Then
        Static hPrevBmp As LongLong
        Dim hDC As LongLong, hTmpMemDC As LongLong, hBmp As LongLong, hBrush As LongLong, hRgn As LongLong
    #Else
        Static hPrevBmp As Long
        Dim hDC As Long, hTmpMemDC As Long, hBmp As Long, hBrush As Long, hRgn As Long
    #End If
   
    Dim tRect As Rect, oStdPic As StdPicture, tBM As BITMAP

    Set oStdPic = PicFromRange(Target)
    If Not oStdPic Is Nothing Then
        Call GetObjectAPI(oStdPic.Handle, LenB(tBM), tBM)
        Call SetRect(tRect, 0, 0, tBM.bmWidth, tBM.bmHeight)
        hDC = GetDC(0)
        hTmpMemDC = CreateCompatibleDC(hDC)
        Call SelectObject(hTmpMemDC, oStdPic.Handle)
        Call SelectObject(hMemoryDC, hPrevBmp)
        Call DeleteDC(hMemoryDC)
        hMemoryDC = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, tBM.bmWidth, tBM.bmHeight)
        hPrevBmp = SelectObject(hMemoryDC, hBmp)
        hBrush = CreateSolidBrush(Target.Interior.Color)
        Call FillRect(hMemoryDC, tRect, hBrush)
        Call GetClipBox(hTmpMemDC, tRect)
        With tRect
            Call SetRect(tRect, .Left + 4, .Top + 4, .Right - 4, .Bottom - 4)
            hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
        End With
        Call SelectClipRgn(hMemoryDC, hRgn)
        Call BitBlt(hMemoryDC, 0, 0, tBM.bmWidth, tBM.bmHeight, hTmpMemDC, 0, 0, SRCCOPY)
        Call ReleaseDC(0, hDC)
        Call DeleteDC(hTmpMemDC)
        Call DeleteObject(hBmp)
        Call DeleteObject(hBrush)
        Call DeleteObject(hRgn)
    End If

End Function

Private Sub UpdateCell()

    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Const SM_CYBORDER = 6
    Const SM_CXVSCROLL = 2
    Const SM_CYDLGFRAME = 8
    Const SRCCOPY = &HCC0020

    #If Win64 Then
        Dim hDC As LongLong
    #Else
        Dim hDC As Long
    #End If
   
    Dim tCellRect As Rect, tPrevCellRect As Rect
    Dim tGridRect As Rect, tPrevGridRect As Rect, tVisibleRect As Rect, tTaskBarRect As Rect, tAppRect As Rect
    Dim tDestRect1 As Rect, tDestRect2 As Rect
    Dim lYOffset As Long, lMemDcHeight As Long, lVertScrollBarWidth As Long
   

    On Error Resume Next
    Application.EnableCancelKey = xlDisabled
   
    hDC = GetDC(0)
    Do
        DoEvents
        With oTargetCell
            If .Value <> vPrevCellValue Then
                .NumberFormat = sNumberFormat
                Call ScrollCellNow
                .NumberFormat = ";;;"
                vPrevCellValue = .Value
            End If
        End With
        tCellRect = GetRangeRect(oTargetCell)
        Call GetWindowRect(Application.hwnd, tAppRect)
        With tCellRect
            If CellOnScreen Then
                If EqualRect(tCellRect, tPrevCellRect) = 0 Or EqualRect(tAppRect, tPrevGridRect) = 0 Then
                    bCellRectHasChanged = True
                    tPrevCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    Call GetWindowRect(FindWindow("Shell_TrayWnd", vbNullString), tTaskBarRect)
                    With tTaskBarRect
                        .Left = .Left - GetSystemMetrics(SM_CXSCREEN)
                        .Right = .Right + GetSystemMetrics(SM_CXSCREEN)
                        .Bottom = .Bottom + GetSystemMetrics(SM_CYSCREEN)
                    End With
                    tGridRect = GetGridRect
                    Call IntersectRect(tDestRect1, tGridRect, tCellRect)
                    Call SubtractRect(tDestRect2, tDestRect1, tTaskBarRect)
                    Call ScrollCellNow
                    Call Sleep(200)
                    oTargetCell.NumberFormat = ";;;"
                End If
                tVisibleRect = GetRangeRect(Application.ActiveWindow.VisibleRange)
                If ActiveWindow.DisplayVerticalScrollBar And tCellRect.Right >= tVisibleRect.Right Then
                    lVertScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL) + _
                    GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYDLGFRAME)
                End If
                If lBMPHeight >= (.Bottom - .Top) Then
                    lMemDcHeight = lBMPHeight
                Else
                    lMemDcHeight = (.Bottom - .Top)
                End If
                If bBottomToTop Then
                    Call BitBlt(hDC, .Left, .Top, (tDestRect2.Right - tDestRect2.Left) - lVertScrollBarWidth - 2, _
                    (tDestRect2.Bottom - tDestRect2.Top) - 4, _
                   hMemoryDC, 0, lYOffset - lMemDcHeight, SRCCOPY)
                Else
                    Call BitBlt(hDC, .Left, .Top, (tDestRect2.Right - tDestRect2.Left) - lVertScrollBarWidth - 2, _
                    (tDestRect2.Bottom - tDestRect2.Top) - 4, _
                    hMemoryDC, 0, lMemDcHeight - lYOffset, SRCCOPY)
                End If
                If e_Speed <= °Fast Then
                    Call SetSpeed(e_Speed)
                Else
                    Call Reset
                    Exit Do
                End If
                If lYOffset = 0 Then lYOffset = lMemDcHeight
                If lYOffset > lMemDcHeight * 2 Then lYOffset = 0
                lYOffset = lYOffset + 1
            End If
        End With
        Call GetWindowRect(Application.hwnd, tPrevGridRect)
    Loop Until bScrolling = False
   
    lYOffset = 0
    Call ReleaseDC(0, hDC)

End Sub

Private Sub SetSpeed(ByVal eSpeed As ScrollSpeed)
    Dim t As Single
    t = Timer
    Do: Loop Until (Timer - t) >= eSpeed / Switch(eSpeed = °VerySlow, 10, eSpeed = °Slow, 100, eSpeed = °Fast, 800)
End Sub


Private Function PicFromRange(ByVal rCell As Range) As StdPicture

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long

    On Error GoTo ErrHandler

    Call DeleteObject(hBmpPtr)
    Call CopyRange(rCell)
    Call OpenClipboard(0)
    hBmpPtr = GetClipboardData(CF_BITMAP)
   
    If hBmpPtr Then
        hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hBmpPtr
            .hPal = CF_BITMAP
        End With
        lRet = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
        If lRet = S_OK Then
            Set PicFromRange = IPic
        End If
    End If
   
ErrHandler:
    Call EmptyClipboard
    Call CloseClipboard
   
End Function

Private Function GetBMPHeight() As Long

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    #If Win64 Then
        Dim hBmpPtr As LongLong
    #Else
        Dim hBmpPtr As Long
    #End If

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As Object, lRet As Long
    Dim tBM As BITMAP

    On Error GoTo ErrHandler
   
    Call OpenClipboard(0)
    hBmpPtr = GetClipboardData(CF_BITMAP)
    If hBmpPtr Then
        hBmpPtr = CopyImage(hBmpPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        Call GetObjectAPI(hBmpPtr, LenB(tBM), tBM)
        GetBMPHeight = tBM.bmHeight
    End If
   
ErrHandler:

    Call DeleteObject(hBmpPtr)
    Call EmptyClipboard
    Call CloseClipboard

End Function

Private Sub CopyRange(ByVal rCell As Range)
   
    Dim oTempRange As Range
   
    rCell.VerticalAlignment = xlTop
    Set oTempRange = HiddenCopySheet.Range("A1")
    With oTempRange
        .EntireRow.AutoFit
        .VerticalAlignment = xlTop
        .ColumnWidth = rCell.ColumnWidth
        rCell.Copy oTempRange
        oTempRange.Copy
        On Error Resume Next
            lBMPHeight = GetBMPHeight
            oTempRange.RowHeight = PXtoPT(lBMPHeight, True)
            oTempRange.Copy
        On Error GoTo 0
    End With

End Sub

Private Function GetGridRect() As Rect

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_CLIENT = &HFFFFFFFC
    Const ROLE_SYSTEM_CLIENT = &HA&
    Const ROLE_SYSTEM_WINDOW = &H9&
    Const S_OK = &H0&
   
    Dim tGUID(0 To 3) As Long, oAccClient  As IAccessible, vAccContainer As Variant, vArrChildren As Variant
    Dim l As Long, t As Long, w As Long, h As Long
    Dim l2 As Long, t2 As Long, w2 As Long, h2 As Long
    Dim tTmpRect As Rect, i As Long

    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0)), oAccClient) = S_OK Then
            oAccClient.accLocation l, t, w, h, 0&
            Set vAccContainer = oAccClient
        End If
    End If
   
    If Not vAccContainer Is Nothing Then
        If ActiveWindow.DisplayWorkbookTabs Then
            Do
                Call AccessibleChildren(vAccContainer, i, 1, vArrChildren, 1)
                i = i + 1
            Loop Until vArrChildren.accRole(0&) = ROLE_SYSTEM_CLIENT
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h) - (h2))
        ElseIf ActiveWindow.DisplayHorizontalScrollBar Then
            Do
                Call AccessibleChildren(vAccContainer, i, 1, vArrChildren, 1)
                i = i + 1
            Loop Until (vArrChildren.accRole(0&) = ROLE_SYSTEM_WINDOW And InStr(1, vArrChildren.accName(0&), "Hori", 0))
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h) - (h2 + 10))
        ElseIf Application.DisplayStatusBar Then
            Set oAccClient = Application.CommandBars("Status Bar")
            Set vAccContainer = oAccClient
            Set vArrChildren = vAccContainer
            vArrChildren.accLocation l2, t2, w2, h2, 0&
            Call SetRect(tTmpRect, l, t, w + l, (t + h))
        Else
            Call GetWindowRect(Application.hwnd, tTmpRect)
        End If
        GetGridRect = tTmpRect
    End If

End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1), hDC

    If lDPI(0) = 0 Then
        hDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(0, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH As Long = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function

Private Function GetRangeRect(ByVal obj As Object) As Rect
    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1).ActivePane

    With GetRangeRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left)
        .Top = oPane.PointsToScreenPixelsY(obj.Top)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width - 2)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

Private Function IsCellVisible(ByVal Cell As Range) As Boolean
    With Application.ActiveWindow.VisibleRange
        IsCellVisible = Cell.Left >= .Left And Cell.Top >= .Top And _
            Cell.Top + Cell.Height <= .Top + .Height And _
            Cell.Left + Cell.Width <= .Left + .Width
    End With
End Function

Private Function CellOnScreen() As Boolean
    CellOnScreen = (ActiveSheet Is oTargetCell.Parent) And (IsCellVisible(oTargetCell)) _
    And (GetForegroundWindow = Application.hwnd)
End Function

Private Sub Reset()

    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    Dim sRangeAddr As String, sNumberFormat As String

    bScrolling = False
    bCellRectHasChanged = False
    Call DeleteDC(hMemoryDC)
    Call DeleteObject(hBmpPtr)

    If GetProp(Application.hwnd, "CellAddress") Then
        Atom_ID = CInt(GetProp(Application.hwnd, "CellAddress"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        sRangeAddr = Left(sBuffer, lRet)
        Atom_ID = CInt(GetProp(Application.hwnd, "NumberFormat"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        sNumberFormat = Left(sBuffer, lRet)
        Range(sRangeAddr).NumberFormat = sNumberFormat
        Call RemoveProp(Application.hwnd, "CellAddress")
        Call RemoveProp(Application.hwnd, "NumberFormat")
    End If

End Sub

Private Sub Auto_Close()
    Call Reset
End Sub

Note that the code uses a supporting hidden sheet (HiddenCopySheet) which is needed to temporarly hold a copy of the actual scrolling cell.

Wow! Absolutely fabulous! Precisaly what I was looking for! 100 x thank you!

hakanfa · Mar 18, 2021

sorry for coming back to this again.. I got really exited about it and was about to implement it on my project when I recognized that:
1. I have the sheet zoomed to 70% - the scrolled text is animated in 100% - is there a way to observe this? I tried to toggle the code to find were to correct his but did not come up with any workable solution
2. Would it be possible to have it working with merged cells? Or would it be better to but the text in a textbox to avoid the on-cell-rect dilemma?

Anyways, thank you for absolutely fantastic "smoot" scrolling solution!

-Hakan

Jaafar Tribak · Mar 18, 2021

hakanfa said:
sorry for coming back to this again.. I got really exited about it and was about to implement it on my project when I recognized that:
1. I have the sheet zoomed to 70% - the scrolled text is animated in 100% - is there a way to observe this? I tried to toggle the code to find were to correct his but did not come up with any workable solution
2. Would it be possible to have it working with merged cells? Or would it be better to but the text in a textbox to avoid the on-cell-rect dilemma?

Anyways, thank you for absolutely fantastic "smoot" scrolling solution!

-Hakan

Yes you are right about the zoom issue.

I am surprised because I am 100% sure that I had catered for different sheet zooms and it was working ok ... Maybe I lost that part of the code on a draft copy.

The code as is, doesn't work with merged cells.

I will take a look when I am not busy and see what can be done.

Serjape · Aug 17, 2022

Flamesteel said:
Thanks for this example, it is quite impressive.
While I'm not at the level to understand the code completely, I can reference the some of the marco verbiage.
My question is using the cell reference to enter a text string to display, I would like to reference a range.
Example - A7:B50
Or could it possibly reference data from a pivotal table?
And how could I add a second or third scroll?

I would like to use this example to display scores of players during a game.
As scores update, then the text would display the changes.View attachment 33340

Apologize for the interruption here but I have a case where i would lie to be able to just ent3er text into designated area and have text start scrolling non stop until it is changed or deleted. Starting when workbook is opened and no start or stop buttons. Is this possible?

Scrolling Text

neo2

New Member

Jaafar Tribak

Well-known Member

Excel Facts

Jaafar Tribak

Well-known Member

hakanfa

New Member

Jaafar Tribak

Well-known Member

hakanfa

New Member

Jaafar Tribak

Well-known Member

hakanfa

New Member

hakanfa

New Member

Jaafar Tribak

Well-known Member

Serjape

New Member

Similar threads

Forum statistics

Share this page

Scrolling Text

New Member

Well-known Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

New Member

Well-known Member

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock