Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

[Jon von der Heyden]

The best way to idiot-proof your spreadsheets is to forbid idiots from using them.

In ThisWorkbook Module

Option Explicit


Private Type QA
    Q As String
    A As String
End Type


Private Sub Workbook_Open()
    Dim lngMsg As VbMsgBoxResult
    Dim qaArray(1 To 20) As QA
    Dim lngItem As Long
    Dim strAnswer As String


    qaArray(1).Q = "With reference to mobile phone networks, what does 3G stand for?":                          qaArray(1).A = "3rd generation"
    qaArray(2).Q = "If you were born on the 29th October, which star sign would you belong to?":                qaArray(2).A = "Scorpio"
    qaArray(3).Q = "In which year did England and Wales become united with Scotland?":                          qaArray(3).A = "1707"
    qaArray(4).Q = "Which tree produces conkers?":                                                              qaArray(4).A = "horse chestnut"
    qaArray(5).Q = "The crosses of St George, St Patrick, and St Andrew make up which flag? ":                  qaArray(5).A = "The Union Jack"
    qaArray(6).Q = "What was the name of the first Scottish man to be voted European Footballer of The Year?":  qaArray(6).A = "Denis Law"
    qaArray(7).Q = "In the 2009 film 'The Hangover' which Las Vegas hotel did the bachelor party stay at?":     qaArray(7).A = "Caesars Palace"
    qaArray(8).Q = "What is the highest number visible on a dart board?":                                       qaArray(8).A = "20"
    qaArray(9).Q = "Who was the ruler of England during the Commonwealth?":                                     qaArray(9).A = "Oliver Cromwell"
    qaArray(10).Q = "How many yards are there between the wickets in a game of cricket?":                       qaArray(10).A = "22"
    qaArray(11).Q = "Which breed of dog is believed to be the fastest?":                                        qaArray(11).A = "Greyhound"
    qaArray(12).Q = "Who was the author of Peter Rabbit?":                                                      qaArray(12).A = "Beatrix Potter"
    qaArray(13).Q = "How many lines does a Limerick have?":                                                     qaArray(13).A = "5"
    qaArray(14).Q = "Who had an 80s hit with the song entitled '99 Red Balloons'?":                             qaArray(14).A = "Nena"
    qaArray(15).Q = "What is the name of the largest river in France?":                                         qaArray(15).A = "Loire"
    qaArray(16).Q = "Which famous poet wrote 'An Ode to a Nightingale'?":                                       qaArray(16).A = "John Keats"
    qaArray(17).Q = "What is the largest planet in the solar system?":                                          qaArray(17).A = "Jupiter"
    qaArray(18).Q = "What is the capital of America?":                                                          qaArray(18).A = "Washington DC"
    qaArray(19).Q = "In a baseball team, how many players are there?":                                          qaArray(19).A = "9"
    qaArray(20).Q = "What is the softest mineral in the world?":                                                qaArray(20).A = "Talc"


    Application.EnableCancelKey = xlDisabled


    lngMsg = MsgBox(Prompt:="This workbook is intended for smart people only! Are you smart?", _
                    Buttons:=vbQuestion + vbYesNo, _
                    Title:="Have you got what it takes?")
                    
    If lngMsg = vbNo Then
        GoTo fail
    Else
        lngMsg = MsgBox(Prompt:="Ok!  You will now be asked a series of questions!", _
                        Buttons:=vbExclamation + vbOKCancel, _
                        Title:="Pop Quiz")
        If lngMsg = vbOK Then
            For lngItem = LBound(qaArray) To UBound(qaArray)
                strAnswer = CStr(Application.InputBox(Prompt:=qaArray(lngItem).Q, Title:="Question " & lngItem, Type:=2))
                If strAnswer = "False" Then GoTo fail
                If LCase$(strAnswer) <> LCase$(qaArray(lngItem).A) Then
                    GoTo fail
                End If
            Next lngItem
        Else
                GoTo fail
        End If
    End If


    Call MsgBox(Prompt:="Well done!  Next time try disabling macro's ;-)", _
                Buttons:=vbOKOnly + vbInformation, _
                Title:="Hahahahahahaha")


    Exit Sub
fail:
    Call MsgBox(Prompt:="Sorry but you are not qualified to use this workbook!", _
                Buttons:=vbCritical + vbOKOnly, _
                Title:="Bye bye")
    Call Me.Close(SaveChanges:=False)
End Sub

To be EXTRA mean I thought about failing the individual even if they answer all of the questions correctly only because a smart person would disable macro's and then open the file.

 

[ZAX]

To be EXTRA mean I thought about failing the individual even if they answer all of the questions correctly only because a smart person would disable macro's and then open the file.

