フォルダを作成する (理ろぐ)

VBAで標準で用意されているステートメントでは、作成したいフォルダより上の階層のフォルダが存在しないと作成できません。
つまり、作成したい構成の上位から順番に作っていかないといけないわけです。

で、面倒なので関数を作って見ました。

'///////////////////////////////////////////////////////////
'　ディレクトリの存在チェック
' 返り値： true : 既存
' false : エラーorなし
'///////////////////////////////////////////////////////////
Function DoesDirExist(path As String) As Boolean

On Error GoTo DoesdirExist_Err
If (GetAttr(path) And vbDirectory) = vbDirectory Then

DoesDirExist = True

Else

DoesDirExist = False

End If

DoesdirExist_End:

Exit Function

DoesdirExist_Err:

DoesDirExist = False
Resume DoesdirExist_End

End Function

'///////////////////////////////////////////////////////////
'　ディレクトリの作成
' 返り値：ＯＫのとき：作成できたフォルダを返す
' ＮＧの時：長さ０の文字列
'///////////////////////////////////////////////////////////
Function MakeDirectory(path)

On Error GoTo MakeDirectory_Err

'最後に\が無い場合の対処
pos = InStrRev(path, "\")
If Len(path) > pos Then

path = path & "\"

End If

'ドライブが指定されているか調査
pos = InStr(1, path, ":")
If pos > 0 Then

pos = pos + 1

End If
temp_path = Left(path, pos)
'最初の\へ移動
pos = InStr(pos + 1, path, "\")
Do While (pos > 0)

'見つからないディレクトリが見つかり次第作成
temp_path = Left(path, pos)
If DoesDirExist(CStr(temp_path)) = False Then

'見つからないので作成する
MkDir (temp_path)

End If
'次の\の位置を取得
pos = InStr(pos + 1, path, "\")

Loop

MakeDirectory = path

MakeDirectory_End:

Exit Function

MakeDirectory_Err:

MakeDirectory = ""
Resume MakeDirectory_End

End Function

理ろぐ

フォルダを作成する

検索

サイドフィード