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

[RobMatthews]

I had a minor complaint/Comparison with another dude that my sheets weren't very colourful, and his were. So I wrote this:

My boss finally fell victim to this, this morning. Much laughter was heard. Very worth it, especially in conjunction with the

MsgBox "Is that colourful enough, boss?"

 

[wellsr]

I'm new here but I'm loving this thread. These pranks are great! One of my favorite VBA pranks is to change my coworker's mouse cursor to a dancing banana (from the Peanut Butter Jelly Time video here: https://www.youtube.com/watch?v=s8MDNFaGfT4).

I had a colleague do this to me once and I thought it was brilliant. It actually saves the cursor byte string to your custom document properties so they don't have to download anything. The byte string is "rebuilt" and activated each time the document is opened. Clever! You can read about it here if you want:VBA Office Prank Dancing Banana Cursor - Ryan Wells

 

[jlieu]

I've been throwing in links to images and just playing the waiting game when the if condition is correct. Sometimes I'll use mr hanky(example code given), others i'll look for the scariest picture I can think of and have it activate if someone is using the workbook at 3am-430am. was looking into a way of making it also play a sound through excel and not an external program

ActiveWorkbook.FollowHyperlink "http://i.imgur.com/D6miL7q.gif"

 

[Ady.]

Outstanding lol!!!

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.

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

 

[wellsr]

I've got a new prank for you!

Many people don't know this, but you can actually change content of other cells using a VBA user-defined function. Today, I created a function that I can hide way over on the right side of an Excel sheet. Anytime someone tries typing into a cell in Excel, a different funny message will fill the cell where they just tried typing. Being able to run this prank from a UDF instead of a worksheet change event (the typical way to run similar pranks) is awesome! The 4th example here shows the custom function:

How to Change Another Cell with a VBA Function (Scroll down to the last example to see the prank in action)

Once you copy and paste the macro, just enter =MeanFunction() into any cell in Excel. The user is trapped until he finds out which cell it was typed in. The function returns an empty string in its own cell, so it's even harder to find.

This might be even better than the ole VBA prank to change your cursor to a dancing banana!

 

[BiocideJ]

OK, since this thread has had a surge of life lately, I just recently worked up this fun one for a co-worker who is always leaving his terminal unlocked....(to go catch Pokemon apparently)

Just create a workbook with the following code (and userform) in the modules specified and viola, an infinite loop of annoying (but fun) reminder messages to lock your computer.

in the ThisWorkbook module:

Private Declare Function LockWorkStation Lib "user32.dll" () As Long
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    LockWorkStation
End Sub
Private Sub Workbook_Open()
    MSGBOX_LOOP
End Sub

In a standard module:

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal index As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Const VK_F12 = &H7B
Public RUN_TIMER As Double
Public oldT As Double
Public oldH As Double
Public oldW As Double
 
Sub MSGBOX_LOOP()
    
    Application.WindowState = xlNormal
    oldW = Application.Width
    oldH = Application.Height
    oldT = Application.Top
    Application.Width = 10
    Application.Height = 10
    Application.Top = -100
    Application.OnKey "{F12}", ""
    
    Do
        Application.WindowState = xlNormal
    
        RUN_TIMER = Now + TimeValue("00:00:10")
        frmMsgBox.Show
        MINIMIZE_ALL_ELSE
        
        DoEvents
        If GetAsyncKeyState(VK_F12) Then GoTo LOOPBREAK
        DoEvents
    
    Loop
LOOPBREAK:
    Application.OnKey "{F12}"
    RELEASE_LOOP
    
End Sub
Sub MINIMIZE_ALL_ELSE()
If RUN_TIMER = 0 Then End
On Error Resume Next
    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , False
    CreateObject("Shell.Application").MinimizeAll
    Application.WindowState = xlNormal
    RUN_TIMER = Now + TimeValue("00:00:10")
    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , True
    
End Sub

