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
That sucks, really liked that effect. Thanks for the effort.

Is there another way of having the freeze pane effect without actually selecting it ?
 
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Jaafar Tribak said:
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.
Click to expand...

Hi Jaafar, bit late to the party here but was wondering whether this would work in MS Excel 2016? I've loaded in the macro however the cell formats as blank and I see no text in cell B4 once I click run.
 
Upvote 0
belgiumcookies said:
Apologies, I didn't provide any information on my OS and software version, I'm using MS Excel 2016 (16.0.4927.1000) 32-bit
Click to expand...

Hi belgiumcookies


Updated Workbook

See if this update code works for you :

In a Standard Module:
VBA 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

#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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

    Private hMemoryDC 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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetActiveWindow Lib "user32" () As Long

    Private hMemoryDC As Long

#End If


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 tCellRect As RECT
Private oTargetCell As Range
Private bScrolling As Boolean
Private bRangeRectHasChanged As Boolean
Private vNumberFormat As String
Private vHorzAlignment As Long
Private xOffset As Long




Public Sub StartScrolling()

    '//Scroll the text in Cell B4 from Right to Left.
    Call ScrollCell(TargetCell:=Range("B4"), Delay:=0.5, RightToLeft:=True)
   
End Sub

Public Sub StopScrolling()

    bScrolling = False
    bRangeRectHasChanged = False
    xOffset = 0
    DeleteObject hMemoryDC
    If Not oTargetCell Is Nothing Then
        oTargetCell.NumberFormat = vNumberFormat
        oTargetCell.HorizontalAlignment = vHorzAlignment
    End If
End Sub



Private Sub ScrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    Application.OnTime Now, "'ScrollCellNow " & Chr$(34) & TargetCell.Address & Chr$(34) & "," & Delay & "," & RightToLeft & "'"
   
End Sub


Sub ScrollCellNow(ByVal TargetCellAddr As String, ByVal Delay As Single, ByVal RightToLeft As Boolean)

    If bScrolling = False Then
        If Range(TargetCellAddr).Cells.Count > 1 Then Exit Sub
        bScrolling = True
         Set oTargetCell = Range(TargetCellAddr)
        If ActiveCell.Address = oTargetCell.Address Then oTargetCell.Offset(2).Select
        Sleep 150
        If Not bRangeRectHasChanged Then
            vHorzAlignment = oTargetCell.HorizontalAlignment
            oTargetCell.HorizontalAlignment = xlLeft
        End If
        Call TakeCellSnapShot(oTargetCell)
        If Not bRangeRectHasChanged Then
            vNumberFormat = oTargetCell.NumberFormat
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell(oTargetCell, Delay, RightToLeft)
        End If
    End If

End Sub


Private Sub TakeCellSnapShot(ByVal Target As Range)

    #If VBA7 Then
        Dim hDc As LongPtr, hBmp As LongPtr
    #Else
        Dim hDc As Long, hBmp As Long
    #End If

    tCellRect = GetRangeRect(ByVal Target)
    hDc = GetDC(0)
    hMemoryDC = CreateCompatibleDC(hDc)

    With tCellRect
        hBmp = CreateCompatibleBitmap(hDc, (.Right - .Left), (.Bottom - .Top))
        DeleteObject SelectObject(hMemoryDC, hBmp)
        BitBlt hMemoryDC, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        hDc, .Left, .Top, SRCCOPY
    End With

    ReleaseDC 0, hDc
    DeleteObject hBmp

End Sub


