Scrolling Text

[neo2]

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

 

[Jaafar Tribak]

Hi Serjape,

Here is the code . As per your request, the text starts scrolling non stop until it is changed or deleted. Starting when workbook is opened and no start or stop buttons.

I have also added a high-resolution performance timer for better control of the scroll speed. I have added 6 different speeds to choose from.

Now the scrolling is always very smooth, you can better control its speed as well as its direction and just like before, the scrolling persists while editing other cells. However, one ugly downside is that the code runs a continuous loop which has a bad performance hit... I have tried using a timer instead of a loop but I haven't obtained the same scroll smoothness.

ScrollText_V3_.xlsm








1- Main API code in a Standard Module:

Option Explicit

Public Enum eScroll_Speed
    Speed1 = 32
    Speed2 = 16
    Speed3 = 8
    Speed4 = 4
    Speed5 = 2
    Speed6 = 1
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
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 GetActiveWindow 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 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 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 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 QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

#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 GetActiveWindow 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 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 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 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 QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

#End If

Private tMemDc As MemDc
Private oTargetCell As Range
Private bRightToLeft As Boolean
Private bScrolling As Boolean
Private bCellRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long
Private lSpeed As eScroll_Speed




'___________________________________ PUBLIC ROUTINES__________________________________________


Public Sub ScrollCell( _
    ByVal TargetCell As Range, _
    ByVal Speed As eScroll_Speed, _
    Optional ByVal RightToLeft As Boolean = True _
)

    Call Reset
    Set oTargetCell = TargetCell
    If oTargetCell.NumberFormat = ";;;" Then oTargetCell.NumberFormat = "General"
    lSpeed = Speed
    bRightToLeft = RightToLeft
    Call ScrollCellNow
    
End Sub

Public Sub Reset()

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

    bScrolling = False
    bCellRectHasChanged = False

    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
        
        Call RemoveProp(Application.hwnd, "CellAddress")
        Call RemoveProp(Application.hwnd, "NumberFormat")
        Call RemoveProp(Application.hwnd, "HorzAlignment")
        
        Debug.Print "reset"
    End If

End Sub



'___________________________________ PRIVATE ROUTINES__________________________________________

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
            lHorzAlignment = oTargetCell.HorizontalAlignment
            iAtom_ID = GlobalAddAtom(CStr(oTargetCell.HorizontalAlignment))
            Call SetProp(Application.hwnd, "HorzAlignment", iAtom_ID)
            oTargetCell.HorizontalAlignment = xlLeft
        End If
        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
    tMemDc = TakeCellSnapShot(oTargetCell)

End Sub

Private Function TakeCellSnapShot(ByVal Target As Range) As MemDc

    Const SRCCOPY = &HCC0020

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

    Set oStdPic = PicFromRange(Target)
    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)
        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)
    
    With TakeCellSnapShot
        .hDC = hMemoryDC
        .Width = tBM.bmWidth
    End With
    
    Call ReleaseDC(0, hDC)
    Call DeleteDC(hTmpMemDC)
    Call DeleteObject(hBmp)
    Call DeleteObject(hBrush)
    Call DeleteObject(hRgn)

End Function

Private Sub UpdateCell()

    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 lXOffset As Long
    
    On Error GoTo errHandler
    Application.EnableCancelKey = xlErrorHandler
    
    hDC = GetDC(0)
    Do
       DoEvents
       tCellRect = GetRangeRect(oTargetCell)
        With tCellRect
            If CellOnScreen Then
                If EqualRect(tCellRect, tPrevCellRect) = 0 Then
                    bCellRectHasChanged = True
                    tPrevCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    Call ScrollCellNow
                    oTargetCell.NumberFormat = ";;;"
                End If
                If bRightToLeft Then
                    Call BitBlt(hDC, .Left, .Top, (.Right - .Left), (.Bottom - .Top) - 4, tMemDc.hDC, lXOffset - (.Right - .Left), 0, SRCCOPY)
                Else
                   Call BitBlt(hDC, .Left, .Top, (.Right - .Left), (.Bottom - .Top) - 4, tMemDc.hDC, (.Right - .Left) - lXOffset, 0, SRCCOPY)
                End If
                If lXOffset > tMemDc.Width * 2 Then lXOffset = 0
                Call SetDelay(lSpeed)
                lXOffset = lXOffset + 1
            End If
        End With
    Loop Until bScrolling = False
    
errHandler:
    
    lXOffset = 0
    Call ReleaseDC(0, hDC)
    Call DeleteDC(tMemDc.hDC)
    Call Reset

End Sub

Private Sub SetDelay(ByVal interval As eScroll_Speed)

    Dim curFrq As Currency
    Dim curStartPerformCounter As Currency
    Dim curEndPerformanceCounter As Currency
    
    If QueryPerformanceFrequency(curFrq) Then
        curFrq = curFrq / 1000
        If QueryPerformanceCounter(curStartPerformCounter) Then
            Do
                DoEvents
                Call QueryPerformanceCounter(curEndPerformanceCounter)
            Loop Until (curEndPerformanceCounter - curStartPerformCounter) / curFrq >= interval
        End If
    End If

End Sub

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 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 (GetActiveWindow = Application.hwnd) And (Not CellAndTaskBarOverlapping) And Not IsBackstageView
End Function

Private Function CellAndTaskBarOverlapping() As Boolean
    Dim tCellRect As RECT, tTaskBarRect As RECT, tIntersectionRect As RECT
    Call GetWindowRect(FindWindow("Shell_TrayWnd", vbNullString), tTaskBarRect)
    tCellRect = GetRangeRect(oTargetCell)
    CellAndTaskBarOverlapping = CBool(IntersectRect(tIntersectionRect, tTaskBarRect, tCellRect))
End Function

Private Function IsBackstageView() As Boolean
    IsBackstageView = CBool(FindWindowEx(Application.hwnd, 0, "FullpageUIHost", vbNullString))
End Function

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

    #If Win64 Then
        Static hImagePtr As LongLong
    #Else
        Static hImagePtr As Long
    #End If

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

    On Error GoTo errHandler
    
    Call DeleteObject(hImagePtr)
    rCell.Copy
    Call OpenClipboard(0)
    hImagePtr = GetClipboardData(CF_BITMAP)
    tCellRect = GetRangeRect(rCell)
    
    If hImagePtr Then
        With tCellRect
            hImagePtr = CopyImage(hImagePtr, IMAGE_BITMAP, (.Right - .Left), (.Bottom - .Top), LR_COPYRETURNORG)
        End With
        
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        With uPicInfo
            .Size = Len(uPicInfo)
            .Type = PICTYPE_BITMAP
            .hPic = hImagePtr
            .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 Sub Auto_Close()
    Call Reset
End Sub

2- Code Usage example in the ThisWorkbook Module:

Option Explicit

Private Const SCROLL_CELL As String = "Sheet1!B4"  '<< change scroll cell to suit.


Private Sub Workbook_Activate()
    If ActiveSheet Is Range(SCROLL_CELL).Parent And Not IsEmpty(Range(SCROLL_CELL)) Then
        Call ScrollCell(TargetCell:=Range(SCROLL_CELL), Speed:=Speed4, RightToLeft:=True) '<< change speed & direction as required.
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Reset
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh Is Range(SCROLL_CELL).Parent Then
        If Target.Address = Range(SCROLL_CELL).Address Then
            If Not IsEmpty(Target) Then
                Call ScrollCell(TargetCell:=Target, Speed:=Speed4, RightToLeft:=True) '<< change speed & direction as required.
            Else
                Call Reset
            End If
        End If
    End If
End Sub