Need "fat macro" that wants to join the circus...

[westjelly]

This is a bit of a novelty, but something I brainstorm a bit when I'm not working on the "uber project" (the 400 spreadsheet thing). It's a bit of an escape, and gets me out-of-the-box a bit.

Supervisor joked that I had all these macros and was jealous she doesn't have any. She pontificated that if she had a macro, it would be a "fat macro, possibly a freak, and it would probably join a circus."

Any brainstorms on what such a macro might do?

*Note: As I said up top, this is novelty. It need not do anything incredibly valuable or useful.

 

[PaddyD]

"fat macro, possibly a freak, and it would probably join a circus"

...would take any text in the selected area, bloat it up with a silly font, make it jump through a hoop then put it back.

 

[westjelly]

HA! I like the way you think. Will give that a shot. Any others?

 

[erik.van.geit]

Hi,

run the demo
experiment a bit with the values

Option Explicit

Dim sh1 As Shape
Dim sh2 As Shape
Const nm1 As String = "ShYel"
Const nm2 As String = "ShRed"
Const WsName As String = "sheet1"

Sub demo()
'Erik Van Geit
'060715
Dim i As Integer
create_shapes
    For i = 1 To 36
    circus
    Next i
remove_shapes
End Sub

Sub create_shapes()
Dim tryout1 As Shape
Dim tryout2 As Shape

Const L As Integer = 60
Const T As Integer = 150
Const W As Integer = 95
Const H As Integer = 95

With Sheets(WsName)
    On Error Resume Next
    Set tryout1 = .Shapes(nm1)
    Set tryout2 = .Shapes(nm2)
    On Error GoTo 0
    With .Shapes
    If tryout1 Is Nothing Then .AddShape(msoShapeSmileyFace, L, T, W, H).Name = nm1
    If tryout2 Is Nothing Then .AddShape(msoShapeSmileyFace, L, T, W, H).Name = nm2
    End With
    On Error GoTo 0
Set sh1 = .Shapes(nm1)
Set sh2 = .Shapes(nm2)
End With

With sh1.Fill
.ForeColor.SchemeColor = 10
.Transparency = 1
End With
sh2.Fill.ForeColor.SchemeColor = 13

End Sub


Sub circus()
Const r = 60    'circle diameter
Const mx = 200   'center x coordinate
Const my = 180   'center y coordinate
Const rad = 31.415926 / 180

Dim i As Integer
Dim Obj1 As Shape
Dim Obj2 As Shape

Set Obj1 = IIf(sh1.Fill.Transparency = 1, sh1, sh2)
Set Obj2 = IIf(sh2.Fill.Transparency = 1, sh1, sh2)

Dim y As Integer

Set Obj1 = IIf(sh1.Fill.Transparency = 1, sh1, sh2)
Set Obj2 = IIf(sh2.Fill.Transparency = 1, sh1, sh2)

    For i = 1 To 36
    Obj1.Fill.Transparency = 1 - i / 36
    Obj2.Fill.Transparency = i / 36
    y = i

      Obj1.Left = Sin(y * rad) * r + mx
      Obj2.Left = Obj1.Left
      Obj1.Top = Cos(y * rad) * r + my
      Obj2.Top = Obj1.Top
      Obj1.Rotation = i * 10
      Obj2.Rotation = Obj1.Rotation
      DoEvents

    Next i

End Sub

Sub remove_shapes()
sh1.Delete
sh2.Delete
End Sub

kind regards,
Erik

 

[erik.van.geit]

smiley "stepping" at side of your window
not really finished, but to get the idea

Option Explicit

Dim shShape As Shape
Const shName As String = "ShYel"

Sub circus()
'Erik Van Geit
'060715
Dim R      As Single    'Rotation
Dim i      As Single
Dim loops  As Single
Dim speed  As Single
Dim Rspeed As Single
Dim rng As Range

create_shapes

speed = 1
'rotation speed depends on height of circle but also on zoomfactor ...
Rspeed = speed * 3

    On Error GoTo ErrHandler
    Application.EnableCancelKey = xlErrorHandler

    
    With ActiveWindow.VisibleRange
    Set rng = .Resize(.Rows.Count - 2, .Columns.Count - 2).Offset(1, 1)
    End With
    
    With rng
    shShape.Top = .Top
        Do
        'shShape.Height = shShape.Height + 1
        'shShape.Width = shShape.Width + 1
        
        shShape.Left = .Left
        loops = .Height - shShape.Height
            For i = shShape.Top To loops Step speed
            shShape.Top = i
            R = R + Rspeed
            shShape.Rotation = R
            DoEvents
            Next i
    
        shShape.Top = loops
        loops = .Width - shShape.Width
            For i = shShape.Left To loops Step speed
            shShape.Left = i
            R = R + Rspeed
            shShape.Rotation = R
            DoEvents
            Next i
            
        'shShape.Left = loops
        loops = .Height - shShape.Height
            For i = loops To .Top Step -speed
            shShape.Top = i
            R = R + Rspeed
            shShape.Rotation = R
            DoEvents
            Next i
    
        'shShape.Top = .Height
        loops = .Width - shShape.Width
            For i = loops To .Left Step -speed
            shShape.Left = i
            R = R + Rspeed
            shShape.Rotation = R
            DoEvents
            Next i

        Loop
    End With

ErrHandler:
remove_shapes
End Sub

Sub create_shapes()
Dim tryout As Shape

Const L As Integer = 9999
Const T As Integer = 0
Const W As Integer = 45
Const H As Integer = 45

    With ActiveSheet
        On Error Resume Next
        Set tryout = .Shapes(shName)
        
        On Error GoTo 0
            If tryout Is Nothing Then .Shapes.AddShape(msoShapeSmileyFace, L, T, W, H).Name = shName
        On Error GoTo 0
        
    Set shShape = .Shapes(shName)
    End With

    With shShape.Fill
    .ForeColor.SchemeColor = 13
    End With


End Sub

Sub remove_shapes()
shShape.Delete
End Sub

 

[westjelly]

HA. I'll have to play around with those. Might have to spend an inordinate amount of hours making the face roll around, stop, speak (or thought bubble), fight... all sorts.

Thanks for the energy. This is gonna crack some folks up!


edit: Hrm... maybe I'll try to have him just roll on to the screen, stop, have a thought about "Woah, I shouldn't have eaten that last piece of cake. I better go join the circus" and then roll off

 

[erik.van.geit]

"Woah, I shouldn't have eaten that last piece of cake.

unquote these lines

        'shShape.Height = shShape.Height + 1 
        'shShape.Width = shShape.Width + 1

he will get fat
if your code ends unexpectedly quote the "On Error Resume Next" to see where it happens