完美Excel

Sub WBDisplayPopUp()
' If ActiveWorkbook.Name = ThisWorkbook.Name Then
    On Error Resume Next
    Application.CommandBars(ThisWorkbook.Sheets("MenuSheet").Range("B2").Value).ShowPopup
    On Error GoTo 0
' End If
End Sub

   <ribbon startFromScratch="true">

   <qat>
     <documentControls>
        <control/>
     </documentControls>
   </qat>

    <qat>
        <sharedControls>
            <control/>
        </sharedControls>
    </qat>

   <qat>
     <documentControls>
	<control 
       idMso="Bold"
       screentip="Make it Bold"
       supertip="Click here to make the selected text bold."/>
      <button
       id="rxbtnOpen"
       imageMso="FileOpen"
       screentip="This is Happy"
       supertip="Click here for a happy message"
       onAction="rxbtnOpen_click"/>
     </documentControls>
    </qat>

       <group 
        id="rxgrp" 
        label="My Custom Group">
        <splitButton 
         id="rxsbtn" 
         size="large">
         <button 
          id="rxbtn2" 
          imageMso="HappyFace" 
          label="My Happy Split"/>
          <menu 
           id="rxmnu">
           <button 
            id="rxbtn3" 
            label="My Happy Menu"
            imageMso="HappyFace"
            onAction="rxbtn3_click"/>
          </menu>
        </splitButton>
        </group>

   <qat>
     <documentControls>
      <control
       id="rxsbtn"
       imageMso="HappyFace"
       screentip="This is Happy"
       supertip="Click here for a happy message"/>
     </documentControls>
    </qat>

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
   <ribbon startFromScratch="true">
     <tabs>
      <tab
       id="rxtabHome"
       label="Home">
       <group
        idMso="GroupClipboard"/>
       <group
        idMso="GroupFont"/>
       <group
        idMso="GroupAlignmentExcel"/>
       <group
        idMso="GroupNumber"/>
       <group
        idMso="GroupStyles"/>
       <group
        idMso="GroupCells"/>
       <group
        idMso="GroupEditingExcel"/>
	 <group
	  id="rxgrp" 
	  label="My QAT Custom Group"
        getVisible="rxshared_getVisible">
 
	  <button 
	   id="rxbtnHappy" 
	   label="Mr. Happy Face" 
	   imageMso="HappyFace" 
	   size="large" 
	   onAction="rxshared_click" />
	  <button 
	   id="rxbtnHappy2" 
	   label="Mr. Happy Face 2" 
	   imageMso="HappyFace" 
	   size="large"
	   onAction="rxshared_click" />
	 </group>
 
      </tab>
     </tabs>
 
    <qat>
     <documentControls>
	<control
	  idMso="GroupInsertChartsExcel"/>
      <control
        idMso="GroupFunctionLibrary"/>
      <control
        id="rxgrp"
        imageMso="FormatCellsDialog"/>
     </documentControls>
    </qat>
 
  </ribbon>
</customUI>

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"
    onLoad="rxIRibbonUI_onLoad">
    <commands>
     <command
      idMso="FileSave"
      onAction="rxFileSave_repurpose"/>
     <command
      idMso="FileOpen"
      onAction="rxFileOpen_repurpose"/>
    </commands>
 
   <ribbon startFromScratch="true">
     <qat>
     <documentControls>
	<control 
       idMso="FileSave"
       screentip="Repurposed Save"
       supertip="This is a repurposed command"/>
 
      <control
       idMso="FileOpen"
       screentip="Repurposed File Open"
       supertip="This is a repurposed command"/>
     </documentControls>
    </qat>
  </ribbon>
 
</customUI>

Public WithEvents appXL As Excel.Application
 
Private Sub ShortcutsEnabled(ByVal blnEnabled As Boolean)
    Select Case blnEnabled
        Case Is = True
            Application.OnKey "^o"
            Application.OnKey "^s"
        Case Is = False
            Application.OnKey "^o", "commandDisabled"
            Application.OnKey "^s", "commandDisabled"
    End Select
