【VBA】フォルダとファイルをツリー表示にしてリンクも貼る

Excelでフォルダとファイルをツリー表示

指定したフォルダとファイルをツリー表示にしてExcelのワークシートに書き込み、リンクも貼ります。

ソースコード

Option Explicit

Private sh As Worksheet
Private rowIndex As Long

Private Const START_ROW As Integer = 4
Private Const START_COL As Integer = 2
Private Const TOOL_SH As String = "フォルダツリー"
Private Const TOP_PATH_ADDRESS As String = "D2"

'---------------------------------------------------------------------------------------------------
'【処 理 名】フォルダツリー
'【処理概要】フォルダツリーを取得し、リンクを生成する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub フォルダツリー取得()
    Dim path As String         '先頭フォルダパス
    Dim columnIndex As Long    'カラムインデックス
    
    ' ワークシートオブジェクト取得
    Set sh = ThisWorkbook.Worksheets(TOOL_SH)
    '先頭フォルダパス取得
    path = sh.Range(TOP_PATH_ADDRESS).Value
    
    If Not validation(path) Then
        Exit Sub
    End If
    
    rowIndex = START_ROW
    columnIndex = START_COL
    
    Call getFolderStructure(path, columnIndex)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ファイル一覧出力
'【処理概要】フォルダ・ファイル名を出力する
'【引    数】ByVal sTopPath As String     フォルダパス
'          ByVal columnIndex As Long    カラムインデックス
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getFolderStructure(ByVal sTopPath As String, ByVal columnIndex As Long)
    ' ツール > 参照設定 > Microsoft Scripting Runtime
    Dim oFso As New FileSystemObject    'ファイルシステムオブジェクト
    Dim oTopDir As Folder               'フォルダオブジェクト
    Dim oDir As Folder                  'フォルダオブジェクト
    Dim oFile As File                   'ファイルオブジェクト
    Dim hypLink As Hyperlink            'ハイパーリンク
    
    ' フォルダオブジェクト取得
    Set oTopDir = oFso.GetFolder(sTopPath)

    'ハイパーリンク生成
    Set hypLink = sh.Hyperlinks.Add(Anchor:=sh.Cells(rowIndex, columnIndex), _
                                            Address:=sTopPath, _
                                            TextToDisplay:=oFso.GetFolder(sTopPath).Name)
    
    rowIndex = rowIndex + 1
    
    For Each oDir In oTopDir.SubFolders
        '再帰
        Call getFolderStructure(oDir.path, columnIndex + 1)
    Next
    
    'ディレクトリ直下のすべてのファイル
    For Each oFile In oFso.GetFolder(sTopPath).Files
        'ファイルごとの処理
        Set hypLink = sh.Hyperlinks.Add(Anchor:=sh.Cells(rowIndex, columnIndex + 1), _
                                            Address:=oFile.path, _
                                            TextToDisplay:=oFso.GetFileName(oFile.path))
        rowIndex = rowIndex + 1
    Next
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】入力チェック
'【処理概要】入力チェックを行う
'【引    数】ByVal path As String パス
'【返 却 値】True     エラーなし
'          False    エラーあり
'---------------------------------------------------------------------------------------------------
Private Function validation(ByVal path As String) As Boolean
    If path = "" Then
        MsgBox "先頭フォルダのパスを入力してください"
        GoTo LBL_ERROR
    End If
    
    If Dir(path, vbDirectory) = "" Then
        MsgBox "先頭"
        GoTo LBL_ERROR
    End If

    validation = True
    Exit Function
    
LBL_ERROR:
    validation = False
    Exit Function
End Function

2020/12/26：フォルダ名に「.」(ドット)が含まれていると、フォルダ名のドット以降が出力されないとご指摘いただいて、修正しました。
その代わり、先頭がドットで後に数字が続く場合には対応していません。