VBA 创建Add-Ins和右键菜单的例子

1. ThisWorkbook

在ThisWorkbook中加入如下代码

Option Explicit

Dim WithEvents app As Application

Private Sub workbook_open()
    'Application.OnKey "^+s", "Base.sbSave"
    'Set app = Excel.Application
    Call StartMenu.CreateFaceMenu
    
End Sub

2. 创建StartMenu标准模块

Option Explicit

Sub CreateFaceMenu()
    Dim i As Integer
    Dim MyBar As CommandBar
    Dim MyButton As CommandBarButton
    Dim ButDecCap As Variant
    Dim ButCmd As Variant
    Dim ButIcon As Variant
    Dim MyPopup As CommandBarPopup
    Const strListMenuName As String = "▼List"
    
On Error Resume Next
    
    '---------------------------------------------------------
    'Base
    '---------------------------------------------------------
    If isExistMenu("Base") Then
        CommandBars.Item("Base").Delete
    End If
    
    ButDecCap = Array("Save", "Pic85%", "Zoom", "SearchHyperLinks")
    ButCmd = Array("Base.sbSave", "Base.sbPic", "Base.sbZoom", "Base.SearchHyperLinks")
    ButIcon = Array(3, 445, 444, 25)
    
    Set MyBar = CommandBars.Add("Base", msoBarTop, False, True)
    With MyBar
        For i = 0 To UBound(ButDecCap)
            Set MyButton = .Controls.Add(Type:=msoControlButton)
            MyButton.Width = 30
            MyButton.Height = 30
            With MyButton
                .OnAction = ButCmd(i)
                .Style = msoButtonIconAndCaption
                .FaceId = ButIcon(i)
                .Caption = ButDecCap(i)
            End With
            Set MyButton = Nothing
        Next i
        .Visible = True
        Set MyBar = Nothing
        Set MyButton = Nothing
    End With
    'Application.OnKey "^s", "Base.sbSave"
    
    '---------------------------------------------------------
    'List sample
    '---------------------------------------------------------
    If isExistMenu("ListSample") Then
        CommandBars.Item("ListSample").Delete
    End If
    
    ButDecCap = Array("Save", "Zoom")
    ButCmd = Array("Base.sbSave", "Base.sbZoom")
    ButIcon = Array(3, 444)
    
    Set MyBar = CommandBars.Add("ListSample", msoBarTop, False, True)
    With MyBar
        Set MyPopup = .Controls.Add(Type:=msoControlPopup, Before:=1)
        With MyPopup
            .Width = 30
            .Height = 30
            .Caption = strListMenuName
        End With
        Dim objList As Object
        For i = 0 To UBound(ButDecCap)
            Set objList = .Controls(strListMenuName).Controls.Add(Type:=msoControlButton, Before:=1)
            With objList
                .OnAction = ButCmd(i)
                .Style = msoButtonIconAndCaption
                .FaceId = ButIcon(i)
                .Caption = ButDecCap(i)
            End With
        Next
        .Visible = True
        Set objList = Nothing
        Set MyPopup = Nothing
        Set MyBar = Nothing
    End With
    
    '---------------------------------------------------------
    'PopMenu
    '---------------------------------------------------------
    ButDecCap = Array("Save", "Zoom")
    ButCmd = Array("Base.sbSave", "Base.sbZoom")
    ButIcon = Array(3, 444)
    CommandBars("Cell").Reset
    Set MyBar = CommandBars("Cell")
    With MyBar
        For i = 0 To UBound(ButDecCap)
            .Controls.Add(Type:=msoControlButton, Before:=1).Caption = ButDecCap(i)
            .Controls(ButDecCap(i)).OnAction = ButCmd(i)
            .Controls(ButDecCap(i)).FaceId = ButIcon(i)
        Next i
        Set MyBar = Nothing
    End With
End Sub

'---------------------------------------------------------
'Check if the Menu Exists
'---------------------------------------------------------
Private Function isExistMenu(menuName As String)
On Error GoTo Err
    CommandBars(menuName).Visible = True
    isExistMenu = True
    Exit Function
Err:
    isExistMenu = False
End Function

3. 创建Base标准模块

Sub sbSave()
    Dim sFirstSheetName As String
    Dim bFirstSheetFlg As Boolean
       
    bFirstSheetFlg = False
    Application.ScreenUpdating = True
    
    For Each sht In ActiveWorkbook.Worksheets
        If bFirstSheetFlg = False Then
            sFirstSheetName = sht.Name
            bFirstSheetFlg = True
        End If
        
        Sheets(sht.Name).Activate
        ActiveWindow.Zoom = 85
        ActiveSheet.Range("A1").Select
    Next
    Sheets(sFirstSheetName).Select
    ActiveWorkbook.Save
End Sub

Sub sbPic()
On Error GoTo Err
    Selection.ShapeRange.ScaleHeight 0.85, msoFalse, msoScaleFromTopLeft
    Exit Sub
Err:
    MsgBox "No pictures are selected."
End Sub

Sub sbZoom()
    Dim iSize

    iSize = Application.InputBox("from 10 to 400 value input")
    If iSize = False Then
        Exit Sub
    ElseIf iSize < 10 Or iSize > 400 Then
        MsgBox "from 10 to 400 value input"
        Exit Sub
    End If
    
    For Each sht In ActiveWorkbook.Worksheets
        Sheets(sht.Name).Select
        ActiveWindow.Zoom = iSize
    Next
End Sub

Sub SearchHyperLinks()
    Dim bRet As Boolean
    Dim sLink As String
    Dim bSearch As Boolean

    bSearch = False

    For Each sht In ActiveWorkbook.Worksheets
        If Sheets(sht.Name).Visible <> 0 Then
            Sheets(sht.Name).Select
            For R = 1 To ActiveSheet.UsedRange.Rows.Count
                For c = 1 To ActiveSheet.UsedRange.Columns.Count
                    sLink = F(Range(ActiveSheet.Cells(R, c).Address(0, 0)))
                    If sLink <> "" Then
                        ActiveSheet.Range(ActiveSheet.Cells(R, c).Address(0, 0)).Select
                        MsgBox "【" & ActiveSheet.Cells(R, c).Address(0, 0) & "】セルで下記の外部リンクがある：" & vbCrLf & sLink
                        bSearch = True
                        Exit Sub
                    End If
                Next c
            Next R
        End If
    Next
    
    If bSearch = False Then
        MsgBox "リンクが見つかりませんでした。"
    End If
End Sub
Function F(R As Range) As String
    On Error Resume Next
    a = R.Validation.Formula1
    If InStr(a, "xlsx") > 0 Or InStr(a, "xls") > 0 Then
        F = a
    Else
        F = ""
    End If
End Function

4. 效果