Sub RELEASE_LOOP()
    
    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , False
    RUN_TIMER = 0
    Application.Visible = True
    Application.WindowState = xlNormal
    
    MsgBox "Hopefully you have learned your lesson." & vbCrLf & _
        "LOCK TERMINAL?", vbCritical, "Locking terminal"
    Application.Width = oldW
    Application.Height = oldH
    Application.Top = oldT
    
    ThisWorkbook.Close False
    
End Sub

Create a UserForm (to look like a MsgBox) with a caption field named 'lblText' and an OK button called 'btnOK'
In the code section of that UserForm:

Private Sub btnOK_Click()
    Unload Me
End Sub
Private Sub UserForm_Activate()
msgstr = Array( _
    "Next time I will lock my terminal.", _
    "Terminal Unlock Status: VERIFIED" & vbCrLf & "Status: VULNERABLE" & vbCrLf & "Condition:  :(", _
    "I have been left unlocked.  Now I am FREEeee!", _
    "Is your computer running?                                               " & vbCrLf & "Well you better go and catch it." & vbCrLf & "LOLOLOL", _
    "Which way did the programmer go?                                        " & vbCrLf & "He went DATA way.", _
    "Do computers dream in binary?", _
    "10001001011010011010010011101110111010001000001 0101010 101010101001111011011" & vbCrLf & vbCrLf & "If you were a computer you'd understand.", _
    "Let's play a game.  Try to guess where will I pop up next.", _
    "Calculating the square root of infinity", _
    "There IS a way to make this stop.                                       " & vbCrLf & "Just kidding.  This will go on forever now.", _
    "Why, oh why, didn't you lock me.", _
    "Wake up Neo.                                                            " & vbCrLf & "The MATRIX has you.", _
    "I am a jelly doughnut.")
    
    
    With Me
        .StartUpPosition = 0
        .Left = .Width + Rnd() * (GetSystemMetrics(SM_CXSCREEN) - .Width)
        .Top = .Height + Rnd() * (GetSystemMetrics(SM_CYSCREEN) / 2 - .Height)
    End With
    
    Randomize Now()
    R = Int(Rnd() * (UBound(msgstr) + 1)) + LBound(msgstr)
    For i = 1 To Len(msgstr(R))
    
        Me.lblText.Caption = Left(msgstr(R), i)
        Me.Repaint
        Sleep 20
    
    Next i
    
End Sub

Private Sub UserForm_Deactivate()
    MINIMIZE_ALL_ELSE
    Me.Show
End Sub

You can hold down F12 when pressing the OK button to exit the loop at any time.
Added bonus:
-Every 10 seconds, all other windows but the UserForm are minimized so they can't just ignore the message

 

[redbull1]

I created an account to leave this here...

To enable it, goto tools ~> References and select "Microsoft Internet Controls"

Private Sub Workbook_Open()
Dim ie As InternetExplorer
Set ie = New InternetExplorer
ie.Navigate ("https://www.youtube.com/watch?v=dQw4w9WgXcQ") 'Put whatever youtube stuff you want here.
End Sub

opens an invisible IE window to play a video. If the users PC is not muted... Oh joy. I know theres code out there to unmute and turn up a pc, but I didn't want to be too mean.

 

[CalcSux78]

In honor of yesterday being "Talk like a pirate day".... you could combine the speak function to make the workbook literally talk like a pirate. The following will store the text of the active cell and when the selection is changed, audibly speak the string in pirate jargon.

Note: more fun if this is applied to a workbook where text is entered frequently.

Standard Module:

Public str As String


Function PirateSpeak(normalText As String) As String


    Const BASE_URL As String = "http://isithackday.com/arrpi.php?text="
    
    Dim msxml As clsMSXML
    Dim xml As Object   ' MSXML2.XMLHTTP60
    Dim result As String
    
    Set msxml = New clsMSXML
    Set xml = msxml.GetMSXML
    
    result = msxml.GetResponse(xml, HTTP_GET, _
        BASE_URL & normalText, False)
        
    PirateSpeak = result
