A 'floating' rounded rectangle

[Duncs]

I have a rounded rectangle in my Excel 2003 s/s. I want it to float, so that no mater where I scroll to within the s/s, it remains visible on the screen.

Is this possible and if so, how?

Duncs

[Oorang]

No not really. Shapes are tied to specific point in a worksheet object. You could intercept and update that point on every window resize, scroll, selection change, zoom, etc. but unfortunantly not all of those things have exposed events.

[Duncs]

Oh well, cheers then

Duncs

[Duncs]

Oorang,

I've seen the following code elsewhere:


' You can do this by putting the following code
' in the Sheet object for the worksheet in question:
' (You'll need to use the Textbox control from the
' Control Toolbox, not from the Drawing toolbar.) Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

With ActiveWindow.VisibleRange
' subsitute the name of the Textbox in question
TextBox1.Top = .Top + 5
TextBox1.Left = .Left + .Width - TextBox1.Width - 45
' 45 seems to be the right number of points--use fewer if
' you've hidden the scrollbars or the row headings
End With
End Sub


However, when I use it, it doesn't seem to work. Does this mean that the code doesn't work due to a small error, or it doesn't work due to the fact that it just doesn't work? I'm sure I've seen the floating shape somewhere, but I can't remember where.

Rgds

Duncs

[TomSchreiner]

Hi Duncs. The problem is not moving the shape, but finding an appropriate event to automate the movement. There really isn't one for scrolling. The closest you are going to get is the selection change event but there is no guarantee that the user will cooperate. You could subclass the worksheet window, but VBA is not fast enough so you would need a third party dll to do that. You could also use a timer which usually works well enough.

If you have rendering issues, see the InvalidateRect Function (http://msdn.microsoft.com/en-us/library/ms534893%28VS.85%29.aspx) to fix this problem...

Draw out Oval 1 on Sheet1. Paste this code into Sheet1:
Private Sub Worksheet_Activate()
Call StartTimer(Me.Shapes("Oval 1"))
End Sub

Private Sub Worksheet_Deactivate()
Call StopTimer
End Sub
Paste this code into the workbook class:
Private Sub Workbook_Open()
If ActiveSheet.CodeName = "Sheet1" Then Call StartTimer(Sheet1.Shapes("Oval 1"))
End Sub
Paste this code into a standard module:
Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private Const EventId As Long = 1
Private ShapeRef As Shape
Private PrevVisRng As Range

Public Sub StartTimer(o As Shape)
Set ShapeRef = o
Set PrevVisRng = ActiveWindow.VisibleRange
Call SetTimer(Application.hwnd, EventId, 10, AddressOf TimerTick)
End Sub

Public Sub StopTimer()
Call KillTimer(Application.hwnd, EventId)
End Sub

Private Sub TimerTick(ByVal hwnd As Long, ByVal uint1 As Long, ByVal nEventId As Long, ByVal dwParam As Long)
On Error Resume Next
Call MoveMyShape
End Sub

Private Sub MoveMyShape()
Static NewRotation As Single

With ShapeRef
NewRotation = NewRotation + 1
If NewRotation > 360 Then NewRotation = 0
.Rotation = NewRotation
End With

If Not (ActiveWindow.VisibleRange.Address = PrevVisRng.Address) Then
With ActiveWindow.VisibleRange
ShapeRef.Left = .Columns(.Columns.Count).Left - ShapeRef.Width
ShapeRef.Top = .Top + ShapeRef.Height
End With
Set PrevVisRng = ActiveWindow.VisibleRange
End If

End Sub
Select Sheet2 and then Sheet1 to fire Sheet1's activate event.

[TomSchreiner]

See attached example... :)

[malik641]

See attached example... :)
Hey TomSchreiner,

I really like your example. One thing, the following code should be added to the ThisWorkbook module:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopTimer
End Sub
I hope you don't mind, I played with it a little and made the shape "slide" into place. It's a little buggy, but it's working pretty well for the most part. When I first started, I thought it wouldn't be so long winded...but I was proven wrong :) Let me know what you think.

NOTE: Be careful when Clicking the scrollbar...my app doesn't like that so much for some reason.