End Sub
 
Private Sub setEnabled(ByVal Wb As Workbook)
    Select Case Wb.Name
        Case Is = ThisWorkbook.Name
            ShortcutsEnabled False
        Case Else
            ShortcutsEnabled True
    End Select
End Sub

Private Sub appXL_WorkbookActivate(ByVal Wb As Workbook)
    setEnabled Wb
End Sub
 
Private Sub appXL_WorkbookDeactivate(ByVal Wb As Workbook)
    setEnabled Wb
End Sub

Dim XL As New clsAppExcelEvents
Private Sub Workbook_Open()
    Set XL.appXL = Application
End Sub

     <documentControls>
	<control
	  id="rxgrp"
        imageMso="AdvancedFileProperties"/>
      <button 
	  id="rxbtnShowPopup"
        image="rob"
	  screentip="This is Robert's QAT"
	  supertip="You can only customize the QAT by starting from scratch. If you do not do that you will not be able to make any changes..."
	  onAction="rxbtnShowPopup_Click"
	  />
     </documentControls>

Public Const POPNAME As String = "MY POPUP"
 
Sub loadPopup()
    Dim mnuWs           As Worksheet
    Dim cmdbar          As CommandBar
    Dim cmdbarPopup     As CommandBarPopup
    Dim cmdbarBtn       As CommandBarButton
    Dim nRowCount       As Long
 
    Call unloadPopup
    Set mnuWs = ThisWorkbook.Sheets("MenuItems")
    Set cmdbar = Application.CommandBars.Add(POPNAME, msoBarPopup)
 
    nRowCount = 2
    With mnuWs
        Do Until IsEmpty(.Cells(nRowCount, 1))
 
            Select Case UCase(.Cells(nRowCount, 1))
                Case "POPUP"
                    Set cmdbarPopup = cmdbar.Controls.Add(msoControlPopup)
                        cmdbarPopup.Caption = .Cells(nRowCount, 2)
                        If .Cells(nRowCount, 3) <> "" Then
                            cmdbarPopup.BeginGroup = True
                        End If
 
                Case "BUTTON"
                    Set cmdbarBtn = cmdbarPopup.Controls.Add(msoControlButton)
                        cmdbarBtn.Caption = .Cells(nRowCount, 2)
                        If .Cells(nRowCount, 3) <> "" Then
                            cmdbarBtn.BeginGroup = True
                        End If
                        cmdbarBtn.FaceId = .Cells(nRowCount, 4)
                        cmdbarBtn.OnAction = .Cells(nRowCount, 5)
 
                Case "BUTTON_STANDALONE"
                    Set cmdbarBtn = cmdbar.Controls.Add(msoControlButton)
                        cmdbarBtn.Caption = .Cells(nRowCount, 2)
                        If .Cells(nRowCount, 3) <> "" Then
                            cmdbarBtn.BeginGroup = True
                        End If
                        cmdbarBtn.FaceId = .Cells(nRowCount, 4)
                        cmdbarBtn.OnAction = .Cells(nRowCount, 5)
 
            End Select
            nRowCount = nRowCount + 1
        Loop
    End With
 
End Sub
 
Sub unloadPopup()
    On Error Resume Next
    Application.CommandBars(POPNAME).Delete
End Sub
 
Sub showAbout()
    MsgBox "This is a sample on how to customize the QAT on the fly!!", vbInformation
End Sub
 
Sub showHelp()
    On Error GoTo Err_Handler
    ThisWorkbook.FollowHyperlink "http://www.msofficegurus.com", , True, True
    Exit Sub
 
Err_Handler:
    MsgBox Err.Description, vbCritical, Err.Number
 
End Sub

Dim grxIRibbonUI        As IRibbonUI
 
