概要
フォルダを再帰的に作成するサブルーチンです。
- mkdirだけでは再帰的にフォルダが作れないため、下層からフォルダの存在をチェックして、再帰的に作成する処理になっています。
- フォルダが既にある場合、1を返します。（フォルダありを区別しないなら、正常の判定は「<=1」としてもらうか、ありでも0を返すようにすればいいかと思います）
- mkdirでエラーが発生した場合に On Error GoTo CFErr でキャッチしています。
コード
Function CreateFolderRecurs(strFolder As String) As Long
'--------------------------------------
'フォルダ作成
' パスに含まれる途中のフォルダがない場合、再帰的に作成
'
'[戻り値] 0:正常終了
' 1:フォルダあり
' 9:異常終了
'--------------------------------------
On Error GoTo CFErr:
Dim FSO As Object
Dim tmpFolder()
Dim parFol As String
Dim s As Long
Dim i As Long
Set FSO = CreateObject("Scripting.FilesystemObject")
'フォルダ存在チェック
If FSO.FolderExists(strFolder) = True Then
CreateFolderRecurs = 1
Else
s = 1
ReDim tmpFolder(s)
tmpFolder(s) = strFolder 'フォルダを配列に格納
'1つずつ上の階層をたどって、作成すべきフォルダ（フォルダが存在しない）を取得
Do
'1つ上の階層のフォルダを取得
'（後ろから検索してパスに「\」が含まれていればそこまでのパスを取得）
parFol = Left(tmpFolder(s), InStrRev(tmpFolder(s), "\") - 1)
'1つ上の階層のフォルダが存在するかチェック
If FSO.FolderExists(parFol) = False Then
s = s + 1
ReDim Preserve tmpFolder(s)
tmpFolder(s) = parFol '1つ上のフォルダを配列に格納
Else
'フォルダが存在したらチェック
Exit Do
End If
Loop
'上の階層から再帰的にフォルダを作成
For i = s To 1 Step -1
MkDir tmpFolder(i)
Next i
CreateFolderRecurs = 0
End If
Erase tmpFolder
Set FSO = Nothing
Exit Function
'異常終了
CFErr:
Erase tmpFolder
Set FSO = Nothing
CreateFolderRecurs = 9
End Function