WARNING: Please save all Excel documents before using! Better yet, close all other documents before using!

Here's the code (class module called clsShapeMover):
Option Explicit

Private dblCurrentLeft As Double, dblCurrentTop As Double
Private dblEndLeft As Double, dblEndTop As Double
Private dblIncrementLeft As Double, dblIncrementTop As Double
Private dblIncrementLeveler As Double
Private blnMoveLeft As Boolean, blnMoveTop As Boolean
Private Const dblDefaultLeveler As Double = 10
Private Const dblIncrementMinimum As Double = 1
Private Const dblIncrementLevelerSlowDownRate As Double = 1.15

Public Property Let CurrentLeft(ByVal curLeft As Double)
dblCurrentLeft = curLeft
End Property
Public Property Let CurrentTop(ByVal curTop As Double)
dblCurrentTop = curTop
End Property
Public Property Let EndLeft(ByVal eLeft As Double)
dblEndLeft = eLeft
End Property
Public Property Let EndTop(ByVal eTop As Double)
dblEndTop = eTop
End Property

Public Sub MoveShapeSmooth(ByRef ShapeRef As Excel.Shape)
Call setIncrements
Call setMovements

If (blnMoveLeft And blnMoveTop) Then
If (dblIncrementLeft < 0) Then
If (dblIncrementTop < 0) Then
Call MoveXnegativeYnegative(ShapeRef)
Else
Call MoveXnegativeYpositive(ShapeRef)
End If
Else
If (dblIncrementTop < 0) Then
Call MoveXpositiveYnegative(ShapeRef)
Else
Call MoveXpositiveYpositive(ShapeRef)
End If
End If
ElseIf (blnMoveLeft) Then
If (dblIncrementLeft < 0) Then
Call MoveXnegative(ShapeRef)
Else
Call MoveXpositive(ShapeRef)
End If
Else ' blnMoveTop
If (dblIncrementTop < 0) Then
Call MoveYnegative(ShapeRef)
Else
Call MoveYpositive(ShapeRef)
End If
End If
End Sub

Private Sub MoveXpositiveYpositive(ByRef ShapeRef As Excel.Shape)
Do Until ((ShapeRef.Left >= dblEndLeft) Or (ShapeRef.Top >= dblEndTop))
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop

