Good Excel Practical Jokes, Pranks, Mean Tricks, etc. - Page 45

Thanks Thanks:  0
Likes Likes:  0
Page 45 of 45 FirstFirst ... 35434445
Results 441 to 449 of 449

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

  1. #441
    Board Regular RobMatthews's Avatar
    Join Date
    Nov 2008
    Location
    Brisbane, AU
    Posts
    79
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    Quote Originally Posted by RobMatthews View Post
    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
    Code:
    MsgBox "Is that colourful enough, boss?"

  2. #442
    Board Regular wellsr's Avatar
    Join Date
    May 2015
    Location
    United States
    Posts
    127
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    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

  3. #443
    New Member
    Join Date
    Jun 2015
    Posts
    11
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    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

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

  4. #444
    New Member
    Join Date
    May 2012
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    Outstanding lol!!!

    Quote Originally Posted by biocidej View Post
    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.

    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

  5. #445
    Board Regular wellsr's Avatar
    Join Date
    May 2015
    Location
    United States
    Posts
    127
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    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!

  6. #446
    Board Regular BiocideJ's Avatar
    Join Date
    Jan 2012
    Location
    Florida, USA
    Posts
    1,664
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    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:
    Code:
    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:
    Code:
    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:
    Code:
    
    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
    I use Excel 2010 at work.
    Notusingindentsincodeislikenotusingspacesinsentences.Youcanmakeitout,butonlywithdifficulty.

  7. #447
    New Member
    Join Date
    Jul 2016
    Posts
    0
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    I created an account to leave this here...

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

    Code:
    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.

  8. #448
    Board Regular CalcSux78's Avatar
    Join Date
    Oct 2013
    Location
    STL
    Posts
    1,012
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    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:
    Code:
    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:
    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
    Code:
    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
    Need a more specific answer? Use MrExcel HTML Maker to post an example.

    "The quality of life depends on the clarity of the message." - Unknown

    Cunningham's Law: "The best way to get the right answer on the Internet is not to ask a question, it's to post the wrong answer."

  9. #449
    New Member
    Join Date
    Oct 2016
    Posts
    0
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Good Excel Practical Jokes, Pranks, Mean Tricks, etc.

    Quote Originally Posted by Iridium View Post
    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.

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

DMCA.com