End Function

ThisWorkbook code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
str = Target.value
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Not str = "" Then
    Application.Speech.Speak PirateSpeak(str)
    str = ""
End If
End Sub

Class Module: Rename to clsMSXML

Option Explicit
' ***********************************************************************
' private vars
' ***********************************************************************
' change this to "" if you want version 2
Private Const VERSION As String = "6.0"
' ***********************************************************************
' enums
' ***********************************************************************
Public Enum HTTPRequestType
  HTTP_GET
  HTTP_POST
  HTTP_HEAD
End Enum
' ***********************************************************************
' internal class functions
' ***********************************************************************
Private Function GetRequestType(reqType As HTTPRequestType) As String
' translate enum into string
  Select Case reqType
  Case 1
    GetRequestType = "POST"
  Case 2
    GetRequestType = "HEAD"
  Case Else  ' GET is default
    GetRequestType = "GET"
  End Select
End Function
' ***********************************************************************
' major objects
' ***********************************************************************
Public Function GetMSXML() As Object  ' MSXML2.XMLHTTP60
  On Error Resume Next
  Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function GetDomDoc() As Object  ' MSXML2.DOMDocument
  On Error Resume Next
  Set GetDomDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function GetMXXMLWriter() As Object
  On Error Resume Next
  Set GetMXXMLWriter = CreateObject("MSXML2.MXXMLWriter" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function CreateHTMLDoc() As Object  ' MSHTML.HTMLDocument
  On Error Resume Next
  Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
' ***********************************************************************
' nodes
' ***********************************************************************
Function GetNode(parentNode As Object, nodeNumber As Long) As Object
  On Error Resume Next
  ' if parentNode is a MSXML2.IXMLDOMNodeList
  Set GetNode = parentNode.item(nodeNumber - 1)
  ' if parentNode is a MSXML2.IXMLDOMNode
  If GetNode Is Nothing Then
    Set GetNode = parentNode.childNodes(nodeNumber - 1)
  End If
End Function
Public Function GetChildNodes(node As Object) As Object
' returns child nodes for a given MSXML2.IXMLDOMNode
  Set GetChildNodes = node.childNodes
End Function
Function GetRootNode(xmlDoc As Object) As Object
' returns root node
  Set GetRootNode = xmlDoc.documentElement
End Function
' ***********************************************************************
' error checking
' ***********************************************************************
Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
  LoadError = (xmlDoc.parseError.errorCode <> 0)
End Function
' ***********************************************************************
' maintenance
' ***********************************************************************
Function ClearCache(Optional fileExtension As String = "xml")
' deletes stored xml files from temp folder
  Dim filesToDelete As String
  filesToDelete = Environ("temp") & "\*." & fileExtension
  Kill filesToDelete
End Function
Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
  Dim tempFile As String
  Dim nextFileNum As Long
  nextFileNum = FreeFile
  tempFile = fileName
  Open tempFile For Output As #nextFileNum
  Print #nextFileNum, contents
  Close #nextFileNum
  CreateFile = tempFile
End Function
' ***********************************************************************
' string operations
' ***********************************************************************
Function ConvertAccent(ByVal inputString As String) As String
' http://www.vbforums.com/archive/index.php/t-483965.html
  Const AccChars As String = _
        "²—*–ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ’"
  Const RegChars As String = _
        "2---SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy'"
  Dim i As Long, j As Long
  Dim tempString As String
  Dim currentCharacter As String
  Dim found As Boolean
  Dim foundPosition As Long
  tempString = inputString
  ' loop through the shorter string
  Select Case True
  Case Len(AccChars) <= Len(inputString)
    ' accent character list is shorter (or same)
    ' loop through accent character string
    For i = 1 To Len(AccChars)
      ' get next accent character
      currentCharacter = Mid$(AccChars, i, 1)
      ' replace with corresponding character in "regular" array
      If InStr(tempString, currentCharacter) > 0 Then
        tempString = Replace(tempString, currentCharacter, _
                             Mid$(RegChars, i, 1))
      End If
    Next i
  Case Len(AccChars) > Len(inputString)
    ' input string is shorter
    ' loop through input string
    For i = 1 To Len(inputString)
      ' grab current character from input string and
      ' determine if it is a special char
      currentCharacter = Mid$(inputString, i, 1)
      found = (InStr(AccChars, currentCharacter) > 0)
      If found Then
        ' find position of special character in special array
        foundPosition = InStr(AccChars, currentCharacter)
        ' replace with corresponding character in "regular" array
        tempString = Replace(tempString, currentCharacter, _
                             Mid$(RegChars, foundPosition, 1))
      End If
    Next i
  End Select
  ConvertAccent = tempString
End Function
Function FixAngleBrackets(textString As String) As String
  FixAngleBrackets = Replace(Replace(textString, "<", "<"), ">", ">")
End Function
Function URLEncode(EncodeStr As String) As String
' http://www.freevbcode.com/ShowCode.asp?ID=5137
  Dim i As Integer
  Dim erg As String


  erg = EncodeStr
  ' *** First replace '%' chr
  erg = Replace(erg, "%", Chr(1))
  ' *** then '+' chr
  erg = Replace(erg, "+", Chr(2))
  For i = 0 To 255
    Select Case i
      ' *** Allowed 'regular' characters
    Case 37, 43, 48 To 57, 65 To 90, 97 To 122
    Case 1  ' *** Replace original %
      erg = Replace(erg, Chr(i), "%25")
    Case 2  ' *** Replace original +
      erg = Replace(erg, Chr(i), "%2B")
    Case 32
      erg = Replace(erg, Chr(i), "+")
    Case 3 To 15
      erg = Replace(erg, Chr(i), "%0" & Hex(i))
    Case Else
      erg = Replace(erg, Chr(i), "%" & Hex(i))
    End Select
  Next
  URLEncode = erg
End Function
Function ExtractFileName(fileName As String) As String
' extract filename portion of filename, no extension
  Dim fileN As String


  fileN = Right(fileName, Len(fileName) - InStrRev(fileName, "\"))
  fileN = Replace(fileN, GetFileType(fileN), "")


  ExtractFileName = fileN
End Function
Function GetFileType(fileName As String) As String
' get file extension
  GetFileType = Mid$(fileName, InStrRev(fileName, "."), Len(fileName))
End Function
' ***********************************************************************
' read/write operations
' ***********************************************************************
Function CreateXML(inputValues As Variant, _
                   Optional filePath As String, _
                   Optional parentNodeName As String = "Values", _
                   Optional returnXML As Boolean = 1) As String
' see http://www.jpsoftwaretech.com/create-xml-files-using-dom/
' validated using http://validator.w3.org/
  Dim pathName As String
  Dim xmlDoc As Object  ' MSXML2.DOMDocument60
  Dim mxxml As Object  ' MSXML2.MXXMLWriter60
  Dim cnth As Object  ' MSXML2.IVBSAXContentHandler
  Dim i As Long, j As Long


  ' create new DOM Document and point XML writer to it
  Set xmlDoc = GetDomDoc


  If xmlDoc Is Nothing Then
    MsgBox "Could not create MSXML DOM Document."
    Exit Function
  End If


  Set mxxml = GetMXXMLWriter
  If mxxml Is Nothing Then
    MsgBox "Could not create MXXML Writer"
    Exit Function
  End If


  Set cnth = mxxml
  mxxml.output = xmlDoc
  mxxml.indent = True


  ' begin creating the XML document output
  cnth.startDocument
  ' add xml declaration
  cnth.processingInstruction "xml", "version='1.0' encoding='UTF-8'"


  ' create parent node using input name or default of "Values"
  cnth.startElement "", "", parentNodeName, Nothing


  ' create first-level child nodes using first row of array
  For i = LBound(inputValues, 2) To UBound(inputValues, 2)
    cnth.startElement "", "", CStr(inputValues(1, i)), Nothing
    ' loop through array and create a child node for each
    ' since parent node hasn't been closed, these will automatically be child nodes
    For j = 2 To UBound(inputValues)
      cnth.startElement "", "", "Value", Nothing
      cnth.Characters CStr(inputValues(j, i))
      cnth.endElement "", "", "Value"
    Next j
    ' close parent node
    cnth.endElement "", "", CStr(inputValues(1, i))
  Next i


  ' close parent node
  cnth.endElement "", "", parentNodeName
  ' end output
  cnth.endDocument


  ' save xml?
  If Len(filePath) > 0 Then
    ' verify folder exists
    pathName = Split(filePath, ExtractFileName(filePath))(0)
    If FolderExists(pathName) Then
      ' save xml to specified filepath
      xmlDoc.Save filePath
    End If
  Else  ' return xml
    returnXML = 1
  End If


  ' return xml?
  If returnXML Then
    CreateXML = xmlDoc.xml
  End If


End Function
Function ReadXML(fileName As String) As String()
' see http://www.jpsoftwaretech.com/read-xml-files-using-dom/
  Dim xmlDoc As Object  ' MSXML2.DOMDocument60
  Dim myvalues As Object  ' MSXML2.IXMLDOMNode
  Dim values As Object  ' MSXML2.IXMLDOMNode
  Dim value As Object  ' MSXML2.IXMLDOMNode
  Dim tempString() As String
  Dim numRows As Long, numColumns As Long
  Dim i As Long, j As Long


  ' check if file exists
  If Len(Dir(fileName)) = 0 Then Exit Function


  ' create MSXML 6.0 document and load existing file
  Set xmlDoc = GetDomDoc
  If xmlDoc Is Nothing Then Exit Function
  xmlDoc.Load fileName
  If LoadError(xmlDoc) Then Exit Function


  ' second node starts the node tree
  Set myvalues = GetNode(xmlDoc, 2)
  ' array size? add +1 for header row
  numColumns = myvalues.childNodes.Length
  numRows = GetNode(myvalues, 1).childNodes.Length + 1
  ReDim tempString(1 To numColumns, 1 To numRows)


  For i = 1 To numColumns
    Set values = GetNode(myvalues, i)
    ' first value in every column is node name
    tempString(i, 1) = values.nodeName


    For j = 1 To numRows - 1
      tempString(i, j + 1) = GetNode(values, j).nodeTypedValue
    Next j


  Next i


  ReadXML = tempString


End Function


Function GetResponse(xml As Object, _
                     requestType As HTTPRequestType, _
                     destinationURL As String, _
                     Optional async As Boolean, _
                     Optional requestHeaders As Variant, _
                     Optional postContent As String) As String


  Dim reqType As String
  Dim response As String
  Dim i As Long


  ' translate enum into string
  reqType = GetRequestType(requestType)


  ' open request
  With xml
    .Open reqType, destinationURL, async


    ' check for headers
    If Not IsMissing(requestHeaders) Then
      If Not IsEmpty(requestHeaders) Then
        For i = LBound(requestHeaders) To UBound(requestHeaders)
          .setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
        Next i
      End If
    End If


    ' if HTTP POST, need to send contents, will not
    ' harm GET or HEAD requests
    .send postContent


    ' if HEAD request, return headers, not response
    If reqType = "HEAD" Then
      response = xml.getAllResponseHeaders
    Else
      response = xml.responseText
    End If


  End With


  GetResponse = response
End Function


Function FolderExists(foldername As String) As Boolean
  FolderExists = (Len(Dir(foldername)) > 0)
End Function

 

[SpreadingSheets]

How about having a macro that plays a paricularly loud and long wav file on entry of data into a particular cell - enough to cause panic in many colleagues when the boss is prowling about

Yeah, love this idea, though my crude mind immediately went to fart noises.

 

[harveya915]

Following...