再帰的にフォルダを作成

createfolder.vb

'再帰的にフォルダを作成
'複数階層で途中のパスのフォルダが存在しなくても作成できます
Public Sub CreateFolder(FolderFullPath As String)

  ' パスを\区切りで分ける
  Dim FolderPaths As Variant ' フォルダ名リスト
  FolderPaths = Split(FolderFullPath, "\")

  Dim FSO As Scripting.FileSystemObject
  Set FSO = New Scripting.FileSystemObject

  ' フォルダを作成する
  Dim FolderPath As Variant ' フォルダ名リストから取り出したフォルダ名
  Dim CurPath As String
  On Error Goto catch
  For Each FolderPath In FolderPaths
    ' 上位層からのフォルダパスを作る
    CurPath = CurPath & Path & "\"
    If Not FSO.FolderExists(CurPath) Then FSO.CreateFolder (CurPath)
  Next
  Exit Sub

catch:
  MsgBox Err.Source & vbCrLf & Err.Description, vbCritical + vbOKOnly
  Error (Err.Number)
End Sub