Private Sub UpdateCell(ByVal Target As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    #If VBA7 Then
        Dim hDc As LongPtr
    #Else
        Dim hDc As Long
    #End If
   
    hDc = GetDC(0)
    Do
        With tCellRect
            If ActiveSheet Is oTargetCell.Parent And IsCellVisible(oTargetCell) And GetActiveWindow = Application.hwnd Then
                If tCellRect.Left <> GetRangeRect(oTargetCell).Left Or _
                .Top <> GetRangeRect(oTargetCell).Top Or _
                .Right <> GetRangeRect(oTargetCell).Right Or _
                .Bottom <> GetRangeRect(oTargetCell).Bottom Then
                    bRangeRectHasChanged = True
                    tCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = vNumberFormat
                    ScrollCell oTargetCell, Delay, RightToLeft
                    oTargetCell.NumberFormat = ";;;"
                End If
                If RightToLeft Then
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    (.Bottom - .Top), _
                    hMemoryDC, xOffset - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    hMemoryDC, (.Right - .Left) - xOffset, 0, SRCCOPY
                End If
                If xOffset >= (.Right - .Left) * 2 Then xOffset = 0
                xOffset = xOffset + 1
                SetDelay Delay  'Secs.
            End If
        End With
        DoEvents
    Loop Until bScrolling = False
    ReleaseDC 0, hDc

End Sub


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    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
    PTtoPX = Points * 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 Obj
        GetRangeRect.Left = oPane.PointsToScreenPixelsX(.Left)
        GetRangeRect.Top = oPane.PointsToScreenPixelsY(.Top)
        GetRangeRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width - 2)
        GetRangeRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height)
    End With

End Function


Private Function IsCellVisible(ByVal Cell As Range) As Boolean

    With Cell
        IsCellVisible = .Left >= ActiveWindow.VisibleRange.Left And .Top >= ActiveWindow.VisibleRange.Top
    End With

End Function


Private Sub SetDelay(ByVal TimeOut As Single)

    Dim t As Single

    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut / 100

End Sub
 
Upvote 0
This is an update of the above code that takes into account the scenario where the user might close the workbook without first stopping the scrolling .

Workbook Update



In a Standard Module:
VBA 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

#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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () 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 hMemoryDC 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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetActiveWindow Lib "user32" () 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 hMemoryDC As Long

#End If


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 tCellRect As RECT
Private oTargetCell As Range
Private bScrolling As Boolean
Private bRangeRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long
Private lXOffset As Long



Public Sub StartScrolling()

    '//Scroll the text in Cell B4 from Right to Left.
    Call scrollCell(TargetCell:=Range("B4"), Delay:=0.5, RightToLeft:=True)
    
End Sub

Public Sub StopScrolling()

    Call Auto_Close

End Sub



Private Sub scrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    Application.OnTime Now, "'ScrollCellNow " & Chr$(34) & TargetCell.Address & Chr$(34) & "," & Delay & "," & RightToLeft & "'"
    
End Sub


Sub ScrollCellNow(ByVal TargetCellAddr As String, ByVal Delay As Single, ByVal RightToLeft As Boolean)

    Dim iAtom_ID As Integer
    
    If bScrolling = False Then
        If Range(TargetCellAddr).Cells.Count > 1 Then Exit Sub
        bScrolling = True
        Set oTargetCell = Range(TargetCellAddr)
        iAtom_ID = GlobalAddAtom(oTargetCell.Address)
        SetProp Application.hWnd, "CellAddress", iAtom_ID
        If ActiveCell.Address = oTargetCell.Address Then oTargetCell.Offset(2).Select
        Sleep 150
        If Not bRangeRectHasChanged Then
            lHorzAlignment = oTargetCell.HorizontalAlignment
            iAtom_ID = GlobalAddAtom(CStr(oTargetCell.HorizontalAlignment))
            SetProp Application.hWnd, "HorzAlignment", iAtom_ID
            oTargetCell.HorizontalAlignment = xlLeft
        End If
        Call TakeCellSnapShot(oTargetCell)
        If Not bRangeRectHasChanged Then
            sNumberFormat = oTargetCell.NumberFormat
            iAtom_ID = GlobalAddAtom(oTargetCell.NumberFormat)
            SetProp Application.hWnd, "NumberFormat", iAtom_ID
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell(oTargetCell, Delay, RightToLeft)
        End If
    End If

End Sub


Private Sub TakeCellSnapShot(ByVal target As Range)

    #If VBA7 Then
        Dim hDc As LongPtr, hBmp As LongPtr
    #Else
        Dim hDc As Long, hBmp As Long
    #End If

    tCellRect = GetRangeRect(ByVal target)
    hDc = GetDC(0)
    hMemoryDC = CreateCompatibleDC(hDc)

    With tCellRect
        hBmp = CreateCompatibleBitmap(hDc, (.Right - .Left), (.Bottom - .Top))
        DeleteObject SelectObject(hMemoryDC, hBmp)
        BitBlt hMemoryDC, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        hDc, .Left, .Top, SRCCOPY
    End With

    ReleaseDC 0, hDc
    DeleteObject hBmp