Sub rxIRibbonUI_onLoad(ribbon As IRibbonUI)
    On Error Resume Next
    Set grxIRibbonUI = ribbon
 
    Application.Workbooks.Add
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        With ActiveWorkbook
            .Saved = True
            .Close
        End With
    End If
 
'   可以在这个事件或者ThisWorkbook的Open事件中装载弹出菜单
    Call loadPopup
End Sub
 
Sub rxbtnShowPopup_Click(control As IRibbonControl)
    On Error Resume Next
    Application.CommandBars(POPNAME).ShowPopup
End Sub
 
Sub rxbtnHappy_Click(control As IRibbonControl)
    MsgBox "This is Mr. Happy Face... hurray!!", vbExclamation
End Sub

Sub rxIRibbonUI_onLoad(ribbon As IRibbonUI)
    Set grxIRibbonUI = ribbon
    On Error Resume Next
    Application.Workbooks.Add
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then
        With ActiveWorkbook
            .Saved = True
            .Close
        End With
    End If
End Sub

Sub CreateMenu()
'   打开工作簿时执行本过程
'   注: 在本过程中没有编写错误处理的代码

    Dim MenuSheet As Worksheet
    Dim MenuObject As CommandBarPopup
 
    Dim MenuItem As Object
    Dim SubMenuItem As CommandBarButton
    Dim Row As Integer
    Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId
 
''''''''''''''''''''''''''''''''''''''''''''''''''''
'   菜单数据所在的工作表
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
''''''''''''''''''''''''''''''''''''''''''''''''''''

'   确保不会出现重复菜单
    Call DeleteMenu
 
'   初始化行计数器
    Row = 2
 
'   使用存储在MenuSheet工作表中的数据添加菜单,菜单项和子菜单项
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        With MenuSheet
            MenuLevel = .Cells(Row, 1)
            Caption = .Cells(Row, 2)
            PositionOrMacro = .Cells(Row, 3)
            Divider = .Cells(Row, 4)
            FaceId = .Cells(Row, 5)
            NextLevel = .Cells(Row + 1, 1)
        End With
 
        Select Case MenuLevel
            Case 1 ' 代表菜单
'              在工作表命令栏中添加顶级菜单
                Set MenuObject = Application.CommandBars(1). _
                    Controls.Add(Type:=msoControlPopup, _
                    Before:=PositionOrMacro, _
                    Temporary:=True)
                MenuObject.Caption = Caption
 
            Case 2 ' 代表菜单项
                If NextLevel = 3 Then
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
                Else
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
                    MenuItem.OnAction = PositionOrMacro
                End If
                MenuItem.Caption = Caption
                If FaceId <> "" Then MenuItem.FaceId = FaceId
                If Divider Then MenuItem.BeginGroup = True
 
            Case 3 ' 代表子菜单项
                Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
                SubMenuItem.Caption = Caption
                SubMenuItem.OnAction = PositionOrMacro
                If FaceId <> "" Then SubMenuItem.FaceId = FaceId
                If Divider Then SubMenuItem.BeginGroup = True
        End Select
        Row = Row + 1
    Loop
End Sub
 
Sub DeleteMenu()
'   关闭工作簿时执行本过程
'   删除创建的菜单
    Dim MenuSheet As Worksheet
    Dim Row As Integer
    Dim Caption As String
 
    On Error Resume Next
    Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
    Row = 2
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        If MenuSheet.Cells(Row, 1) = 1 Then
            Caption = MenuSheet.Cells(Row, 2)
            Application.CommandBars(1).Controls(Caption).Delete
        End If
        Row = Row + 1
    Loop
    On Error GoTo 0
End Sub
 
Sub DummyMacro()
    MsgBox "这里一个用于演示的宏."
End Sub

Private Sub Workbook_Open()
    Call CreateMenu
End Sub
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call DeleteMenu
End Sub

Const NA = "N/A"
'列偏移量
Const TAG_OFFSET = 1
Const CAPTION_OFFSET = 2
Const TYPE_OFFSET = 3
Const ONACTION_OFFSET = 4
Const BEGINGROUP_OFFSET = 5
Const DESCRIPTION_OFFSET = 6
 
