VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る

VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る

以前はマクロ有効ブック(xlsm)で作っていたのですが、拡張子を変えて堂々と効率化すると、いろいろと面倒なことになるので、最近はアドイン化して自分だけしれっと使っています。
さて、本題に入りましょう。

やりたいこと

VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る
リボンに自作のタブを追加し、フォルダ・ファイルの一覧を取得するマクロを使えるようにします。

タブに作った入力欄にパスを入れボタンを押せば、取得したフォルダ・ファイルの一覧は、階層を付けてアクティブなシートに書き込みます。

VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る

Excelアドインのブックを作って下準備

まずはExcelアドインのブック(xlam)を作ります。

空のExcelブックを開いてExcelアドイン(xlam)で保存

アドイン名は好きな名前で作ってください。

VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る

拡張子をzipに変更する

拡張子を「zip」に変更します。
xlamはアドインに必要な一式が圧縮されたものなので、拡張子をzipに変更すれば、開けるようになります。

zipの中身はこうなります。

〇〇.zip
│  [Content_Types].xml
│
├─docProps
│      app.xml
│      core.xml
│
├─xl
│  │  sharedStrings.xml
│  │  styles.xml
│  │  vbaProject.bin
│  │  workbook.xml
│  │
│  ├─theme
│  │      theme1.xml
│  │
│  ├─worksheets
│  │      sheet1.xml
│  │
│  └─_rels
│          workbook.xml.rels
│
└─_rels
        .rels

自作タブを表示させるXMLを作る

VBA|フォルダとファイルの一覧をツリー表示にしてリンクを貼る

リボンに表示させるタブは、xmlで記載します。
zipの中のファイルは直接編集できないので、どこか別のところで作ってから、zip内にコピーします。

_rels\.relsの修正

CustomRibbon.zip\_rels\.relsの、「</Relationships>」の前に、以下を書き足します。
Idはこのファイルの中でユニークになれば何でも良いです。

<Relationship Id="customUI" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/>

customUI\customUI.xmlの作成

customUIフォルダを作り、customUI.xmlを生成します。

<?xml version="1.0" encoding="utf-8" ?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
    <ribbon>
      <tabs>
        <tab id="CustomTab" label="カスタム">
          <group id="FolderTreeGroup" label="フォルダツリー">
            <editBox 
              id="FolderTree_EditBox1" maxLength="255" label="フォルダパス" onChange="FolderTree.OnChangeFolderTreeEditBox1" sizeString="WWWWWWWWWWWWWWWW" />
            <button 
              id="FolderTreeButton" imageMso="FileLinksToFiles" label="ファイル一覧取得" size="normal" 
              onAction="FolderTree.ファイル一覧取得" 
              screentip="指定されたフォルダのファイル一覧を取得します"
            />
          </group >
        </tab>
      </tabs>
   </ribbon>
</customUI>

拡張子をxlamに戻す

ここまでできたら、拡張子をxlamに戻します。

VBA

VBAのコードです。

参照設定

ツール > 参照設定 > Microsoft Scripting Runtime

コード

標準モジュールで、モジュール名は「FolderTree」にします。

customUI\customUI.xmlのonChangeに設定した名前と合わせます。

Option Explicit

Private TopPath As String    ' フォルダツリーを取得する対象フォルダのパス
Private sh As Worksheet      ' ワークシートオブジェクト

'---------------------------------------------------------------------------------------------------
'【処 理 名】リボン FolderTreeGroupのFolderTree_EditBox1変更イベント時
'【処理概要】リボン FolderTreeGroupのFolderTree_EditBox1変更イベント時に、値を取得する。
'【引    数】control As IRibbonControl
'            text As String
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Sub OnChangeFolderTreeEditBox1(control As IRibbonControl, text As String)
    TopPath = text
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ファイル一覧生成
'【処理概要】フォルダ・ファイルの一覧を取得し、ツリー表示およびハイパーリンクを挿入する。
'【引    数】control As IRibbonControl
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub ファイル一覧取得(control As IRibbonControl)
    Dim rowIndex As Long: rowIndex = 1       '書き込み行インデックス
    Dim columnIndex As Long: columnIndex = 1 '書き込み列インデックス
    
    ' 処理を続行するか確認する
    If vbNo = MsgBox("アクティブシートは上書きされます。処理を続けますか?", vbYesNo + vbQuestion) Then
        Exit Sub
    End If
    
    ' 指定されたディレクトリが不正な場合は処理終了
    If Not validation() Then
        Exit Sub
    End If
    
    ' アクティブなワークシートを取得する
    Set sh = ActiveWorkbook.ActiveSheet
    
    ' フォルダツリー取得処理を呼び出す
    Call GetFolderTree(TopPath, rowIndex, columnIndex)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】フォルダツリー取得
'【処理概要】フォルダツリーを取得しシートへの書き込みとハイパーリンクの挿入をする
'【引    数】ByVal sTopPath As String     処理対象フォルダパス
'          ByRef rowIndex As Long       書き込み行
'          ByVal columnIndex As Long    書き込み列
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub GetFolderTree(ByVal sTopPath As String, ByRef rowIndex As Long, 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 hypLink = sh.Hyperlinks.Add( _
        Anchor:=sh.Cells(rowIndex, columnIndex), _
        Address:=sTopPath, _
        TextToDisplay:=oFso.GetFolder(sTopPath).Name)

    ' フォルダオブジェクト取得
    Set oTopDir = oFso.GetFolder(sTopPath)
    rowIndex = rowIndex + 1
    For Each oDir In oTopDir.SubFolders
        Call GetFolderTree(oDir.Path, rowIndex, columnIndex + 1)
    Next oDir
    
    'フォルダ配下のすべてのファイルを一覧化
    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 oFile
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】フォルダツリーを取得する対象フォルダのパス設定チェック
'【処理概要】リボン FolderTreeGroupのFolderTree_EditBox1に設定されたフォルダパスの正当性をチェックする
'【引    数】なし
'【返 却 値】True…適正/False…不正
'---------------------------------------------------------------------------------------------------
Private Function validation() As Boolean
    validation = False
    
    ' フォルダツリーを取得する対象フォルダのパスが設定されていない
    If TopPath = "" Then
        MsgBox "フォルダツリー取得対象フォルダのパスを入力してください"
        Exit Function
    End If
    
    ' ディレクトリであるか
    If Dir(TopPath, vbDirectory) = "" Then
        MsgBox "フォルダツリー取得対象にフォルダが指定されていません"
        Exit Function
    End If
    
    validation = True
End Function

 

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

CAPTCHA