End Sub


Private Sub UpdateCell(ByVal target As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    #If VBA7 Then
        Dim hDc As LongPtr
    #Else
        Dim hDc As Long
    #End If
    
    hDc = GetDC(0)
    Do
        With tCellRect
            If ActiveSheet Is oTargetCell.Parent And IsCellVisible(oTargetCell) And GetActiveWindow = Application.hWnd Then
                If tCellRect.Left <> GetRangeRect(oTargetCell).Left Or _
                .Top <> GetRangeRect(oTargetCell).Top Or _
                .Right <> GetRangeRect(oTargetCell).Right Or _
                .Bottom <> GetRangeRect(oTargetCell).Bottom Then
                    bRangeRectHasChanged = True
                    tCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    scrollCell oTargetCell, Delay, RightToLeft
                    oTargetCell.NumberFormat = ";;;"
                End If
                If RightToLeft Then
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    (.Bottom - .Top), _
                    hMemoryDC, lXOffset - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    hMemoryDC, (.Right - .Left) - lXOffset, 0, SRCCOPY
                End If
                If lXOffset >= (.Right - .Left) * 2 Then lXOffset = 0
                lXOffset = lXOffset + 1
                SetDelay Delay  'Secs.
            End If
        End With
        DoEvents
    Loop Until bScrolling = False
    ReleaseDC 0, hDc


End Sub


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    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
    PTtoPX = Points * 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 Obj
        GetRangeRect.Left = oPane.PointsToScreenPixelsX(.Left)
        GetRangeRect.Top = oPane.PointsToScreenPixelsY(.Top)
        GetRangeRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width - 2)
        GetRangeRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height)
    End With

End Function


Private Function IsCellVisible(ByVal Cell As Range) As Boolean

    With Cell
        IsCellVisible = .Left >= ActiveWindow.VisibleRange.Left And .Top >= ActiveWindow.VisibleRange.Top
    End With

End Function


Private Sub SetDelay(ByVal TimeOut As Single)

    Dim t As Single

    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut / 100

End Sub