Sub BuildMenu()
  Dim ws As Worksheet
  Dim rg As Range
  On Error GoTo ErrHandler
  Set ws = ThisWorkbook.Worksheets("Menu Builder")
  '从第二行开始,因为第一行已经包含了列标题
  Set rg = ws.Cells(2, 1)
  Do Until IsEmpty(rg)
      If rg.Value = NA Then
      '新建顶级菜单项
          AddTopLevelItem rg
      Else
          '现有控件的子菜单
          AddSubItem rg
      End If
      '向下移一行
      Set rg = rg.Offset(1, 0)
  Loop
ExitPoint:
  Set rg = Nothing
  Set ws = Nothing
  Exit Sub
ErrHandler:
  Debug.Print Err.Description
  Resume ExitPoint
End Sub
 
'向工作表菜单栏中添加新菜单项
Private Function AddTopLevelItem(rg As Range) As CommandBarControl
  Dim cbWSMenuBar As CommandBar
  Dim cbc As CommandBarControl
  On Error GoTo ErrHandler
  Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
  '添加菜单项
  Set cbc = cbWSMenuBar.Controls.Add(msoControlPopup, , , , True)
  cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
  cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
  cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
  '返回新添加的菜单项
  Set AddTopLevelItem = cbc
ExitPoint:
  Set cbc = Nothing
  Set cbWSMenuBar = Nothing
  Exit Function
ErrHandler:
  Set AddTopLevelItem = Nothing
  Resume ExitPoint
End Function
 
Private Function AddSubItem(rg As Range) As CommandBarControl
  Dim cbcParent As CommandBarControl
  Dim cbc As CommandBarControl
  On Error GoTo ErrHandler
  '基于父标记定位父菜单
  Set cbcParent = Application.CommandBars.FindControl(, , rg.Value)
  If Not cbcParent Is Nothing Then
      '添加菜单项
      Set cbc = cbcParent.Controls.Add(GetType(rg))
      '确保该菜单项具有一个OnAction值而不是N/A
      If rg.Offset(0, ONACTION_OFFSET).Value <> NA Then
          cbc.OnAction = rg.Offset(0, ONACTION_OFFSET).Value
      End If
      cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
      cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
      cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
      cbc.BeginGroup = rg.Offset(0, BEGINGROUP_OFFSET).Value
      '返回新添加的控件
      Set AddSubItem = cbc
  Else
      '不能找到父控件-返回无
      Set AddSubItem = Nothing
  End If
ExitPoint:
  Set cbc = Nothing
  Set cbcParent = Nothing
  Exit Function
ErrHandler:
  Debug.Print Err.Description
  Set AddSubItem = Nothing
  Resume ExitPoint
End Function
 
'将所选的msoControlType枚举转换为值
Private Function GetType(rg As Range) As Long
  Dim sType As String
  sType = rg.Offset(0, TYPE_OFFSET).Value
  Select Case sType
      Case Is = "msoControlPopup"
          GetType = msoControlPopup
      Case Is = "msoControlButton"
          GetType = msoControlButton
      Case Is = "msoControlDropDown"
          GetType = msoControlDropdown
      Case Else '包括N/A
      '默认为msoControlPopup
          GetType = msoControlPopup
  End Select
End Function
 
'删除标记为"我的菜单1"的控件
Sub DeleteMyMenu1()
  DeleteMenu "我的菜单1"
End Sub
 
'删除标记为"我的菜单2"的控件
Sub DeleteMyMenu2()
  DeleteMenu "我的菜单2"
End Sub
 
Private Sub DeleteMenu(sTag As String)
  Dim cbc As CommandBarControl
  Set cbc = Application.CommandBars.FindControl(Tag:=sTag)
  If Not cbc Is Nothing Then
  cbc.Delete
  End If
  Set cbc = Nothing
End Sub