Creating Excel2013-style-toolbar in Excel2010 (Excel VBA)

来源:互联网 发布:浩浩乎如冯虚御风的乎 编辑:程序博客网 时间:2024/06/05 20:28

*******************************************In the script screen of <Thisworkbook>, to where paste the following script, *******************************************

Option Explicit
Private Const gs_toolbar_extract_rpt_a As String = "toolbar_extract_rpt_a"
Private Const gs_toolbar_extract_rpt_c As String = "toolbar_extract_rpt_c"
Private Const gs_toolbar_extract_rpt_e As String = "toolbar_extract_rpt_e"
Private Const gs_toolbar_tool_1 As String = "toolbar_tool_1"

Private Sub Workbook_Activate()
    On Error Resume Next
   
    Application.CommandBars(gs_toolbar_extract_rpt_a).Visible = True
    Application.CommandBars(gs_toolbar_extract_rpt_c).Visible = True
    Application.CommandBars(gs_toolbar_extract_rpt_e).Visible = True
End Sub

Private Sub Workbook_Deactivate()
    On Error Resume Next
   
    Application.CommandBars(gs_toolbar_extract_rpt_a).Visible = False
    Application.CommandBars(gs_toolbar_extract_rpt_c).Visible = False
    Application.CommandBars(gs_toolbar_extract_rpt_e).Visible = False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
   
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_a)
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_c)
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_e)
    Call sub_RemoveToolBar(gs_toolbar_tool_1)
  '  Call sub_remove_all_bars
End Sub

 

Private Sub Workbook_Open()
    gs_saved_path = ThisWorkbook.Path
  
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_a)
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_c)
    Call sub_RemoveToolBar(gs_toolbar_extract_rpt_e)
    Call sub_RemoveToolBar(gs_toolbar_tool_1)
    'Call sub_remove_all_bars
   
    'gs_toolbar_extract_rpt_a
    '============================================================================================
    Call sub_add_new_bar(gs_toolbar_extract_rpt_a)
    Call sub_add_new_button(as_bar_name:=gs_toolbar_extract_rpt_a, _
                            as_btn_caption:="Extract Report (A)", _
                            as_on_action:="'sub_extract_report ""A"" '", _
                            ai_face_id:=300, _
                            as_tip_text:="Extract Report A")
                   
    Call sub_add_new_button(as_bar_name:=gs_toolbar_extract_rpt_a, _
                            as_btn_caption:="Generate Text File (A)", _
                            as_on_action:="'sub_gen_text_file ""A"" '", _
                            ai_face_id:=139, _
                            as_tip_text:="Generate Text File A")

'    Call sub_add_new_button(as_bar_name:=gs_toolbar_extract_rpt_a, _
'                            as_btn_caption:="", _
'                            as_on_action:="'sub_RemoveToolBar ""toolbar_extract_report"" '", ai_face_id:=722, _
'                            as_tip_text:="Exit this toolbar")
    '============================================================================================

end sub

 

******************************************* insert a new module - Module_CommandBar, to whose script screen paste the following script ***********************

Option Explicit

Sub sub_add_new_bar(as_bar_name As String)
    Dim lcb_new_commdbar As CommandBar
       
    Call sub_RemoveToolBar(as_bar_name)
   
    Set lcb_new_commdbar = Application.CommandBars.Add(as_bar_name, msoBarTop)
    lcb_new_commdbar.Visible = True
    Set lcb_new_commdbar = Nothing
End Sub

Public Sub sub_RemoveToolBar(as_toolbar As String)
    On Error Resume Next
   
    Dim lcb_commdbar As CommandBar
   
    Set lcb_commdbar = Nothing
   
    Application.CommandBars(as_toolbar).Delete
    Application.CommandBars("Custom 1").Delete
End Sub

Sub sub_remove_all_bars()
    On Error Resume Next
    Dim tempbar As CommandBar

    For Each tempbar In Application.CommandBars
        'If tempbar.Name Like "my_bar*" Then
            tempbar.Delete
        'End If
    Next

End Sub

Public Sub sub_add_new_button(as_bar_name As String, as_btn_caption As String, _
                    as_on_action As String, ai_face_id As Integer, _
                    Optional as_tip_text As String)

    Dim lcb_commdbar As CommandBar
    Dim lbtn_new_button As CommandBarButton
   
    Set lcb_commdbar = Application.CommandBars(as_bar_name)
       
    Set lbtn_new_button = lcb_commdbar.Controls.Add(msoControlButton)
    With lbtn_new_button
        .Caption = as_btn_caption
        .Style = msoButtonIconAndCaptionBelow
        '.OnAction = "sub_RemoveToolBar"
        .OnAction = as_on_action
        .FaceId = ai_face_id
        .TooltipText = as_tip_text
        .BeginGroup = True
    End With
   
    Set lcb_commdbar = Nothing
    Set lbtn_new_button = Nothing
End Sub


 Then you can see the command bar and button in the ribbon <Addin>.

 

0 0
原创粉丝点击