[vba vbs tool] 【超便利ツール自作】リンク付きで指定パス配下のサブフォルダー＆ファイルに対してループで ExcelへPrint

超便利ツール

前編と違って、cmdを使わず、一時ファイルも利用しない

特徴

・超簡単な使い方
・単純すぎる仕組み
　※Copyだけですぐ使える
　※隠しフォルダー＆隠しファイルを処理対象外としている

簡単な用例テスト

１．用例作成bat

C:\temp>
    mkdir test
    echo "." > a.txt
    echo "." > b.txt
    cd  test
    mkdir test2-1
    mkdir test2-2
    echo "." > a2.txt
    echo "." > b2.properties
    cd test2-2
    echo "." > a2-2.txt
    echo "." > b2-2.txt
    copy b2-2.txt b2-2-1.xlsx
    copy b2-2.txt b2-2-2.xlsx
↓
C:\temp>tree /f
フォルダー パスの一覧:  ボリューム Windows
ボリューム シリアル番号は A014-E3CA です
C:.
│  a.txt
│  b.txt
│
└─test
    │  a2.txt
    │  b2.properties
    │
    ├─test2-1
    └─test2-2
            a2-2.txt
            b2-2-1.xlsx
            b2-2-2.xlsx
            b2-2.txt

２．マクロ実行後
※ファイル対象の前に空白のままで処理しないも以下のように処理済み（tree /fに合わせ）
※コードに変更箇所★を参照

（ExcelからCopyしてきた）

※2020/01/22以下の改善を入れました。
ﾌｧｲﾙの親ﾌｫﾙﾀﾞを一個前のセルをクリックで直接に開けるようにするため、リンク付き（赤い枠線）

（ExcelからCopyしてきた）

コード

'*************************************************
' 0.図形化用変数定義
'*************************************************
Const Subfolder_Con = "│"
Const Subfolder_Mid = "├─"
Const Subfolder_End = "└─"
Const Folder_Open = "▲"
Private Sub CommandButton1_Click()
    Call GetFiles
End Sub
'*************************************************
' 1.GetFiles
'*************************************************
Sub GetFiles()
    Dim inputStr As String
    Dim selectHere As Object
    Set selectHere = Selection
On Error GoTo EXECEPTION
    inputStr = InputBox("指定の目標パス配下にすべてのものをリンク付きで出力します", "目標Path入れてからOKボタンを押下してください", Trimmer(Trim(GetTextFromClipboard())))
    inputStr = Trim(inputStr)
    If inputStr <> "" Then
        Dim dic
        Set dic = CreateObject("Scripting.Dictionary")
        Call ShowFolderList(inputStr, Selection.Row, Selection.Column, "", dic, True)
        Call DoneWithDic(dic)
        Set dic = Nothing
    End If
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    selectHere.Select
EXECEPTION:
    If Err.Number <> 0 Then
        MsgBox "GetFiles生成中エラー： " & Err.Description, vbExclamation, "実行終了"
    End If
    Set selectHere = Nothing
    Application.StatusBar = "■出力完了"
    Application.ScreenUpdating = True
