Evil but Fun

[bpgolferguy]

Hi! Ok, I have some button happy people that like to push buttons they shouldn't in Excel, and so I want to teach them a lesson. Does anyone have any ideas of something I could have happen to their computer when they push this button? Like maybe a bunch of message boxes start popping? Or something like that? Just basically as a prank. Thanks!

 

[Smitty]

You haven't said when it's OK to press buttons or not, so how do you differentiate?

Why not just disable them until certain criteria (like the ones where they're allowed to use the buttons) are met?

Or set the presence/visibility of a button(s) based on a username?

For ideas on pranks take a look in the Lounge. There's a long running thread. Just note in a work environment you should plan carefully, because a prank on a group of people is likely to **** off as many, if not more users than it amuses.

HTH,

 

[Random Wok]

Link it to a macro that opens a new workbook, the equivalent of CTRL + N. Hitting that shortcut always strikes a nerve with the user, until they realize their data wasn't just completely erased. A funny, yet fairly safe booby trap.

 

[Akashwani]

Hi,

Take a look here, but don't tell anyone

http://www.mrexcel.com/forum/showthread.php?t=27058&highlight=pranks

Ak

 

[Norie]

Why have these buttons in the first place?

PS You might want to take a look at the jobs section in the newspaper - I think this sort of thing might be frowned a little.

 

[crimson_b1ade]

...what jobs?

Why have these buttons in the first place?

PS You might want to take a look at the jobs section in the newspaper - I think this sort of thing might be frowned a little.

 

[Akashwani]

Hi,

This is my favourite...

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub bleeding_nose()
Dim AWVRH As Integer
Dim AWVRW As Integer
Dim Sh As Shape
Dim TP As Double
Dim LP As Double
Dim ShH As Integer
Dim ShW As Integer
Dim ShClear As Shape
Dim WB As Workbook
Dim NoHarm As Boolean
Dim i As Integer
'if NoHarm is True then pressing escape will "undo" the macro
'if NoHarm is False you should stay in the neighbourhood ! :-)
NoHarm = True
    If NoHarm Then
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    Set WB = ActiveWorkbook
    Application.ScreenUpdating = True
    Else
    'if any problems, you can find this file in same directory
    Set WB = ActiveWorkbook
    WB.SaveCopyAs Left(WB.FullName, Len(WB.FullName) - 4) & " no bled.xls"
    End If
Application.EnableCancelKey = xlErrorHandler
On Error GoTo StopBleeding
AWVRH = ActiveWindow.VisibleRange.Height * 0.95
AWVRW = ActiveWindow.VisibleRange.Width * 0.95
    Do
    Randomize Timer
    LP = Rnd * AWVRW + AWVRW * 0.025
    TP = Rnd * AWVRH + AWVRH * 0.025
    ShH = 4 * Rnd + 5
    ShW = 4 * Rnd + 5
    
        With WB.ActiveSheet.Shapes
            Select Case Rnd
            Case 0 To 0.6
            Set Sh = .AddShape(msoShapeExplosion1, LP, TP, ShW, ShH)
            Case 0.6 To 0.8
            Set Sh = .AddShape(msoShapeExplosion2, LP, TP, ShW, ShH)
            Case Else
            Set Sh = .AddShape(msoShapeSun, LP, TP, ShW, ShH)
            End Select
        End With
        
        With Sh
        .FILL.ForeColor.SchemeColor = 10
        .FILL.Transparency = Rnd * 0.8
        .Line.Visible = msoFalse
        If NoHarm = False Then .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        End With
    
        For i = 1 To Int(Rnd * 10)
        Sleep CLng(Rnd * 99)
        DoEvents
        Next i
        For Each ShClear In ActiveSheet.Shapes
        If Not Intersect(Selection, ShClear.TopLeftCell) Is Nothing Then ShClear.Delete
        Next ShClear
    Loop
StopBleeding:
Err.Clear
Application.EnableCancelKey = xlDisabled
    If NoHarm Then
    WB.Close False
    Else
    'automatisation error if user closed WB "while bleeding"
    'same error checking if WB is still open
    'On Error Resume Next didn't work
    'not a big issue anyway :-)
        With WB.ActiveSheet.Buttons.Add(25, 25, 200, 80)
        .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        .Characters.Text = "A fatal problem occured: " & vbLf & "Your system has solved this only partially. Please click the shapes and this button to remove them."
        End With
    End If
End Sub
Sub oh()
ActiveSheet.Shapes(Application.Caller).Delete
End Sub

I only prank IT, they seem to have the sense of humour, they don't panic and they are less likely to report you.

Ak

 

[Norie]

Crimson Blade

The jobs created when people get fired for trying this sort of 'hilarious' prank.

 

[Akashwani]

Wow, what a response.

Ak

 

[OfficeUser]

Hi,

This is my favourite...

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub bleeding_nose()
Dim AWVRH As Integer
Dim AWVRW As Integer
Dim Sh As Shape
Dim TP As Double
Dim LP As Double
Dim ShH As Integer
Dim ShW As Integer
Dim ShClear As Shape
Dim WB As Workbook
Dim NoHarm As Boolean
Dim i As Integer
'if NoHarm is True then pressing escape will "undo" the macro
'if NoHarm is False you should stay in the neighbourhood ! :-)
NoHarm = True
    If NoHarm Then
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    Set WB = ActiveWorkbook
    Application.ScreenUpdating = True
    Else
    'if any problems, you can find this file in same directory
    Set WB = ActiveWorkbook
    WB.SaveCopyAs Left(WB.FullName, Len(WB.FullName) - 4) & " no bled.xls"
    End If
Application.EnableCancelKey = xlErrorHandler
On Error GoTo StopBleeding
AWVRH = ActiveWindow.VisibleRange.Height * 0.95
AWVRW = ActiveWindow.VisibleRange.Width * 0.95
    Do
    Randomize Timer
    LP = Rnd * AWVRW + AWVRW * 0.025
    TP = Rnd * AWVRH + AWVRH * 0.025
    ShH = 4 * Rnd + 5
    ShW = 4 * Rnd + 5
    
        With WB.ActiveSheet.Shapes
            Select Case Rnd
            Case 0 To 0.6
            Set Sh = .AddShape(msoShapeExplosion1, LP, TP, ShW, ShH)
            Case 0.6 To 0.8
            Set Sh = .AddShape(msoShapeExplosion2, LP, TP, ShW, ShH)
            Case Else
            Set Sh = .AddShape(msoShapeSun, LP, TP, ShW, ShH)
            End Select
        End With
        
        With Sh
        .FILL.ForeColor.SchemeColor = 10
        .FILL.Transparency = Rnd * 0.8
        .Line.Visible = msoFalse
        If NoHarm = False Then .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        End With
    
        For i = 1 To Int(Rnd * 10)
        Sleep CLng(Rnd * 99)
        DoEvents
        Next i
        For Each ShClear In ActiveSheet.Shapes
        If Not Intersect(Selection, ShClear.TopLeftCell) Is Nothing Then ShClear.Delete
        Next ShClear
    Loop
StopBleeding:
Err.Clear
Application.EnableCancelKey = xlDisabled
    If NoHarm Then
    WB.Close False
    Else
    'automatisation error if user closed WB "while bleeding"
    'same error checking if WB is still open
    'On Error Resume Next didn't work
    'not a big issue anyway :-)
        With WB.ActiveSheet.Buttons.Add(25, 25, 200, 80)
        .OnAction = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".xls!oh"
        .Characters.Text = "A fatal problem occured: " & vbLf & "Your system has solved this only partially. Please click the shapes and this button to remove them."
        End With
    End If
End Sub
Sub oh()
ActiveSheet.Shapes(Application.Caller).Delete
End Sub

I only prank IT, they seem to have the sense of humour, they don't panic and they are less likely to report you.

Ak

I had to try this myself. This is great.