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
hakanfa said:
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
Click to expand...

Hello Hakan, by looking at your error message your file type seems to be saved as “.xls”? If this is the case, please save as “.xlsm” (macro enabled worksheet)
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
hakanfa said:
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
Click to expand...
Have you changed anything in the demo file ?
Try fully qualifying the module as follows and see if it works:
VBA Code: 
Private Sub scrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

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

BTW, the code can be improved further as I have just realised that if the scrolling-text cell is off-screen when first calling the StartScrolling macro, the code won't work... Also, the scenario where the scrolling cell has borders around has not ben handled properly.

I'll post an update later.
 
Upvote 0
belgiumcookies said:
Hello Hakan, by looking at your error message your file type seems to be saved as “.xls”? If this is the case, please save as “.xlsm” (macro enabled worksheet)
Click to expand...
Hi, this was a mistake (blush, how did I not recognize that), as when I downloaded the file it was in .xls mode. I changed that to .xlsm but no affect on the error (beside that it says the same but with .xlsm extension.
 
Upvote 0
Jaafar Tribak said:
Have you changed anything in the demo file ?
Try fully qualifying the module as follows and see if it works:
VBA Code: 
Private Sub scrollCell(ByVal TargetCell As Range, ByVal Delay As Single, Optional ByVal RightToLeft As Boolean = True)

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

BTW, the code can be improved further as I have just realised that if the scrolling-text cell is off-screen when first calling the StartScrolling macro, the code won't work... Also, the scenario where the scrolling cell has borders around has not ben handled properly.

I'll post an update later.
Click to expand...
Hi,
thank you for the reply. I have not changed anything, beside that when I download the file it was in .xls mode, did a "save as" and to .xlsm mode. Tested with borh 32-bit and 64-bit excels. Same error.
 
Upvote 0
Sorry for the late response.

This new version has the following improvements:

1- The scroll-text cell can be anywhere (on-screen or off-screen) when first invoking the text-scroll macro.
2- While the text is scrolling, the user can freely and dynamically change the Row & Column size of the cell, the worksheet zoom etc, the scrolling space will adjust itself automatically.
3- The code uses Device Context double buffering for achieving smoother scrolling.
4- The user can dynamically change the scrolling speed and scroll direction.

I have tested the code on Excel 2007/Win 32bit and Excel 2016 64bit/Win 64bit. The scrolling is quite smooth without any flicker.

I hope this works as advertised in other excel\windows settings as well.


File Demo:
ScrollText_V2_.xls





- Code in a Standard Module (as per the above file demo)
VBA Code: 
Option Explicit

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 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

#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 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

#End If


Private Const MAX_SPEED = 10

Private tMemDc As MemDc
Private oTargetCell As Range
Private sngDelay As Single
Private bRightToLeft As Boolean
Private bScrolling As Boolean
Private bCellRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long




Public Sub Scroll_ON_OFF_Macro()

    '// Scroll the text in Cell B4 from Right to Left.
    '// Scroll Speed 1 to 10 = MAX_SPEED

    With Sheet1
        If .Shapes("Check Box Scroll").ControlFormat.Value = 1 Then
            .Shapes("Check Box Direction").ControlFormat.Value = 1
            Call ScrollCell(TargetCell:=.Range("B4"), Speed:=MAX_SPEED / 2, RightToLeft:=True)
        Else
            Call Reset
        End If
    End With
    
End Sub


Sub Scroll_Speed_Macro(Optional ByVal Dummy As Boolean)
    sngDelay = MAX_SPEED - Range(Sheet1.Shapes("Scroll Bar").ControlFormat.LinkedCell).Value
End Sub

Sub Scroll_Direction_Macro(Optional ByVal Dummy As Boolean)
    If Sheet1.Shapes("Check Box Direction").ControlFormat.Value = 1 Then
        bRightToLeft = True
    Else
        bRightToLeft = False
    End If
End Sub




'_____________________________PRIVATE ROUTINES__________________________________________


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

    If TargetCell.Cells.Count > 1 Then
        MsgBox "You cannot apply the text-scroll feature to multiple cells."
        Exit Sub
    End If
    
    Set oTargetCell = TargetCell
    If Speed > MAX_SPEED Then Speed = MAX_SPEED
    If Speed < 1 Then Speed = 1
    sngDelay = MAX_SPEED - Speed
    bRightToLeft = RightToLeft
    Sheet1.Range(Sheet1.Shapes("Scroll Bar").ControlFormat.LinkedCell).Value = MAX_SPEED - sngDelay
    
    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
        If Range(oTargetCell.Address).Cells.Count > 1 Then Exit Sub
        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 Resume Next
    
    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
                    Call Sleep(200)
                    oTargetCell.NumberFormat = ";;;"
                End If
                If bRightToLeft Then
                    Call BitBlt(hDC, .Left, .Top, (.Right - .Left), (.Bottom - .Top) - 2, tMemDc.hDC, lXOffset - (.Right - .Left), 0, SRCCOPY)
                Else
                   Call BitBlt(hDC, .Left, .Top, (.Right - .Left), (.Bottom - .Top) - 2, tMemDc.hDC, (.Right - .Left) - lXOffset, 0, SRCCOPY)
                End If
                If lXOffset > tMemDc.Width * 2 Then lXOffset = 0
                If sngDelay < MAX_SPEED Then
                    Call SetDelay(sngDelay / MAX_SPEED)
                Else
                    Call Reset
                    Exit Do
                End If
                lXOffset = lXOffset + 1
            End If
        End With
    Loop Until bScrolling = False
    
    lXOffset = 0
    Call ReleaseDC(0, hDC)
    Call DeleteDC(tMemDc.hDC)

End Sub

Private Sub SetDelay(ByVal TimeOut As Single)
    Dim t As Single
    t = Timer
    Do: Loop Until Timer - t >= TimeOut / 100
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)
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 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 ResetControls()
    With Sheet1
        .Shapes("Check Box Scroll").ControlFormat.Value = False
        .Shapes("Check Box Direction").ControlFormat.Value = 1
        .Shapes("Scroll Bar").ControlFormat.Value = 0
    End With
