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