サブフォルダまで一括作成

フォルダを作成する際、サブフォルダまで一度に作成したい場合がありますが、MkDirやCreateFolderでは、作成できずエラーとなります。順次作成していく方法で、一括作成を行います。

【呼び出し例】

Sub CreateSubFolder_sample1()
    ' サブフォルダまで一括作成
    CreateSubFolder "C:\ExcelVBA\Report\Test"
End Sub

Sub CreateSubFolder_sample2()
    ' サブフォルダまで一括作成（ファイル名の場合）
    CreateSubFolder "C:\ExcelVBA\Report\Test\Info.xlsx", False
End Sub

【関数化】

' ------------------------------------------------------------
' 説明：フォルダの作成(サブフォルダまで一括作成)
' 引数：1:確認するファイルもしくはフォルダ名
'       2:ファイルまで指定する場合は、folderをFalseに設定する
' 戻値：フォルダが作成できた場合:True
'       フォルダが作成できなかった場合:False
'
'       引数2について。フォイル名を含んだファイルパスを指定する場合に False を指定。
'       例："C:\ExcelVBA\Report\Test\Info.xlsx"
'       "C:\ExcelVBA\Report\Test" までのフォルダを作成する。
' ------------------------------------------------------------
Function CreateSubFolder(filename As String, Optional folder As Boolean = True) As Boolean
	Dim spastr As Variant
	Dim idx As Long
	Dim dir_str As String
	Dim adjust As Integer

	Dim fso As Object
	Set fso = CreateObject("Scripting.FileSystemObject")

	On Error GoTo ErrProc

	' フォルダ以外の場合（ファイルの場合）、作成フォルダに含まないように調整
	' この処理が無いと、ファイル名のフォルダが作成されてしまう
	If folder = False Then
		adjust = 1
	End If

	' カンマ区切り
	spastr = Split(filename, "\")

	For idx = LBound(spastr) To (UBound(spastr) - adjust)
		' フォルダを順次作成
		If idx = 0 Then
			dir_str = spastr(idx)	' ドライブの処理
		Else
			dir_str = dir_str & "\" & spastr(idx)
		End If

		' 既にフォルダがあるか確認
		If fso.FolderExists(dir_str) = False Then
			' フォルダが無い場合、作成する
			If idx = 0 Then
				' ドライブば作成できないのでエラーとする
				CreateSubFolder = False
				Exit Function
			End If
			' フォルダの作成
			fso.CreateFolder dir_str
		End If
	Next idx

	CreateSubFolder = True
	Exit Function

' エラー発生時の処理
ErrProc:
	CreateSubFolder = False
	Debug.Print "エラー番号:" & Err.Number & ", エラーの種類:" & Err.Description
End Function