End Sub

Private 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
   
    Call ResetControls

    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")
    End If

End Sub

Private Sub Auto_Close()
    Call Reset
End Sub
 
Last edited:
Upvote 0
Editing time is over.

Just to mention that I have just made a small, albeit important modification to the code so that it will also work with merged cells.

I have updated the above demo file to take merged cells into account.
 
Upvote 0
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.
Scrolling Text.png
 
Upvote 0
@Flamesteel

See if this works for you :

Demo File:
ScrollText_Scores_Test.xlsm


The slight screen-flicker that you see in the below gif is mostly due to the screen-capture software that I used to create the gif for posting it here.. It is not due to the code which actually runs quite smoothly at least when I tested it.




I actually had to update the code to add a couple of new features.

Updated code: (Standard Module)
VBA Code: 
Option Explicit

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 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) 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 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

#End If


Private Const MAX_SPEED = 10

Private tMemDc As MemDc
Private oTargetCell As Range
Private sngDelay As Single
Private bRightToLeft As Boolean
Private bScrolling As Boolean
Private bCellRectHasChanged As Boolean
Private sNumberFormat As String
Private lHorzAlignment As Long
Private vPrevCellValue As Variant




Public Sub Start()
    If bScrolling = False Then
        Call ScrollCell(TargetCell:=Sheet1.Range("B4"), Speed:=7, RightToLeft:=True)
    End If
End Sub

Public Sub Finish()
    Call Reset
End Sub



'_____________________________PRIVATE ROUTINES__________________________________________


Private Sub ScrollCell(ByVal TargetCell As Range, ByVal Speed As Single, Optional ByVal RightToLeft As Boolean = True)
    Set oTargetCell = TargetCell
    vPrevCellValue = TargetCell.Value
    If Speed >= MAX_SPEED Then Speed = MAX_SPEED - 1
    If Speed < 1 Then Speed = 1
    sngDelay = Speed
    bRightToLeft = RightToLeft
    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
            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)
    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)
            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 If

End Function


Private Sub UpdateCell()

    Const SRCCOPY = &HCC0020
    Const SM_CYBORDER = 6
    Const SM_CXVSCROLL = 2
    Const SM_CYDLGFRAME = 8

    #If Win64 Then
        Dim hDC As LongLong
    #Else
        Dim hDC As Long
    #End If
    
    Dim tCellRect As RECT, tPrevCellRect As RECT
    Dim tAppRect As RECT, t_InterRect As RECT, tVisibleRect As RECT
    Dim lXOffset As Long, lVertScrollBarWidth As Long
    

    On Error Resume Next
    
    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 IntersectRect(t_InterRect, tAppRect, tCellRect)
        Call GetWindowRect(Application.hwnd, tAppRect)
        With tCellRect
            If CellOnScreen Then
                If EqualRect(tCellRect, tPrevCellRect) = 0 Then
                    bCellRectHasChanged = True
                    tPrevCellRect = GetRangeRect(oTargetCell)
                    oTargetCell.NumberFormat = sNumberFormat
                    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 bRightToLeft Then
                    Call BitBlt(hDC, .Left, .Top, (t_InterRect.Right - t_InterRect.Left) - lVertScrollBarWidth - 2, (.Bottom - .Top) - 2, tMemDc.hDC, lXOffset - (.Right - .Left), 0, SRCCOPY)
                Else
                   Call BitBlt(hDC, .Left, .Top, (t_InterRect.Right - t_InterRect.Left) - lVertScrollBarWidth - 2, (.Bottom - .Top) - 2, tMemDc.hDC, (.Right - .Left) - lXOffset, 0, SRCCOPY)
                End If
                If lXOffset > tMemDc.Width * 2 Then lXOffset = 0
                If sngDelay <= MAX_SPEED Then
                    Call SetDelay((MAX_SPEED - sngDelay) / 10)
                Else
                    Call Reset
                    Exit Do
                End If
                lXOffset = lXOffset + 1
            End If
        End With
    Loop Until bScrolling = False
    
    lXOffset = 0
    Call ReleaseDC(0, hDC)
    Call DeleteDC(tMemDc.hDC)

End Sub


Private Sub SetDelay(ByVal TimeOut As Single)
    Dim t As Single
    t = Timer
    Do
        DoEvents
    Loop Until (Timer - t) >= TimeOut / IIf(TimeOut = 0.1, 1000, 50)
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)
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 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 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")
    End If

End Sub

Private Sub Auto_Close()
    Call Reset
End Sub
 
Upvote 0
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
 
Upvote 0
@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
Gross & Net.png
 
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,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

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