保存先フォルダを作成してブックを保存する(複数階層のフォルダ)|Excel VBA |
ブックに名前を付けて保存するには、SaveAsメソッドを使います。
次のコードは、アクティブブックをC:\WorkフォルダにBook1という名前で保存します。
Sub Sample1()
ActiveWorkbook.SaveAs "C:\Work\Book1.xls"
End Sub
このとき、C:\Workフォルダが存在しないとエラーになります。
ブックに名前を付けて保存するときは、保存先のフォルダが存在するかどうかを事前に確認した方が安全です。
フォルダが存在するかどうかはDir関数でも調べることもできますが、ここではFileSystemObjectを使って確認してみましょう。
Sub Sample2()
With CreateObject("Scripting.FileSystemObject")
If .FolderExists("C:\Work") Then
MsgBox "存在します"
Else
MsgBox "存在しません"
End If
End With
End Sub
存在した場合は安心してSaveAsメソッドを実行できますが、もし存在しなかったら、フォルダを作成しなければなりません。
フォルダの作成には、FileSystemObjectのCreateFolderメソッドを使います。
Sub Sample3()
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists("C:\Work") Then .CreateFolder "C:\Work"
End With
ActiveWorkbook.SaveAs "C:\Work\Book1.xls"
End Sub
このように、保存先フォルダの階層が浅い場合は、対応も簡単です。
では、保存先フォルダがC:\Work\2012\Quater1だった場合はどうでしょう。
先のように、FileSystemObjectを使えば、フォルダの存在は確認できます。
Sub Sample4()
With CreateObject("Scripting.FileSystemObject")
If .FolderExists("C:\Work\2012\Quater1") Then
MsgBox "存在します"
Else
MsgBox "存在しません"
End If
End With
End Sub
存在しない場合、C:\Work\2012\Quater1フォルダが存在しないのは明らかですが、もうひとつ上位のC:\Work\2012フォルダも存在しないのか、あるいは、そもそもC:\Workフォルダが存在しないのかはわかりません。
もし、C:\Work\2012フォルダが存在しない場合は、CreateFolderメソッドでC:\Work\2012\Quater1フォルダを作成しようとすると失敗します。存在しないC:\Work\2012フォルダに、新しいフォルダを作ることはできないからです。
このように深い階層のフォルダを作成するには、パスのどこまで存在するかを調べなければなりません。
フォルダの階層はさまざまですから、汎用的な対応をしたいのなら、再帰的に上位フォルダの存在を確認しなければなりません。これは、少々やっかいです。
そんなときはWindows APIの出番です。
SHCreateDirectoryExを使うと、深い階層であっても指定したフォルダを作成できます。
Declare Function SHCreateDirectoryEx Lib "shell32" Alias _
"SHCreateDirectoryExA" ( _
ByVal hwnd As Long, _
ByVal pszPath As String, _
ByVal psa As Long) As Long
Sub Sample5()
Dim TargetPath As String, rc As Long
TargetPath = "C:\Work\2012\Quater1"
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(TargetPath) Then
rc = SHCreateDirectoryEx(0&, TargetPath, 0&)
End If
End With
If rc <> 0 Then
MsgBox "フォルダの作成に失敗しました"
Else
ActiveWorkbook.SaveAs TargetPath & "\Book1.xls"
End If
End Sub
SHCreateDirectoryExは、フォルダの作成に成功すると0を返します。
作成に失敗したときは、エラーの状況に応じて戻り値を返します。
たとえば、作成しようとしている C:\Work\2012\Quater1 が既に存在していると、エラーコード 183(ERROR_ALREADY_EXISTS)を返し、指定したフォルダパスが空の文字列だった場合は、エラーコード 161(ERROR_BAD_PATHNAME)を返します。
また、"O:\Work" のように存在しないドライブのフォルダを指定すると「指定されたパスが見つかりません」とメッセージを表示し、エラーコード 1223(ERROR_CANCELLED)を返します。
複数階層のフォルダを作成するAPI関数には、MakeSureDirectoryPathExistsもあります。
MakeSureDirectoryPathExistsの戻り値はBoolean型で、成功するとTure、失敗するとFalseを返します。作成しようとしている C:\Work\2012\Quater1 が既に存在していても、Trueを返します。
ただし、フォルダパスの末尾に「\」が必要な点に注意してください。
Private Declare Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub Sample6()
Dim TargetPath As String
TargetPath = "C:\Work\2012\Quater1\"
If MakeSureDirectoryPathExists(TargetPath) Then
ActiveWorkbook.SaveAs TargetPath & "Book1.xls"
Else
MsgBox "フォルダの作成に失敗しました"
End If
End Sub