Creating a Toolbar and a button that is linked to a macro

Creating a Toolbar and a button that is linked to a macro

• Handschuh

  Hi

  I think this is nearly what you want. Create a workbook and put the first part of the code in ThisWorkbook module, and the second part in a standard code module.

  Save the working program in the folder set in Excel as the one where all files will be opened at Startup.

  This is actually a cut down version of some code I use, so I've left some extras in that save the position of the command bar in the Registry and use this information when the workbook is opened.

  Good luck

  Peter Mo.

  '====================================================================
  '
  ' ThisWorkbook module
  '
  '====================================================================
  Option Explicit

  Dim myCbr As CommandBar

  '--------------------------------------------------------------------
  Private Sub Workbook_BeforeClose(Cancel As Boolean)
  ' tidy everything up
  
  ' save position on command bar

  SaveSetting strAppName, strStartup, strCBPosn, myCbr.Position
  SaveSetting strAppName, strStartup, strCBTop, myCbr.Top
  SaveSetting strAppName, strStartup, strCBLeft, myCbr.Left
  
  ' delete command bar

  Call CBDeleteCommandBar(strMyCMB)

  End Sub

  '--------------------------------------------------------------------
  Private Sub Workbook_Open()

  ' create command bar using position we had last time

  Set myCbr = CreateCustomCommandBar(strMyCMB, _
  GetSetting(strAppName, strStartup, strCBPosn, CBDefaultPosn), _
  GetSetting(strAppName, strStartup, strCBTop, CBDefaultTop), _
  GetSetting(strAppName, strStartup, strCBLeft, CBDefaultLeft))

  ' add button
  
  Call AddButton(myCbr, strRun, strRunCode)

  End Sub

  '====================================================================
  '
  ' Code Module
  '
  '====================================================================
  Option Explicit

  ' Command Bar and Button Names

  Public Const strMyCMB As String = "MyCommandBar"
  Public Const strRun As String = "Run"
  Public Const strRunCode As String = "RunCode"

  ' Registry Info

  Public Const strAppName As String = "MyName"
  Public Const strStartup As String = "Startup"
  Public Const strCBPosn As String = "Position"
  Public Const strCBTop As String = "Top"
  Public Const strCBLeft As String = "Left"

  ' Default Command Bar Position

  Public Const CBDefaultPosn As Long = msoBarTop
  Public Const CBDefaultTop As Long = 0
  Public Const CBDefaultLeft As Long = 0

  '-------------------------------------------------------------------------
  Function RunCode()
  ' Come here when the user click run button

  MsgBox "Run Code"
  
  End Function

  '-------------------------------------------------------------------------
  Function CreateCustomCommandBar(argCommandBar As String, _
  argPosn As Long, argTop As Long, argLeft As Long) As CommandBar
  ' Create Custom CommandBar

  Dim cbrNew As CommandBar
  Dim ctlCBarControl As CommandBarControl
  Dim myVar As String
  Dim lngCnt As Long
  
  If CBDoesCBExist(argCommandBar) Then
  Call CBDeleteCommandBar(argCommandBar)
  End If
  
  Set cbrNew = Application.CommandBars.Add(Name:=argCommandBar)
  
  With cbrNew
  .Visible = True
  .Position = argPosn
  .Top = argTop
  .Left = argLeft
  End With

  Set CreateCustomCommandBar = cbrNew
  
  End Function

  '-------------------------------------------------------------------------
  Sub AddButton(argCbr As CommandBar, argCaption As String, argOnAction As String)
  ' add button to custom CommandBar

  Dim ctlCBarControl As CommandBarControl

  With argCbr
  Set ctlCBarControl = .Controls.Add(msoControlButton)
  With ctlCBarControl
  .Caption = argCaption
  .Style = msoButtonCaption
  .BeginGroup = True
  .Enabled = True
  .OnAction = argOnAction
  .Parameter = argCaption
  End With
  End With

  End Sub

  '-------------------------------------------------------------------------
  Function CBDoesCBExist(strCBarName As String) As Boolean
  ' Check for existence of command bar with name strCBarName

  Dim cbrBar As CommandBar
  
  On Error Resume Next
  Set cbrBar = CommandBars(strCBarName)
  If Err = 0 Then
  CBDoesCBExist = True
  Else
  CBDoesCBExist = False
  End If
  
  End Function

  '-------------------------------------------------------------------------
  Sub CBDeleteCommandBar(strCBarName As String)
  ' Delete the command bar specified by strCBarName. If the
  ' command bar does not exist, an error will occur and that
  ' error is ignored here.
  
  On Error Resume Next
  Application.CommandBars(strCBarName).Delete
  
  End Sub

  
  

• Teo97917

  This is great...thank you
  
• Creating a Toolbar and a button that is linked to a macro