常用功能加载宏——工作簿目录

      <button id="rbbtnWorkbookDir" label="工作簿目录&#13;" onAction="rbbtnWorkbookDir" imageMso="FileSaveAsExcel97_2003" />

Sub rbbtnWorkbookDir(control As IRibbonControl)
    Call MShtWk.WorkbookDir
End Sub

Sub WorkbookDir()
    Dim i As Long
    Dim result() As Variant
    Dim rngout As Range
    
    On Error Resume Next
    Set rngout = Application.InputBox("请选择输出单元格", Default:=ActiveCell.Address, Type:=8)
    On Error GoTo 0
    
    If rngout Is Nothing Then
        Exit Sub
    End If
    '这里保证rngout只是单个的单元格，因为后面设置超链接的时候只要设置单个单元格
    Set rngout = rngout.Range("A1")
    
    Dim strDir As String
    Dim RetDirs() As String, RetFiles() As String
    '选择要查找的文件夹
    strDir = GetFolderPath()
    If VBA.Len(strDir) = 0 Then Exit Sub
    '遍历获取文件
    If ScanDir(strDir, RetDirs, RetFiles) = -1 Then Exit Sub
    
    '定义结果数组
    ReDim result(UBound(RetFiles) + 1, 1) '+1是因为有1个标题，可能会比RetFiles多一个

    result(0, 0) = "序号"
    result(0, 1) = "工作簿名称"
    
    Dim flag As Boolean
    Dim pRow As Long
    pRow = 0
    For i = 0 To UBound(RetFiles)
        flag = False
        '避免用Or将多个判断连接在一起，因为那样会每一个判断都执行
        If VBA.InStr(RetFiles(i), ".xls") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xls") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xlsx") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xlsm") Then
            flag = True
        End If
        
        If flag Then
            'pRow记录的是有多少个满足条件的
            pRow = pRow + 1
            result(pRow, 0) = pRow
            result(pRow, 1) = RetFiles(i)
            
             '添加超链接
             rngout.Offset(pRow, 1).Hyperlinks.Add rngout.Offset(pRow, 1), RetFiles(i)
        End If
    Next
    
    If pRow Then rngout.Resize(pRow + 1, 2).Value = result
    
    Set rngout = Nothing
    Erase result
End Sub

Function GetFolderPath() As String
    Dim myFolder As Object
    Set myFolder = CreateObject("Shell.Application").Browseforfolder(0, "选择文件夹", 0)
    If Not myFolder Is Nothing Then
'        GetFolderPath = myFolder.Items.item.path
        GetFolderPath = myFolder.Self.Path
        If Right(GetFolderPath, 1) <> "\" Then GetFolderPath = GetFolderPath & "\"
    Else
        GetFolderPath = ""
    End If
    Set myFolder = Nothing
End Function