Scrolling Text

[neo2]

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

 

[neo2]

Thanks alot for all the help guys.

Jaafar, Can you modify your code so that it will work in merge cells. I am mergeing cell B1 to R1, so i would like to see the text scroll across that entire section.

Also when I run the macro all I see is a moving line at the top and bottom of the cell, I don't actually see the text I typed in.

Lastly I would like the macro to run when the worksheet is opened.

Thanks alot for the help.

 

[dado6612]

WOW
this is very cool, but i have some additional questions about this
I didn't try to change code on my self cause I don't know so much about codes
questions
1. Can this work with merged cells? I wish to merge G11:H12
2. Can text have middle align?
3. Can I have 2 or more independent texts with scroll option? Beside G11:H12 I wish to have some in L11:L12
4. Can text in cell be hyperlink?
5. Can text have blinking effect with scrolling effect?
6. Can text start to scroll and flash since workbook is opened?
7. Can text cook to me?

Ok, 7 is a joke.

What I exactly wish for is:
when workbook is opened, automatically to start:
1. text in G11:H12 merged cell to scroll and flash with middle align
2. hyperlink text in I11:I12 merged cell to flash with middle align
3. hyperlink text in L11:L12 merged cell to scroll and flash with middle align

There is some problem, the sheet where I need it can be copied with button. So I need copy that scrolling and flashing code to new sheet too.
Sheet name is dado6612

Thanks

 

[Jaafar Tribak]

Hi neo2 and dado6612.

Here is an update that works for merged cells with a blinking text.

tested on excel 2003 and worked very smoothly.

Workbook Example.


In a Standard Module :

'// 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".
'//
'// Upadted on 7/08/2010 to work for Merged Cells
'// plus blinking text.
'//
'// 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 bRangeRectHasChanged As Boolean
Private vNumberFormat As String
Private vHorzAlignment As Long
Private lMemoryDC1 As Long
Private lMemoryDC2 As Long
Private lWBHwnd As Long
Private i As Long
Private bScrolling As Boolean
 
Public Sub StartScrolling()
 
    '//Scroll the text in Cell B4 from Right to Left.
    Call ScrollCell(Range("B4:D5"), 0.01, True)
 
End Sub
 
Public Sub StopScrolling()
 
    '// Set flg to exit the loop.
    bScrolling = False
    i = 0
 
    '//Reset this flag.
    bRangeRectHasChanged = False
 
    '//Reset Cell's settings.
    oTargetCell.NumberFormat = vNumberFormat
    oTargetCell.HorizontalAlignment = vHorzAlignment
 
End Sub
 
Private Sub TakeCellSnapShots(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.
    lMemoryDC1 = CreateCompatibleDC(lDC)
 
       lMemoryDC2 = 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(lMemoryDC1, lBmp)
 
        '//Copy the target cell image onto the Mem DC.
        BitBlt lMemoryDC1, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        lDC, .Left, .Top, SRCCOPY
 
 
        vNumberFormat = Target.NumberFormat
 
        Target.NumberFormat = ";;;"
 
 
         lBmp = CreateCompatibleBitmap _
        (lDC, (.Right - 1 - .Left), (.Bottom - .Top))
 
        '//Select the Bmp onto our mem DC.
        DeleteObject SelectObject(lMemoryDC2, lBmp)
 
        '//Copy the target cell image onto the Mem DC.
        BitBlt lMemoryDC2, 0, 0, (.Right - .Left), (.Bottom - .Top), _
        lDC, .Left, .Top, SRCCOPY
 
        Target.NumberFormat = vNumberFormat
 
    End With
 
    '//CleanUp.
    ReleaseDC 0, lDC
    ReleaseDC lMemoryDC1, 0
    ReleaseDC lMemoryDC2, 0
 
End Sub
 
Private Sub ScrollCell _
(ByVal Target As Range, ByVal Delay As Single, _
Optional ByVal RightToLeft As Boolean)
 
    '//Exit if text already scrolling.
    If bScrolling Then Exit Sub
    '// Set Flag.
    bScrolling = True
 
    '//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 TakeCellSnapShots(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
 
    Static j 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
                bScrolling = False
                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), _
                    lMemoryDC1, i - (.Right - .Left), 0, SRCCOPY
                Else
                    BitBlt lDC, .Left, .Top, (.Right - .Left), _
                    .Bottom - .Top, _
                    lMemoryDC1, (.Right - .Left) - i, 0, SRCCOPY
                End If
 
                If i >= (.Right - .Left) * 2 Then i = 0
 
            End With
 
 
            If j > 20 Then
                j = 0
                With tPrevRect
 
                    If RightToLeft Then
                        BitBlt lDC, .Left + 1, .Top, (.Right - .Left), _
                        (.Bottom - .Top), _
                        lMemoryDC2, i - (.Right - .Left), 0, SRCCOPY
                    Else
                        BitBlt lDC, .Left, .Top, (.Right - .Left), _
                        .Bottom - .Top, _
                        lMemoryDC2, (.Right - .Left) - i, 0, SRCCOPY
                    End If
                    If i >= (.Right - .Left) * 2 Then i = 0
                End With
 
                SetDelay Delay * 15
            End If
               i = i + 1
        j = j + 1
 
        SetDelay Delay
        End If
 
        DoEvents
 
    Loop Until Not bScrolling
 
    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

The blinking of the text could have been made more flexible and smoother if I had used a Windows timer instead of just using a loop but I try to avoid using Timers as much as posiible.

Again, this code also works even in edit mode.

 

[dado6612]

Thanks

 

[neo2]

Hello Jaafer,

http://www.speedyshare.com/files/23724642/workbook.xls

I've attached a copy of my workbook, you will see the area in which I would like the text to scroll. Can you take off the flashing effect, I do not particularly like that.

I also need the macro to run upon opening the workbook.

Thanks

 

[Jaafar Tribak]

Hello Jaafer,

http://www.speedyshare.com/files/23724642/workbook.xls

I've attached a copy of my workbook, you will see the area in which I would like the text to scroll. Can you take off the flashing effect, I do not particularly like that.

I also need the macro to run upon opening the workbook.

Thanks

Hi neo2.

Do you mean the area in yellow ( ie : The Range B1:S1) or the range B1:S16 ?

 

[neo2]

Hi Jaafar,

Yes the area highlighted in yellow. Range B1:S1. Thanks

 

[Jaafar Tribak]

Hi Jaafar,

Yes the area highlighted in yellow. Range B1:S1. Thanks

Your workbook has frozen panes and for some reason, the text scrolling doesn't work with the frozen pane setting.

I'll explore this further and let you know.

 

[neo2]

Thanks Jaafar. Really appreciate it!

 

[Jaafar Tribak]

Thanks Jaafar. Really appreciate it!

Hi.

I am afraid neo2, I can't seem to make this work for worksheets with frozen panes.

If you think it is worth to redesign your workbook without the frozen panes then maybe I can help.