' check if we're not done yet
If (ShapeRef.Left < dblEndLeft) Then
Do Until (ShapeRef.Left >= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
ElseIf (ShapeRef.Top < dblEndTop) Then
Do Until (ShapeRef.Top >= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End If
End Sub

Private Sub MoveXpositiveYnegative(ByRef ShapeRef As Excel.Shape)
Do Until ((ShapeRef.Left >= dblEndLeft) Or (ShapeRef.Top <= dblEndTop))
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop


' check if we're not done yet
If (ShapeRef.Left < dblEndLeft) Then
Do Until (ShapeRef.Left >= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
ElseIf (ShapeRef.Top > dblEndTop) Then
Do Until (ShapeRef.Top <= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End If
End Sub

Private Sub MoveXnegativeYpositive(ByRef ShapeRef As Excel.Shape)
Do Until ((ShapeRef.Left <= dblEndLeft) Or (ShapeRef.Top >= dblEndTop))
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop


' check if we're not done yet
If (ShapeRef.Left > dblEndLeft) Then
Do Until (ShapeRef.Left <= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
ElseIf (ShapeRef.Top < dblEndTop) Then
Do Until (ShapeRef.Top >= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End If
End Sub

Private Sub MoveXnegativeYnegative(ByRef ShapeRef As Excel.Shape)
Do Until ((ShapeRef.Left <= dblEndLeft) Or (ShapeRef.Top <= dblEndTop))
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop


' check if we're not done yet
If (ShapeRef.Left > dblEndLeft) Then
Do Until (ShapeRef.Left <= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
ElseIf (ShapeRef.Top > dblEndTop) Then
Do Until (ShapeRef.Top <= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End If
End Sub

Private Sub MoveXpositive(ByRef ShapeRef As Excel.Shape)
Do Until (ShapeRef.Left >= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End Sub

Private Sub MoveXnegative(ByRef ShapeRef As Excel.Shape)
Do Until (ShapeRef.Left <= dblEndLeft)
DoEvents
ShapeRef.Left = ShapeRef.Left + dblIncrementLeft
If (VBA.Abs(dblIncrementLeft / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementLeft = dblIncrementLeft / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End Sub

Private Sub MoveYpositive(ByRef ShapeRef As Excel.Shape)
Do Until (ShapeRef.Top >= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End Sub

Private Sub MoveYnegative(ByRef ShapeRef As Excel.Shape)
Do Until (ShapeRef.Top <= dblEndTop)
DoEvents
ShapeRef.Top = ShapeRef.Top + dblIncrementTop
If (VBA.Abs(dblIncrementTop / dblIncrementLeveler) > dblIncrementMinimum) Then
dblIncrementTop = dblIncrementTop / dblIncrementLeveler
End If

Call resetIncrementsToMinimum
Loop
End Sub

Private Sub resetIncrementsToMinimum()
If (VBA.Abs(dblIncrementLeft) < dblIncrementMinimum) Then
If (dblIncrementLeft < 0) Then
dblIncrementLeft = -1 * dblIncrementMinimum
Else
dblIncrementLeft = dblIncrementMinimum
End If
End If
If (VBA.Abs(dblIncrementTop) < dblIncrementMinimum) Then
If (dblIncrementTop < 0) Then
dblIncrementTop = -1 * dblIncrementMinimum
Else
dblIncrementTop = dblIncrementMinimum
End If
End If
End Sub

Private Sub setIncrements()
dblIncrementLeveler = dblDefaultLeveler

dblIncrementLeft = (dblEndLeft - dblCurrentLeft) / dblIncrementLeveler
dblIncrementTop = (dblEndTop - dblCurrentTop) / dblIncrementLeveler

dblIncrementLeveler = dblIncrementLevelerSlowDownRate
End Sub

Private Sub setMovements()
If (dblIncrementLeft <> 0) Then blnMoveLeft = True
If (dblIncrementTop <> 0) Then blnMoveTop = True
End Sub

Used like so:
Private ShapeMover As clsShapeMover

Public Sub StartTimer(o As Shape)
Set ShapeMover = New clsShapeMover
Set ShapeRef = o
Set PrevVisRng = ActiveWindow.VisibleRange
Call SetTimer(Application.hwnd, EventId, 10, AddressOf TimerTick)
End Sub

Private Sub MoveMyShape()
Static NewRotation As Single

With ShapeRef
NewRotation = NewRotation + 1
If NewRotation > 360 Then NewRotation = 0
.Rotation = NewRotation
End With

If Not (ActiveWindow.VisibleRange.Address = PrevVisRng.Address) Then
Call StopTimer

With ActiveWindow.VisibleRange
ShapeMover.CurrentLeft = ShapeRef.Left
ShapeMover.CurrentTop = ShapeRef.Top
ShapeMover.EndLeft = .Columns(.Columns.Count).Left - ShapeRef.Width
ShapeMover.EndTop = .Top + ShapeRef.Height

ShapeMover.MoveShapeSmooth ShapeRef

'ShapeRef.Left = .Columns(.Columns.Count).Left - ShapeRef.Width
'ShapeRef.Top = .Top + ShapeRef.Height
End With
Set PrevVisRng = ActiveWindow.VisibleRange

Call StartTimer(Sheet1.Shapes("Oval 1"))
End If

End Sub

[malik641]

On second thought, I should set a New instance of my class when the workbook opens...not when I call StartTimer (because I turn it off and back on while my code runs).

So here is the revised version, with less memory consumption.

[TomSchreiner]

I like... The "slide". :)

[malik641]

Thanks. I was trying to make it kind of "rush" to the position it needs to be in, and then slow down nice and easy to the spot...but that algorithm is kind of tricky...

[Oorang]

Wow, that turned out really nice. Props!

[mdmackillop]

Even more fun with a shadow added. Now if only I could find a use for it.:confused4

[malik641]

You could assign a macro to it and give it the text "Home" so when you click it your screen returns to cell A1.

There's 1 :)

We should think of more just to have reasons for something like that :)