End Sub
'*************************************************
' 2.ShowFolderList
'*************************************************
Sub ShowFolderList(folderspec, iRowNm, iColNm, mark_folder_bef, dic, Optional isFirst As Boolean = False)
On Error GoTo EXECEPTION
    If Mid(folderspec, Len(folderspec), 1) <> "\" Then
        folderspec = folderspec + "\"
    End If
    Dim fs, f, f1, fc, tmp, aFile, f_Files
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.getFolder(folderspec)
    Set fc = f.SubFolders
    Set f_Files = f.Files

    '#　今のフォルダーをプリント
    If mark_folder_bef <> "" Then
        Cells(iRowNm, iColNm - 1) = mark_folder_bef
    End If
    If mark_folder_bef = Subfolder_Mid Then
        Call dic.Add(iRowNm, iColNm - 1)
    End If

    Cells(iRowNm, iColNm).Select
    If isFirst Then
        Call setAddr(Cells(iRowNm, iColNm), folderspec, Trim(folderspec))
        Application.StatusBar = "■実行中…"
        Application.ScreenUpdating = False
    Else
        Call setAddr(Cells(iRowNm, iColNm), Replace(folderspec, f.ParentFolder, ""), Trim(folderspec))
    End If

    For Each aFile In f_Files
        DoEvents
        If aFile.Attributes <> Hidden Then
            iRowNm = iRowNm + 1
            '#　今のフォルダーにあるファイルｓをプリント
            Cells(iRowNm, iColNm + 1).Select
            Call setAddr(Cells(iRowNm, iColNm + 1), Replace(aFile.path, f.path & "\", ""), Trim(aFile.path))
            '#　親フォルダを一個前のセルをクリックで直接に開けるようにリンク付き
            Call setAddr(Cells(iRowNm, iColNm), Folder_Open, Trim(f.path))
            'Cells(iRowNm, iColNm).Font.Color = -1003520
        End If
    Next

    '# mark_folder_befを確定
    mark_folder_bef = Subfolder_Mid
    Dim cnt As Integer
    cnt = 1
    For Each f1 In fc
        '# is last one
        If cnt = fc.COUNT Then
            mark_folder_bef = Subfolder_End
            Call dic.Add(Subfolder_End & iRowNm + 1, iColNm) '★Add
        End If

        cnt = cnt + 1

        If f1.Attributes <> Hidden Then
            If isMatchedWithRegExp(folderspec, ".*\\$", True) Then
                tmp = folderspec & f1.Name
            Else
                tmp = folderspec & "\" & f1.Name
            End If

            '#　今のフォルダーにあるサブをプリント
            iRowNm = iRowNm + 1
            Call ShowFolderList(tmp, iRowNm, iColNm + 1, mark_folder_bef, dic)

        End If

EXECEPTION:
        If Err.Number <> 0 Then
            MsgBox Err.Description & vbCrLf & "maybe its not exist." & vbCrLf & "[" & folderspec & "]", vbExclamation
            If MsgBox("Yes -> go to next. No -> end.", vbYesNo) = vbNo Then
                GoTo ToEnd
            Else
                Err.Clear
            End If
        End If

    Next

ToEnd:
    Set fs = Nothing
End Sub
'*************************************************
' 3.DoneWithDic　最終整理　★Mod
'*************************************************
Sub DoneWithDic(dic)
    If dic Is Nothing Then
    Else
        Dim r, iRownm
        For Each vKey In dic.Keys
            Debug.Print vKey
            iRownm = Replace(vKey, Subfolder_End, "")
            If iRownm <> "" Then
            '1.Subfolder_Endに対する整理
            '2.Subfolder_Midに対する整理
                For r = CInt(iRownm) - 1 To 1 Step -1
                    If Cells(r, dic.Item(vKey)) = "" Or Cells(r, dic.Item(vKey)) = Folder_Open Then
                        If Cells(r, dic.Item(vKey)) = Folder_Open Then
                            Cells(r, dic.Item(vKey)) = Subfolder_Con
                            '見た目は悪いから、UnderLineを取り除く
                            Cells(r, dic.Item(vKey)).Font.Underline = xlUnderlineStyleNone
                        Else
                            Cells(r, dic.Item(vKey)) = Subfolder_Con
                        End If
                    Else
                        Exit For
                    End If
                Next r
            End If
        Next
    End If
End Sub
'*************************************************
' Trimmer
'*************************************************
Public Function Trimmer(str) As String
    'RegExpオブジェクトの作成
    Dim reg As Object
    Set reg = CreateObject("VBScript.RegExp")

    '正規表現の指定
    With reg
        .Pattern = vbCr & "|" & vbLf & "|" & vbCrLf & "|" & vbTab      'パターンを指定
        .IgnoreCase = False     '大文字と小文字を区別するか(False)、しないか(True)
        .Global = True          '文字列全体を検索するか(True)、しないか(False)
    End With

    Trimmer = reg.Replace(str, "") '指定した正規表現を第2引数の区切り文字に置換
End Function
'*************************************************
' setAddr
'*************************************************
Sub setAddr(rge As Range, value, link2Path)
    rge.ClearContents
    rge.ClearHyperlinks
    rge.ClearFormats
    rge.value = value
    If isFileFolderExist(link2Path) Then
        ActiveSheet.Hyperlinks.Add Anchor:=rge, Address:=Trim(link2Path)
    End If
End Sub
'*************************************************
' isFileFolderExist
'*************************************************
Function isFileFolderExist(filePath) As Boolean
    isFileFolderExist = False
    If Trim(filePath) <> "" And (Dir(filePath) <> "" Or Dir(filePath, vbDirectory) <> "") Then
        isFileFolderExist = True
    End If
End Function
'*************************************************
' This String is Matched ?
'*************************************************
Function isMatchedWithRegExp(ByVal theStr As String _
                            , ByVal pat As String _
                            , Optional ByVal ignoreCaseFlag As Boolean = True) As Boolean
    Set re = CreateObject("VBScript.RegExp")
    With re
        .Global = True                ' Search the whole character string.
        .IgnoreCase = ignoreCaseFlag  ' Ture : Lowwer Letter a = Upper Letter A
        .Pattern = pat
        If .test(theStr) Then
            isMatchedWithRegExp = True
            Set re = Nothing
            Exit Function
        End If
    End With
isMatchedWithRegExp = False
Set re = Nothing
End Function