Private Sub Auto_Close()

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

    bScrolling = False
    bRangeRectHasChanged = False
    lXOffset = 0
    DeleteObject hMemoryDC
    
    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)
        
        
        Atom_ID = CInt(GetProp(Application.hWnd, "HorzAlignment"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        lHorzAlignment = CLng(Left(sBuffer, lRet))
        
        Range(sRangeAddr).NumberFormat = sNumberFormat
        Range(sRangeAddr).HorizontalAlignment = lHorzAlignment
        
        RemoveProp Application.hWnd, "CellAddress"
        RemoveProp Application.hWnd, "NumberFormat"
        RemoveProp Application.hWnd, "HorzAlignment"
        
    End If
    
End Sub
 
Upvote 0
Jaafar Tribak said:
This is an update of the above code that takes into account the scenario where the user might close the workbook without first stopping the scrolling .

Workbook Update



In a Standard Module:
VBA 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

#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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () 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 hMemoryDC 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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetActiveWindow Lib "user32" () 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 hMemoryDC As Long

#End If


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 tCellRect As RECT
Private oTargetCell As Range
Private bScrolling As Boolean
Private bRangeRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long
Private lXOffset As Long



Public Sub StartScrolling()

    '//Scroll the text in Cell B4 from Right to Left.
    Call scrollCell(TargetCell:=Range("B4"), Delay:=0.5, RightToLeft:=True)
   
End Sub

Public Sub StopScrolling()

    Call Auto_Close

End Sub



Private Sub scrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    Application.OnTime Now, "'ScrollCellNow " & Chr$(34) & TargetCell.Address & Chr$(34) & "," & Delay & "," & RightToLeft & "'"
   
End Sub


Sub ScrollCellNow(ByVal TargetCellAddr As String, ByVal Delay As Single, ByVal RightToLeft As Boolean)

    Dim iAtom_ID As Integer
   
    If bScrolling = False Then
        If Range(TargetCellAddr).Cells.Count > 1 Then Exit Sub
        bScrolling = True
        Set oTargetCell = Range(TargetCellAddr)
        iAtom_ID = GlobalAddAtom(oTargetCell.Address)
        SetProp Application.hWnd, "CellAddress", iAtom_ID
        If ActiveCell.Address = oTargetCell.Address Then oTargetCell.Offset(2).Select
        Sleep 150
        If Not bRangeRectHasChanged Then
            lHorzAlignment = oTargetCell.HorizontalAlignment
            iAtom_ID = GlobalAddAtom(CStr(oTargetCell.HorizontalAlignment))
            SetProp Application.hWnd, "HorzAlignment", iAtom_ID
            oTargetCell.HorizontalAlignment = xlLeft
        End If
        Call TakeCellSnapShot(oTargetCell)
        If Not bRangeRectHasChanged Then
            sNumberFormat = oTargetCell.NumberFormat
            iAtom_ID = GlobalAddAtom(oTargetCell.NumberFormat)
            SetProp Application.hWnd, "NumberFormat", iAtom_ID
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell(oTargetCell, Delay, RightToLeft)
        End If
    End If

End Sub


Private Sub TakeCellSnapShot(ByVal target As Range)

    #If VBA7 Then
        Dim hDc As LongPtr, hBmp As LongPtr
    #Else
        Dim hDc As Long, hBmp As Long
    #End If

    tCellRect = GetRangeRect(ByVal target)
    hDc = GetDC(0)
    hMemoryDC = CreateCompatibleDC(hDc)

    With tCellRect
        hBmp = CreateCompatibleBitmap(hDc, (.Right - .Left), (.Bottom - .Top))
        DeleteObject SelectObject(hMemoryDC, hBmp)
        BitBlt hMemoryDC, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        hDc, .Left, .Top, SRCCOPY
    End With

    ReleaseDC 0, hDc
    DeleteObject hBmp

End Sub


Private Sub UpdateCell(ByVal target As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    #If VBA7 Then
        Dim hDc As LongPtr
    #Else
        Dim hDc As Long
    #End If
   
    hDc = GetDC(0)
    Do
        With tCellRect
            If ActiveSheet Is oTargetCell.Parent And IsCellVisible(oTargetCell) And GetActiveWindow = Application.hWnd Then
                If tCellRect.Left <> GetRangeRect(oTargetCell).Left Or _
                .Top <> GetRangeRect(oTargetCell).Top Or _
                .Right <> GetRangeRect(oTargetCell).Right Or _
                .Bottom <> GetRangeRect(oTargetCell).Bottom Then
                    bRangeRectHasChanged = True
                    tCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    scrollCell oTargetCell, Delay, RightToLeft
                    oTargetCell.NumberFormat = ";;;"
                End If
                If RightToLeft Then
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    (.Bottom - .Top), _
                    hMemoryDC, lXOffset - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    hMemoryDC, (.Right - .Left) - lXOffset, 0, SRCCOPY
                End If
                If lXOffset >= (.Right - .Left) * 2 Then lXOffset = 0
                lXOffset = lXOffset + 1
                SetDelay Delay  'Secs.
            End If
        End With
        DoEvents
    Loop Until bScrolling = False
    ReleaseDC 0, hDc


End Sub


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    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
    PTtoPX = Points * 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 Obj
        GetRangeRect.Left = oPane.PointsToScreenPixelsX(.Left)
        GetRangeRect.Top = oPane.PointsToScreenPixelsY(.Top)
        GetRangeRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width - 2)
        GetRangeRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height)
    End With

End Function


Private Function IsCellVisible(ByVal Cell As Range) As Boolean

    With Cell
        IsCellVisible = .Left >= ActiveWindow.VisibleRange.Left And .Top >= ActiveWindow.VisibleRange.Top
    End With

End Function


Private Sub SetDelay(ByVal TimeOut As Single)

    Dim t As Single

    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut / 100

End Sub

Private Sub Auto_Close()

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

    bScrolling = False
    bRangeRectHasChanged = False
    lXOffset = 0
    DeleteObject hMemoryDC
   
    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)
       
       
        Atom_ID = CInt(GetProp(Application.hWnd, "HorzAlignment"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        lHorzAlignment = CLng(Left(sBuffer, lRet))
       
        Range(sRangeAddr).NumberFormat = sNumberFormat
        Range(sRangeAddr).HorizontalAlignment = lHorzAlignment
       
        RemoveProp Application.hWnd, "CellAddress"
        RemoveProp Application.hWnd, "NumberFormat"
        RemoveProp Application.hWnd, "HorzAlignment"
       
    End If
   
End Sub
Click to expand...
Thank you!! I had no idea you could get the marquee effect that smooth, all the other examples I’ve saw were pretty clunky but this is great. A fair bit I need to learn before I understand how this works but thank you for your time and replies Jaafar!
 
Upvote 0
Jaafar Tribak said:
This is an update of the above code that takes into account the scenario where the user might close the workbook without first stopping the scrolling .

Workbook Update



In a Standard Module:
VBA 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

#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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () 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 hMemoryDC 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 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetActiveWindow Lib "user32" () 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 hMemoryDC As Long

#End If


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 tCellRect As RECT
Private oTargetCell As Range
Private bScrolling As Boolean
Private bRangeRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long
Private lXOffset As Long



Public Sub StartScrolling()

    '//Scroll the text in Cell B4 from Right to Left.
    Call scrollCell(TargetCell:=Range("B4"), Delay:=0.5, RightToLeft:=True)
   
End Sub

Public Sub StopScrolling()

    Call Auto_Close

End Sub



Private Sub scrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    Application.OnTime Now, "'ScrollCellNow " & Chr$(34) & TargetCell.Address & Chr$(34) & "," & Delay & "," & RightToLeft & "'"
   
End Sub


Sub ScrollCellNow(ByVal TargetCellAddr As String, ByVal Delay As Single, ByVal RightToLeft As Boolean)

    Dim iAtom_ID As Integer
   
    If bScrolling = False Then
        If Range(TargetCellAddr).Cells.Count > 1 Then Exit Sub
        bScrolling = True
        Set oTargetCell = Range(TargetCellAddr)
        iAtom_ID = GlobalAddAtom(oTargetCell.Address)
        SetProp Application.hWnd, "CellAddress", iAtom_ID
        If ActiveCell.Address = oTargetCell.Address Then oTargetCell.Offset(2).Select
        Sleep 150
        If Not bRangeRectHasChanged Then
            lHorzAlignment = oTargetCell.HorizontalAlignment
            iAtom_ID = GlobalAddAtom(CStr(oTargetCell.HorizontalAlignment))
            SetProp Application.hWnd, "HorzAlignment", iAtom_ID
            oTargetCell.HorizontalAlignment = xlLeft
        End If
        Call TakeCellSnapShot(oTargetCell)
        If Not bRangeRectHasChanged Then
            sNumberFormat = oTargetCell.NumberFormat
            iAtom_ID = GlobalAddAtom(oTargetCell.NumberFormat)
            SetProp Application.hWnd, "NumberFormat", iAtom_ID
            oTargetCell.NumberFormat = ";;;"
            Call UpdateCell(oTargetCell, Delay, RightToLeft)
        End If
    End If

End Sub


Private Sub TakeCellSnapShot(ByVal target As Range)

    #If VBA7 Then
        Dim hDc As LongPtr, hBmp As LongPtr
    #Else
        Dim hDc As Long, hBmp As Long
    #End If

    tCellRect = GetRangeRect(ByVal target)
    hDc = GetDC(0)
    hMemoryDC = CreateCompatibleDC(hDc)

    With tCellRect
        hBmp = CreateCompatibleBitmap(hDc, (.Right - .Left), (.Bottom - .Top))
        DeleteObject SelectObject(hMemoryDC, hBmp)
        BitBlt hMemoryDC, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        hDc, .Left, .Top, SRCCOPY
    End With

    ReleaseDC 0, hDc
    DeleteObject hBmp

End Sub


Private Sub UpdateCell(ByVal target As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

    #If VBA7 Then
        Dim hDc As LongPtr
    #Else
        Dim hDc As Long
    #End If
   
    hDc = GetDC(0)
    Do
        With tCellRect
            If ActiveSheet Is oTargetCell.Parent And IsCellVisible(oTargetCell) And GetActiveWindow = Application.hWnd Then
                If tCellRect.Left <> GetRangeRect(oTargetCell).Left Or _
                .Top <> GetRangeRect(oTargetCell).Top Or _
                .Right <> GetRangeRect(oTargetCell).Right Or _
                .Bottom <> GetRangeRect(oTargetCell).Bottom Then
                    bRangeRectHasChanged = True
                    tCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    scrollCell oTargetCell, Delay, RightToLeft
                    oTargetCell.NumberFormat = ";;;"
                End If
                If RightToLeft Then
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    (.Bottom - .Top), _
                    hMemoryDC, lXOffset - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt hDc, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    hMemoryDC, (.Right - .Left) - lXOffset, 0, SRCCOPY
                End If
                If lXOffset >= (.Right - .Left) * 2 Then lXOffset = 0
                lXOffset = lXOffset + 1
                SetDelay Delay  'Secs.
            End If
        End With
        DoEvents
    Loop Until bScrolling = False
    ReleaseDC 0, hDc


End Sub


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    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
    PTtoPX = Points * 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 Obj
        GetRangeRect.Left = oPane.PointsToScreenPixelsX(.Left)
        GetRangeRect.Top = oPane.PointsToScreenPixelsY(.Top)
        GetRangeRect.Right = oPane.PointsToScreenPixelsX(.Left + .Width - 2)
        GetRangeRect.Bottom = oPane.PointsToScreenPixelsY(.Top + .Height)
    End With

End Function


Private Function IsCellVisible(ByVal Cell As Range) As Boolean

    With Cell
        IsCellVisible = .Left >= ActiveWindow.VisibleRange.Left And .Top >= ActiveWindow.VisibleRange.Top
    End With

End Function


Private Sub SetDelay(ByVal TimeOut As Single)

    Dim t As Single

    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= TimeOut / 100

End Sub

Private Sub Auto_Close()

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

    bScrolling = False
    bRangeRectHasChanged = False
    lXOffset = 0
    DeleteObject hMemoryDC
   
    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)
       
       
        Atom_ID = CInt(GetProp(Application.hWnd, "HorzAlignment"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        lHorzAlignment = CLng(Left(sBuffer, lRet))
       
        Range(sRangeAddr).NumberFormat = sNumberFormat
        Range(sRangeAddr).HorizontalAlignment = lHorzAlignment
       
        RemoveProp Application.hWnd, "CellAddress"
        RemoveProp Application.hWnd, "NumberFormat"
        RemoveProp Application.hWnd, "HorzAlignment"
       
    End If
   
End Sub
Click to expand...
Hi @Jaafar Tribak
The party seems to have ended but its never too late . Unfortunately I moved away from windows and this doesn't seem to work on Excel for Mac, is it possible you have a version that will work onExcel for Mac?

Thanks
 
Upvote 0
panny0109 said:
Hi @Jaafar Tribak
The party seems to have ended but its never too late . Unfortunately I moved away from windows and this doesn't seem to work on Excel for Mac, is it possible you have a version that will work onExcel for Mac?

Thanks
Click to expand...
I am afraid, I know nothing about excel for Mac ...AFAIK, you cannot use Windows API calls on a Mac.
 
Upvote 0
Hello,
sorry for bumping into this interesting topic like this, but I have been looking for such kind of solution but unfortunately I cannot get this running.
Getting the error attached. Macros are enabled and any other macros are working but not this. Any advice what might be wrong?

Br,
Hakan
 

Attachments

  • Screenshot 2021-02-23 100039.jpg
    Screenshot 2021-02-23 100039.jpg
    43.1 KB · Views: 17
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
Listbox Scroll
Replies
5
Views
414
6StringJazzer
6StringJazzer
D
  • Question Question
Filter through a table, and display the results as you type
2
Replies
10
Views
172
dpaton05
D
Excelwhatsthat
  • Question Question
Scroll enabled to minimise table view...but need conditional formatting
Replies
0
Views
79
Excelwhatsthat
Excelwhatsthat
R
  • Question Question
Keep text within a merged row centered on screen when scrolling horizontally
Replies
1
Views
432
ISY
I
B
  • Solved
scrolling in combobox within userform not working
Replies
1
Views
313
Fluff
Fluff

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

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