April Fools Reverse The Excel Menu with VBA

The code below will, when run, reverse all of the menus and their options within Excel.  For example; File will become Elif and Tools will become Sloot.  It works on Excel 97 through 2003.  Simply run the code again to ‘reverse’ the name back to their original format.  It is worth noting that Excel remembers the settings, so you will need to be able to re-run the code.

Sub ReverseMenuText()
    Dim m1 As CommandBarControl
    Dim m2 As CommandBarControl
    Dim m3 As CommandBarControl

    On Error Resume Next
    For Each m1 In Application.CommandBars(1).Controls
        m1.Caption = Reverse(m1.Caption)
        For Each m2 In m1.Controls
            m2.Caption = Reverse(m2.Caption)
            For Each m3 In m2.Controls
                m3.Caption = Reverse(m3.Caption)
            Next m3
        Next m2
    Next m1
End Sub


Function Reverse(MenuText As String) As String
    Dim Temp As String, Temp2 As String
    Dim ItemLen As Integer, i As Integer
    Dim HotKey As String * 1
    Dim Found As Boolean

    ItemLen = Len(MenuText)
    Temp = ""
    For i = ItemLen To 1 Step -1
        If Mid(MenuText, i, 1) = "&" Then _
            HotKey = Mid(MenuText, i + 1, 1) _
        Else Temp = Temp & Mid(MenuText, i, 1)
    Next i
    Temp = Application.Proper(Temp)
    Found = False
    Temp2 = ""
    For i = 1 To ItemLen - 1
        If UCase(Mid(Temp, i, 1)) = UCase(HotKey) And Not Found Then
            Temp2 = Temp2 & "&"
            Found = True
        End If
        Temp2 = Temp2 & Mid(Temp, i, 1)
    Next i
    If Left(Temp2, 3) = "..." Then Temp2 = Right(Temp2, ItemLen - 3) & "..."
    Reverse = Temp2
End Function

This code was orinally found on MrExcel.com.

Aprils Fools ‘Quit Excel’ Workbook_Open Event :)

I just came across this Aprils Fools trick while looking through some old code files.  Figured as it’s the right time of year I’d post it.  Put this code in the ‘ThisWorkbook’ code module, save the file and wait for the users to shout ;)

Private Sub Workbook_Open()
'-------------------------------------------------------------------------
' Procedure : Workbook_Open
' Author    : Matthew Sims - Zypher.co.uk
' Date      : 01/03/2005
' Purpose   : To annoy ;)
'             Quit Excel 30 times out of 100 when the user opens this file
'-------------------------------------------------------------------------
'
    ' Set the annoying level (percentage chance that Exel will close)
    Const annoying_level As Long = 30
    Dim annoying_number As Long

    Application.DisplayAlerts = False

    Randomize
    annoying_number = 100 * Rnd

    ' If the randomly chosen 'annoying_number' is lower then the
    ' preset 'annoying_level' then quite Excel
    If annoying_number < annoying_level Then
        ' Quit Excel
        Application.Quit
    End If

End Sub

Using VBA to Truncate Decimal Values

Recently I have needed to truncate a decimal value to a set number of decimal places. 

For example; If you wanted the number 55.446 to two decimal places rounding the number would return 55.45.  Truncating the number to two decimal places returns 55.44. 

To do this I created the function below.  Pass in a decimal value and the number of decimal places you want the number truncated too and the function returns the value as a ‘Double’.

Public Function TruncTo(dblValue As Double, lngPlaces As Long) As Double
'-------------------------------------------------------------------------
' Procedure : TruncTo
' Author    : Matthew Sims
' Date      : 08-Oct-2010
' Purpose   : Truncate a decimal value to the requested number of decimal places
'-------------------------------------------------------------------------
'
    On Error GoTo TruncTo_Error

    If IsNumeric(dblValue) Then
        TruncTo = Int(dblValue * 10 ^ lngPlaces) / 10 ^ lngPlaces
    Else
        TruncTo = 0
    End If

    On Error GoTo 0
    Exit Function

TruncTo_Error:
    ' Add some error handling code here
End Function

VBA Adjusting Speaker Volume (and Mute)

Following on from the code here (Using VBA Speech) the code below is used to make adjust the speaker volume, including turning mute on / off.

