MyVBA加载宏主要功能是设置为自动加载,作为打开其他宏文件的一个程序,做好后大概是这么一个东西:
制作过程:
- 创建加载宏文件
将所有Excel VBA相关文件都存放到一个目录下面,包括MyVBA加载宏,设置MyVBA加载宏为Excel加载项:
浏览找到文件确定即可,这样打开任何Excel都会自动打开这个文件。
- 编辑Ribbon界面:
创建一个下拉菜单,这个菜单能够将MyVBA加载宏同路径下面所有后缀为.xlsm和.xlam的文件都添加为子菜单,点击自动打开相应的宏文件,Ribbon菜单代码:
代码语言:javascript复制<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon>
<tabs>
<tab idMso="TabDeveloper">
<group id="GroupMyVBA" label="MyVBA">
<dynamicMenu id="dymOpenAddins" label="打开宏文件 " size="large" imageMso="FileSaveAsExcelXlsxMacro" getContent="dymOpenAddins_getContent"/>
</group>
</tab>
</tabs>
</ribbon>
</customUI>
这里使用的是动态dynamicMenu,通过回调函数dymOpenAddins_getContent查找同一文件夹下所有的宏文件,dymOpenAddins_getContent代码:
代码语言:javascript复制Sub dymOpenAddins_getContent(control As IRibbonControl, ByRef content)
Dim RetDirs() As String, RetFiles() As String
'查找遍历所有文件
If ScanDir(ThisWorkbook.Path & "", RetDirs, RetFiles) = -1 Then
Exit Sub
End If
Dim i As Long
Dim icount As Long
Dim fn As String
For i = 0 To UBound(RetFiles)
'过滤本身
If RetFiles(i) <> ThisWorkbook.FullName Then
'只显示有VBA的宏文件
If RetFiles(i) Like "*.xlam" Or RetFiles(i) Like "*.xlsm" Then
'过滤Excel的临时文件
If VBA.InStr(RetFiles(i), "~$") = 0 Then
'取出文件名称
fn = VBA.Mid$(RetFiles(i), VBA.InStrRev(RetFiles(i), "") 1)
RetFiles(icount) = VBA.Left$(fn, Len(fn) - 5)
'生成Ribbon的xml代码
RetFiles(icount) = " <button id=""" & RetFiles(icount) & """ label=""" & RetFiles(icount) & """ onAction=""rbOpenMacroFile"" imageMso=""FileSaveAsExcelXlsxMacro"" tag=""" & RetFiles(i) & """/>"
icount = icount 1
End If
End If
End If
Next
If icount Then
ReDim Preserve RetFiles(icount - 1) As String
'通过回调函数的参数返回xml代码
content = "<menu xmlns=""http://schemas.microsoft.com/office/2006/01/customui"">" & vbNewLine & VBA.Join(RetFiles, vbNewLine) & vbNewLine & "</menu>"
End If
End Sub
'打开文件,文件名在control的Tag属性里
Sub rbOpenMacroFile(control As IRibbonControl)
Workbooks.Open control.Tag, False
End Sub
ScanDir是一个比较常用的查找遍历函数,个人创建了一个VBAProject文件夹专门存储这一类文件,把它当作包来管理,MyVBA加载宏需要通过工具-引用来使用这个文件,函数代码:
代码语言:javascript复制Function ScanDir(str_dir As String, RetDirs() As String, RetFiles() As String) As Long
Dim fso As Object
Dim file As Object
Dim folder As Object, subDir As Object
Dim k As Long
On Error GoTo err_handle
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.Getfolder(str_dir)
k = 0
For Each subDir In folder.Subfolders
ReDim Preserve RetDirs(k) As String
RetDirs(k) = subDir.Path
k = k 1
Next
k = 0
For Each file In folder.Files
ReDim Preserve RetFiles(k) As String
RetFiles(k) = file.Path
k = k 1
Next file
ScanDir = k
Set file = Nothing
Set folder = Nothing
Set subDir = Nothing
Set fso = Nothing
Exit Function
err_handle:
ScanDir = -1
End Function
到此MyVBA加载宏创建完成,后续将不断添加具有功能的加载宏,作为exe可执行文件那样管理。