Code for “easy” Button

Put an “easy” button in your spreadsheets to facilitate launching any macro.

Welcome new readers.  We’ve been talking about how to bring data into XL.  This post introduces the first of many standard routines I use to make assembling real data analysis tools in minutes.  It’s a little function to enhance the user experience by making buttons that look similar to Staple’s ”easy” button.  Who couldn’t use an “easy” button?  

easy button

Option Explicit

Global Const Success = False
Global Const Failure = True 

Function Create_Easy_Button(sText As String, sMacro As String, _
                            x As Long, y As Long) As Boolean

'   Create_Easy_Button:     Create a clickable button resembling
'                           Staples' "easy" button

'   Parameters:     sText:  A short word for the button like
'                           "easy", "Load", "Post", "Save", or "New"
'                   sMacro: The macro name to attach to this button
'                   x:      Button's horizontal position
'                   y:      Button's vertical position

'   Example:        Create_Easy_Button "easy", "Macro1", 10, 8

'     Date   Init Modification
'   01/01/01 CWH  Initial Programming Copyright Craig Hatmaker 10/07/2009

    On Error GoTo ErrHandler            '
    Create_Easy_Button = Failure        'Assume the Worst

    If ShapeExists(sText & "_Button_Base") Then _
        ActiveSheet.Shapes(sText & "_Button_Base").Delete
    If ShapeExists(sText & "_Button_Text") Then _
        ActiveSheet.Shapes(sText & "_Button_Text").Delete

    If x = 0 Then x = 10
    If y = 0 Then y = 8

    With ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, 35, 35)
        .Name = sText & "_Button_Base"
        .Fill.ForeColor.RGB = RGB(200, 0, 0)        'Dark Red center
        .Placement = xlFreeFloating
        .OnAction = sMacro
        With .Line 'White border
            .ForeColor.RGB = RGB(255, 255, 255)
            .Weight = 3
        End With
        With .Shadow
            .Visible = True
            .OffsetX = 2
            .OffsetY = 2
            .Transparency = 0.5
            .ForeColor.RGB = RGB(10, 10, 10)
        End With
        With .ThreeD
            .BevelTopType = 3
            .BevelTopDepth = 20  'Rounded top
            .BevelTopInset = 19  'Rounded Top
            .ContourWidth = 0    'No line around the base
            .Depth = 2
            .ExtrusionColorType = 1
            .FieldOfView = 45
            .LightAngle = 300    'Light from above and to the left
            .Perspective = 0
            .PresetLighting = 15
            .PresetMaterial = 6  'Plastic
        End With
    End With

    With ActiveSheet.Shapes.AddTextbox( _
         msoTextOrientationHorizontal, x - 1, y - 2, 35, 35)
        .Name = sText & "_Button_Text"
        With .TextFrame
            .MarginBottom = 0
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
            .Characters.Text = sText
            With .Characters.Font
                .Bold = True
                .Size = 16
                .Name = "Calibri"
                .Color = RGB(255, 255, 255)
                .Shadow = True
            End With
        End With
        .Line.Visible = False
        .Fill.Visible = False
        .TextEffect.PresetTextEffect = 2
        .Placement = xlFreeFloating
        .OnAction = sMacro
    End With
   
    Create_Easy_Button = Success         'Successful finish

ErrHandler:

    On Error GoTo 0   
    If Err.Number <> 0 Then MsgBox _
        "Create_Easy_Button - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext

End Function

Function ShapeExists(sName As String)

'   ShapeExists:    See if a Shape Exists

'   Parameters:     sName - Shape Name to be checked

'   Example:        If not ShapeExists("EasyButton") then _
'                       Create_Easy_Button "easy", "Show_Prompt", 10, 8

'     Date   Init Modification
'   01/01/01 CWH  Initial Programming

    On Error GoTo ErrHandler
    ShapeExists = False     'Assume not found
   
    Dim objName As Object
   
    For Each objName In ActiveSheet.Shapes
        If objName.Name = sName Then
            ShapeExists = True
            Exit For
        End If
    Next

ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "ShapeExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function