BiocideJ
Well-known Member
- Joined
- Jan 23, 2012
- Messages
- 1,734
Thought I would bring this thread back with a new one I thought of this morning.
This code when run will start randomly moving the cells around (at least it will LOOK like it is).
It works by randomly choosing two cells in the activewindow creating a images of those cells and placing them over the cells and then swapping their locations.
Call GoCrazy to start the macro.
Press F12 to exit the loop.
If you use CTRL+BREAK to exit, you will need to manually run the CureCrazy Sub which removes all created shapes.
You can set the Worksheet_Activate event to call GoCrazy and then when a user goes to the specified sheet, the craziness will begin.
NOTE: This works BEST on a sheet with lots of data and variations to colors, etc. just because you can see everything moving around easily.
It is actually pretty disconcerting to watch even though I know there is a simple UNDO to Cure the Crazy.
This code when run will start randomly moving the cells around (at least it will LOOK like it is).
It works by randomly choosing two cells in the activewindow creating a images of those cells and placing them over the cells and then swapping their locations.
Call GoCrazy to start the macro.
Press F12 to exit the loop.
If you use CTRL+BREAK to exit, you will need to manually run the CureCrazy Sub which removes all created shapes.
You can set the Worksheet_Activate event to call GoCrazy and then when a user goes to the specified sheet, the craziness will begin.
NOTE: This works BEST on a sheet with lots of data and variations to colors, etc. just because you can see everything moving around easily.
It is actually pretty disconcerting to watch even though I know there is a simple UNDO to Cure the Crazy.
Code:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Const VK_F12 = &H7B
Private CRAZY As Boolean
Sub GoCrazy()
Dim Lo_C As Long, Hi_C As Long
Dim Lo_R As Long, Hi_R As Long
Dim c1 As Range, c2 As Range
Dim Shp1 As Shape, Shp2 As Shape
Dim tmpLeft As Long, tmpTop As Long, tmpWidth As Long, tmpHeight As Long
Dim shpCount As Long
CRAZY = True
Application.OnKey "{F12}", ""
Do While CRAZY
Lo_C = ActiveWindow.VisibleRange.Resize(1, 1).Column
Hi_C = ActiveWindow.VisibleRange.Columns.Count + Lo_C - 1
Lo_R = ActiveWindow.VisibleRange.Resize(1, 1).Row
Hi_R = ActiveWindow.VisibleRange.Rows.Count + Lo_R - 1
col1 = Int((Hi_C - Lo_C + 1) * Rnd + Lo_C)
col2 = Int((Hi_C - Lo_C + 1) * Rnd + Lo_C)
row1 = Int((Hi_R - Lo_R + 1) * Rnd + Lo_R)
row2 = Int((Hi_R - Lo_R + 1) * Rnd + Lo_R)
Set c1 = ActiveWindow.ActiveSheet.Cells(row1, col1)
Set c2 = ActiveWindow.ActiveSheet.Cells(row2, col2)
Set Shp1 = GetShape(c1)
Set Shp2 = GetShape(c2)
If Shp1 Is Nothing Then
Set Shp1 = CreateCrazy(c1, shpCount)
shpCount = shpCount + 1
End If
If Shp2 Is Nothing Then
Set Shp2 = CreateCrazy(c2, shpCount)
shpCount = shpCount + 1
End If
tmpLeft = Shp1.Left
tmpTop = Shp1.Top
tmpWidth = Shp1.Width
tmpHeight = Shp1.Height
Shp1.Left = Shp2.Left
Shp1.Top = Shp2.Top
Shp1.Width = Shp2.Width
Shp1.Height = Shp2.Height
Shp2.Left = tmpLeft
Shp2.Top = tmpTop
Shp2.Width = tmpWidth
Shp2.Height = tmpHeight
DoEvents
If GetAsyncKeyState(VK_F12) Then StopCrazy
DoEvents
Loop
Application.OnKey "{F12}"
End Sub
Sub StopCrazy()
CRAZY = False
CureCrazy
End Sub
Function CreateCrazy(Cll As Range, num As Long) As Shape
Dim newShape As Shape
Set currSelect = Selection
Application.ScreenUpdating = False
Cll.CopyPicture
ActiveWindow.ActiveSheet.Paste Cll
Set newShape = GetShape(Cll)
newShape.Name = "CrazyShp" & num
newShape.Fill.Visible = msoTrue
newShape.Line.Visible = msoFalse
DoEvents
currSelect.Select
Application.ScreenUpdating = True
Set CreateCrazy = newShape
End Function
Private Function GetShape(rngSelect As Range) As Shape
Dim Shp As Shape
For Each Shp In rngSelect.Worksheet.Shapes
If Not Intersect(Range(Shp.TopLeftCell, Shp.BottomRightCell), rngSelect) Is Nothing Then
GoTo shapeFound
End If
Next
Set GetShape = Nothing
Exit Function
shapeFound:
Set GetShape = Shp
End Function
Sub CureCrazy()
Dim Shp As Shape
For Each Shp In ActiveWindow.ActiveSheet.Shapes
If Shp.Name Like "CrazyShp*" Then Shp.Delete
Next Shp
End Sub