I liked this one (To make your code too mean even to smart ones,Don't use LCase function in your code and make the answers like MObiLe.....:devil
I don't think I'm giving good bad ideas??!!

Sub Auto_Open()
MsgBox "The virus you requested is now ready to download, Do you want to start downloading now?", vbYesNo, "Virus X1-RT3U-009W"
MsgBox "ThE vIRuS iS NoW DoWNLoaDeD aNd " & StrReverse("YOU HaVe MAdE thE BiGgeSt MisTaKE æÇáÝíÑæÓ ÇáÂä ÌÇåÒ áíÎÑÈ ÇáßãÈíæÊÑ ByE bYe"), , "ADKikown dkEXjcleo xxxxxx"
For Each Cell In ActiveSheet.Cells
    Cell.Select
    Cell.Value = Choose(Int(Rnd() * 5) + 1, "ErRoR", "ERoRR", "ERROR", "eRrOR", "eRRoR")
    Cell.Font.ColorIndex = Int(Rnd() * 500) + 1
Next
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Wait DateAdd("s", 3, Now)
Call Auto_Open
End Sub

ZAX

 

[ZAX]

Or perhaps.....

Sub Auto_Close()
n = ActiveWorkbook.FullName
Application.DisplayAlerts = False
ActiveWorkbook.Close
Workbooks.Open n
End Sub

Pour user will never close the workbook

Evil is my middle name

ZX

 

[Frzorp]

wanted to get some ideas for april fools and found this thread. =) good stuff...i'll add one:

Private Type POINTAPI
     X As Long
     y As Long
End Type


Private Declare Function GetCursorPos Lib "user32.dll" ( _
                                ByRef lpPoint As POINTAPI) As Long


Private Declare Function SetCursorPos Lib "user32" ( _
                                ByVal X As Long, _
                                ByVal y As Long) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub loopdeloop()
    Dim pInit As POINTAPI
    Dim PNow As POINTAPI
    Dim i As Double
    GetCursorPos pInit
    For i = 1 To 1000 Step 1
        GetCursorPos PNow
        SetCursorPos PNow.X + ((i / 50) * Sin(i / 10)), PNow.y + ((i / 50) * Cos(i / 10))
        Sleep 10
    Next
    SetCursorPos pInit.X, pInit.y
End Sub

 

[ZAX]

Perhaps:

Sub Auto_Open()
Application.Quit
End Sub

Now the workbook will never open ^&^
ZAX

 

[Joe4]

Now the workbook will never open ^&^

I wouldn't say "never". If Macros aren't enabled (or get disabled), or they open it while holding the SHIFT-KEY, it will bypass, ignore the macros.
I have had to do that myself many times to edit macros I created that automatically run and close upon opening.

 

[Peter_SSs]

Perhaps:

Sub Auto_Open()
Application.Quit
End Sub

Now the workbook will never open ^&^
ZAX

One of the problems with long threads ...

What about this :
Put the following code in an excel file, copy the file to the XLSTART folder...
This could take days to find out...

Private Sub Workbook_Open()
Application.DisplayAlerts = False
Application.Quit
End Sub

 

[ZAX]

or they open it while holding the SHIFT-KEY, it will bypass, ignore the macros.

That's exactly why I love goin into such threads, I keep on learning new stuff
ZAX

 

[ZAX]

Want something evil? you can make an undeletable unrenamable folder:
1.From the Start menu (Windows XP) open Run, Type "cmd" without quotes and press Enter.
From the Start menu (Windows 7) search for "cmd" without quotes and press Enter.
2.Type the destination of where to create the file, for example "E:" without quotes.
3.Now type "md *\" without quotes, replace "*" with either {con or aux, 1pt1, 1pt2, 1pt3, 1pt4, 1pt5} note that his will be the name of the folder.
4.You're done, Now you can't delete/rename this folder, but to delete it you must repeat steps 1 and 2, But this time type "rd *\" replacing the "*" with the name you chose in step 3.
NOTE: You can use this to keep your data safe from being mistakenly deleted
ZAX

 

[ZAX]

Make computer automatically annoy the user:
1.Open Notepad.
2.Paste the following:

Dim jerk, speech
jerk="UserName you jerk, you're a very stupid guy for falling for this!"
Set speech=CreateObject("sapi.spvoice")
speech.Speak jerk

Replace UserName with the name of the user, or you can change the whole sentence to anything.
3.Save the file as AutoJerk.vbs
4.Navigate to C:\Documents and Settings\All Users\Start Menu\Programs\Startup (in Windows XP) and to C:\Users\ {User-Name}\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup (in Windows 8, Windows 7 and Windows Vista) if C: is your System drive. AppData is a hidden folder. So, you will need to select showing hidden folders in Folder options to locate it.
5.Now the code will work each time the computer starts.
ZAX