Beyond Excel: VBA and Database Manipulation

Oct 6 2009   7:04PM GMT

Code for “easy” Button



Posted by: Craig Hatmaker
Tags:
database
development
excel
Microsoft Excel
ms query
odbc
sql
vba

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

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

 Comment on this Post

 
There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when other members comment.

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to: