はじめに
Windowsでは、ファイルパスが長すぎると(260文字以上？)、ファイル操作ができなくなる。
VBAでも同様で、ファイルパスが長すぎると、ファイル操作ができない。
そのため、ファイルパスをショートパスに変更し、扱えるようにしたい。
マクロ作成の経緯
File System Objectを使い、サブフォルダを含むフォルダ内のファイルを一括取得していた。
すると、フォルダ階層が深く、ファイルパスが長くなり、取得できないファイルがあった。
この長すぎるファイルパスにも対応する方法を模索した。
作成したマクロの概要
文字制限にひっかからないフォルダをショートパスに変換する方法を参考に作成した。
存在するフォルダまでフォルダ階層をさかのぼり、そのパスをショートパスに変換する。
変換したショートパスとその後ろ側のパスを繋げることで、扱えるパスに変換する。
これらの動作を実行する、Functionプロシージャを作成した。
渡したパスが存在しない場合、Functionプロシージャは空欄「””」を返す仕様とした。
動作手順
- 存在するフォルダになるまで、パスの最終要素を順番に切り取る
- 切り取ったパスの最終要素は後ろ側のパスとして、繋げて記録しておく
- 存在するフォルダを見つけたら、そのフォルダをショートパスに変換する
（存在するフォルダを見つけられなかった場合、そのパスは存在しない） - 変換したフォルダのショートパスと、記録しておいた後ろ側のパスを繋げる
（後ろ側のパスが間違っている可能性があるので、完成したパスが存在するか確認する）
完成したマクロ
ショートパスに変換するFunctionプロシージャ
ChangeShortPath
'存在しないパスを渡した場合、空欄""を返す
Public Function ChangeShortPath(FullPath As String) As String
Dim Fso As Object
Dim TargetPath As String
Dim LastPath As String
Set Fso = CreateObject("Scripting.FileSystemObject")
TargetPath = FullPath
'存在するフォルダまで遡って、存在するフォルダをショートパスに変換する
Do Until Fso.FolderExists(TargetPath)
'GetFileNameは、ファイルに限らず、最終要素を取り出す
LastPath = "\" & Fso.GetFileName(TargetPath) & LastPath
'GetParentFolderNameは最終要素のひとつ前の要素を取り出す
TargetPath = Fso.GetParentFolderName(TargetPath)
'TargetPathが空欄 ＝ フォルダを最初まで遡っても存在しなかった ⇒ 存在しないパスであるため、終了
If TargetPath = "" Then Exit Do
Loop
TargetPath = Fso.GetFolder(TargetPath).ShortPath & LastPath
If Fso.FileExists(TargetPath) = False _
And Fso.FolderExists(TargetPath) = False Then TargetPath = ""
ChangeShortPath = TargetPath
Set Fso = Nothing
End Function
File System Objectの各メソッドの注釈
- File System Objectの「FolderExists」は、長すぎて扱えないパスの場合、Falseを返す
また、ファイルパスの場合、フォルダではないので、Falseを返す - File System Objectの「GetFileName」は、ファイル名に限らず、最終要素を取り出す
（ファイルパスではファイル名を、フォルダパスでは最終要素のフォルダを返す） - File System Objectの「GetParentFolderName」は最終要素のひとつ前の要素を取り出す
（フォルダパスでは親フォルダを、ファイルパスではファイルのあるフォルダを返す） - 上記の特徴を活かし、ファイルパス・フォルダパスの両方に対応したマクロとなっている
使用例
使用例として、サブフォルダを含むフォルダ内のファイル一覧を作成するマクロを記載。
出力シートイメージ
作成コード
使用例
Public Sub SearchSubFolders_File()
Dim Fso As Object
Dim FolderPath As String
Dim ChangePath As String
Dim StartRow As Long
Dim FolderStartColumn As Long
Dim TargetSheet As Worksheet
Set Fso = CreateObject("Scripting.FileSystemObject")
Set TargetSheet = ActiveSheet
With TargetSheet
.Range("A1").CurrentRegion.Offset(2).ClearContents
FolderPath = .Range("B1").Value
StartRow = .Range("A3").Row
FolderStartColumn = .Range("C3").Column
End With
ChangePath = ChangeShortPath(FolderPath)
If ChangePath <> "" Then
Call FileSearch(TargetSheet, FolderPath, ChangePath, StartRow, FolderStartColumn, FolderStartColumn, Fso)
Else
MsgBox FolderPath & "は存在しません。"
End If
Set Fso = Nothing
End Sub
Sub FileSearch(TargetSheet As Worksheet, FolderPath As String, ChangePath As String, outRow As Long, outColumn As Long, baseColumn As Long, Fso As Object)
Dim i As Long
Dim TargetFolder As Object
Dim TargetSubfolder As Object
Dim TargetFile As Object
Dim CurrentFolderPath As String
Set TargetFolder = Fso.GetFolder(ChangePath)
For Each TargetSubfolder In TargetFolder.SubFolders
'フォルダを基準となる列から横にずらして出力することで、サブフォルダの階層を表現
Call FileSearch(TargetSheet, FolderPath & "\" & TargetSubfolder.Name, ChangePath & "\" & TargetSubfolder.Name, outRow, outColumn + 1, baseColumn, Fso) '再帰呼出
Next TargetSubfolder
With TargetSheet
For Each TargetFile In TargetFolder.Files
CurrentFolderPath = FolderPath
'一番下の階層のフォルダから出力して、サブフォルダの階層を表現
For i = outColumn To baseColumn Step -1
.Cells(outRow, i).Value = Fso.GetBaseName(CurrentFolderPath)
CurrentFolderPath = Fso.GetParentFolderName(CurrentFolderPath)
Next i
.Cells(outRow, 1) = FolderPath & "\" & TargetFile.Name
.Cells(outRow, 2) = TargetFile.Name
outRow = outRow + 1
End With
Set TargetFile = Nothing
Set TargetSubfolder = Nothing
Set TargetFolder = Nothing
End Sub
サンプルファイル保存先：