MyVBA加载宏——添加自定义菜单04——功能实现

Private Function FsoReadTxt(file_name As String) As String
    Dim fso As Object, sr As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sr = fso.OpenTextFile(file_name, 1) 'ForReading=1

    FsoReadTxt = sr.ReadAll()
    
    Set fso = Nothing
    Set sr = Nothing
End Function

Private Function InsertCode(str_code As String)
    Dim i_row As Long
    '获取鼠标定位所在的行号
    Application.VBE.ActiveCodePane.GetSelection i_row, 0, 0, 0
    '从获取的行号开始处插入代码
    Application.VBE.SelectedVBComponent.CodeModule.InsertLines i_row, str_code
End Function

Public WithEvents cmdbe As VBIDE.CommandBarEvents

Private Sub cmdbe_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
    On Error GoTo ErrHandle
    
    Dim str_code As String
    Const VBE_DIR As String = "\vbaCodes\"
    
    str_code = FsoReadTxt(ThisWorkbook.Path & VBE_DIR & CommandBarControl.Caption & ".txt")
    InsertCode str_code
    Exit Sub
    
ErrHandle:
    MsgBox Err.Description
End Sub

'记录所有需要执行单击事件的菜单按钮
Private cbars As Collection

Private Type CommandBarInfo
    mso As Long     '菜单类型
    Caption As String  '名称
    FaceId As Long  '图标
    Flag As Long    '记录是否是弹出式菜单
End Type

Sub AddCommanBar()
    If Not CheckVbproject Then
        Exit Sub
    End If
    
    Set cbars = New Collection
    add_bar
End Sub

Function add_bar() As Long
    Dim bar_btn As CommandBarControl
    Dim bar_info As CommandBarInfo
    Dim num_file As Integer
    Dim tmp_bar As CommandBarPopup
    Dim my_bar As CommandBarPopup
    Dim cbar As CCommandBar
    
    Const sBAR_NAME As String = "插入代码(&C)"
    Const VBACodes As String = "\vbaCodes\CommandBarDir.txt"
        
    On Error Resume Next
    Application.VBE.CommandBars(1).Controls(sBAR_NAME).Delete
    On Error GoTo 0
    
    '添加菜单
    Set my_bar = Application.VBE.CommandBars(1).Controls.Add(msoControlPopup)
    my_bar.Caption = sBAR_NAME
    Set tmp_bar = my_bar
    
    '打开目录
    num_file = VBA.FreeFile
    Open ThisWorkbook.Path & VBACodes For Input As #num_file
     '跳过标题行
    Line Input #num_file, bar_info.Caption
    Do Until VBA.EOF(num_file)
        Input #num_file, bar_info.mso, bar_info.Caption, bar_info.FaceId, bar_info.Flag
        If bar_info.Caption <> "" Then
            If bar_info.mso = msoControlPopup Then
                '弹出式菜单
                Set tmp_bar = my_bar.Controls.Add(msoControlPopup)
                tmp_bar.Caption = bar_info.Caption
            Else
                Set bar_btn = tmp_bar.Controls.Add(bar_info.mso)
                bar_btn.Caption = bar_info.Caption
                bar_btn.FaceId = bar_info.FaceId
                bar_btn.BeginGroup = True
                
                Set cbar = New CCommandBar
                Set cbar.cmdbe = Application.VBE.Events.CommandBarEvents(bar_btn)
                '添加到集合中
                cbars.Add cbar
                
                'flag=1 表示1个popup的结束
                If bar_info.Flag = 1 Then Set tmp_bar = my_bar
            End If

        End If
    Loop
    
    Close #num_file

    Set bar_btn = Nothing
End Function

Function CheckVbproject() As Boolean
    Dim obj As Object
    
    On Error Resume Next
    Set obj = Application.VBE.ActiveVBProject
    If Err.Number <> 0 Then
        MsgBox "请勾选 信任对VBA工程对象模型的访问"
        CheckVbproject = False
    Else
        CheckVbproject = True
    End If
End Function

Private Sub Workbook_Open()
    Call AddCommanBar
End Sub