Private Declare Sub keybd_event Lib "user32" ( _
   ByVal bVk As Byte, ByVal bScan As Byte, _
   ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Sub VolUp()
'-- Turn volumn up --
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 0, 3, 0
End Sub

Sub VolDown()
'-- Turn volumn down --
   keybd_event VK_VOLUME_DOWN, 0, 1, 0
   keybd_event VK_VOLUME_DOWN, 0, 3, 0
End Sub

Sub VolToggle()
'-- Toggle mute on / off --
   keybd_event VK_VOLUME_MUTE, 0, 1, 0
End Sub

Again, this requires the PC to a sound card and speakers.

Using VBA Speech

With April Fools day approaching (well, four weeks) I though I’d post a couple of amusing VBA tricks and jokes you could use.  The first is using the speech and the CD trey.  The code below can be copied straight into a VBA code module.

Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long)

Private Sub Workbook_Open()
    UseSpeech "The Mouse is hungry."
    OpenCDTray
    UseSpeech "Please add cheese."
    CloseCDTray
End Sub

Private Sub OpenCDTray()
    mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub

Private Sub UseSpeech(stringToSpeak As String)
    Range("A1").Value = stringToSpeak
    Range("A1").Speak
    Application.CommandBars("Text To Speech").Visible = False
End Sub

Private Sub CloseCDTray()
    mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub

This does require the PC to have speakers.

VBA Version Property

It is sometimes useful to know which version of Excel your user is using.  An example of when this would be useful is knowing whether the user is in Excel 2007/2010 or and older version.  Excel 2007 was the first release that allowed over 65535 rows and 255 columns.  Excel 2007 has over 1 million rows (1048576) and 16384 columns.

This can make a big difference to what you can do with the data available to you.  If your user is in Excel 2003 for example your code could crash if it attempts to copy too much data into the active workbook.  The function below can be used within your code to confirm the Excel version, you can then call a different routine depending on it’s results.

Private Function ReturnExcelVersion() As String
'-----------------------------------------------------------------
' Procedure : ReturnExcelVersion
' Author    : Matthew - Zypher.co.uk
' Purpose   : return a string value denoting the version of Excel
'             Check the first two characters as Excel 97 has
'             several different releases and patches
'             http://support.microsoft.com/kb/232652
'-----------------------------------------------------------------
'
    Select Case Left(Application.Version, 2)

         Case Is = "14"
            ReturnExcelVersion = "2010" 
        Case Is = "12"
            ReturnExcelVersion = "2007"
        Case Is = "11"
            ReturnExcelVersion = "2003"
        Case Is = "10"
            ReturnExcelVersion = "2002"
        Case Is = "9."
            ReturnExcelVersion = "2000"
        Case Is = "8."
            ReturnExcelVersion = "97"
        Case Is = "7."
            ReturnExcelVersion = "95"
        Case Else
            ReturnExcelVersion = "Unknown"
    End Select
End Function

Excel 2010 is version 14. The version number 13 was skipped because of the aversion to the number 13.  Another relevant link is XL97: Overview and History of Excel Patches.

You may also want to look into Application.OperatingSystem.

As always, if you have any questions do let us know via the comments section.

Special Folders using the FileSystemObject

There are several methods to get find out the file paths for Microsoft Windows’ special folders (Systems folder, Temporary folder etc).  The example below uses the FileSystemObject.

Sub Special_Folders()
'-----------------------------------------------------------------
' Procedure : Special_Folders
' Purpose   : Retrieve file path for MS Windows 'special folders'
'             Requires a reference to Microsoft Scripting Runtime
'-----------------------------------------------------------------
'
    On Error GoTo ErrTrap

    Dim oFS As FileSystemObject

    Set oFS = New FileSystemObject

    ' Windows Folder Path
    MsgBox FS.GetSpecialFolder(WindowsFolder)

    ' System Folder - (example - Windows\System32)
    MsgBox oFS.GetSpecialFolder(SystemFolder)

    ' Temporary Folder Path
    MsgBox oFS.GetSpecialFolder(TemporaryFolder)

    If Not oFS Is Nothing Then Set oFS = Nothing

ErrTrap:
    Select Case Err.Number
        Case Is = 0
            ' No error continue
        Case Else
            MsgBox Err.Number & " - " & Err.Description
            Err.Clear
    End Select
End Sub

This routine requires a reference Microsoft Scripting Runtime.