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.