我们已经尝试了各种vb脚本在Excel 2010中滚动显示一系列单元格中的文本。我发现了一个可以调整的出色脚本，但不幸的是，我只能使它与没有格式的文本一起使用。我似乎也没有办法无间隙地重复文本。
我已经附上了屏幕截图，其中以我们希望滚动的格式显示了文本。
它确实适用于输入到目标范围内的复制单元格的图片，但是excel电子表格的边缘会切断从屏幕外滚动的图片。
帮助！无论如何，我们都不是认真的编码员。谁能指出我们正确的方向？如果不可能，那么也很高兴知道。
感谢您的任何建议。
scrolling marquee text with formatting
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 StartScrollingRow()
'//Scroll the text in Cell Range from Right to Left.
Call ScrollCell(Range("B4:R4"), 0.01, True)
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