【VBA】FolderUtil

★プログラミング ・VBA-Util 
Option Explicit

'v1
'****************************************************
'フォルダ操作処理
'----------------------------------------------------
'FolderUtil
'****************************************************
'MakeFolder             -フォルダを作成
'DeleteFolder           -フォルダを削除
'CopyFolder             -フォルダをコピー
'MoveFolder             -フォルダを移動
'ChangeFolderName       -フォルダ名を変更
'GetFolderList          -フォルダ名の一覧を取得
'ExistsFolder           -フォルダの存在確認
'****************************************************

'----------------------------------------------------
'■フォルダを作成
'----------------------------------------------------
'備考:階層フォルダに対応
'----------------------------------------------------
'引数:作成するパスorフォルダ名
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Function MakeFolder(ByVal aPath As String) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダ名の場合、カレントディレクトリ＋フォルダ名でパスにする
    If InStr(aPath, "\") = 0 Then aPath = CurDir & "\" & aPath
    'フォルダが存在しない場合は警告
    If ExistsFolder(aPath) Then GoTo Warn
    '作成
    Dim ary As Variant
    Dim arg As Variant: arg = Split(aPath, "\")
    Dim i As Long
    For i = LBound(arg) To UBound(arg)
        ary = arg
        ReDim Preserve ary(i)
        If Not fso.FolderExists(Join(ary, "\")) Then
            fso.CreateFolder Join(ary, "\")
        End If
    Next
    MakeFolder = True
    If logging Then AddLog "FolderUtil.MakeFolder", "INFO ", "対象:" & aPath
    GoTo Finally
Warn:
    MakeFolder = True
    If logging Then AddLog "FolderUtil.MakeFolder", "WARN ", "対象:" & aPath & " / 警告内容:すでに存在しています"
    GoTo Finally
Err:
    If logging Then AddLog "FolderUtil.MakeFolder", "ERROR", "対象:" & aPath & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■フォルダを削除
'----------------------------------------------------
'備考:中身も丸ごと削除。ワイルドカード使用可能(*,?)
'----------------------------------------------------
'引数1:削除するパスorフォルダ名
'引数2:読み取り専用フォルダを削除するか   ※Trueなら削除　デフォルトは削除しない
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function DeleteFolder(ByVal aPath As String, Optional aForce As Boolean) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダ名の場合、カレントディレクトリ＋フォルダ名でパスにする
    If InStr(aPath, "\") = 0 Then aPath = CurDir & "\" & aPath
    'フォルダが存在しない場合は警告
    If Not ExistsFolder(aPath) Then GoTo Warn
    '削除
    fso.DeleteFolder aPath, aForce
    DeleteFolder = True
    If logging Then AddLog "FolderUtil.DeleteFolder", "INFO ", "対象:" & aPath & " / 読み取り専用削除:" & aForce
    GoTo Finally
Warn:
    DeleteFolder = True
    If logging Then AddLog "FolderUtil.DeleteFolder", "WARN ", "対象:" & aPath & " / 警告内容:対象が存在しません"
    GoTo Finally
Err:
    If logging Then AddLog "FolderUtil.DeleteFolder", "ERROR", "対象:" & aPath & " / 読み取り専用削除:" & aForce & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■フォルダをコピー
'----------------------------------------------------
'引数1:コピー元のパスorフォルダ名
'引数2:コピー先のパスorフォルダ名
'引数3:(Optional)上書きするか     ※Trueなら上書きする、デフォルトは上書きしない
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function CopyFolder(ByVal aOrigin As String, ByVal aDestination As String, Optional aIsOverWrite As Boolean) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダ名の場合、カレントディレクトリ＋フォルダ名でパスにする
    If InStr(aOrigin, "\") = 0 Then aOrigin = CurDir & "\" & aOrigin
    If InStr(aDestination, "\") = 0 Then aDestination = CurDir & "\" & aDestination
    'コピー
    fso.CopyFolder aOrigin, aDestination, aIsOverWrite
    CopyFolder = True
    If logging Then AddLog "FolderUtil.CopyFolder", "INFO ", "コピー元:" & aOrigin & " / コピー先:" & aDestination & " / 上書き:" & aIsOverWrite
    GoTo Finally
Err:
    If logging Then AddLog "FolderUtil.CopyFolder", "ERROR", "コピー元:" & aOrigin & " / コピー先:" & aDestination & " / 上書き:" & aIsOverWrite & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■フォルダを移動
'----------------------------------------------------
'引数1:移動元のパスorフォルダ名
'引数2:移動先のパス
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function MoveFolder(ByVal aSource As String, ByVal aDestination As String) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダ名の場合、カレントディレクトリ＋フォルダ名でパスにする
    If InStr(aSource, "\") = 0 Then aSource = CurDir & "\" & aSource
    '移動先のパスの末尾に\をつける
    If Not Right(aDestination, 1) = "\" Then aDestination = aDestination & "\"
    '移動
    fso.MoveFolder aSource, aDestination
    MoveFolder = True
    If logging Then AddLog "FolderUtil.MoveFolder", "INFO ", "移動元:" & aSource & " / 移動先:" & aDestination
    GoTo Finally
Err:
    If logging Then AddLog "FolderUtil.MoveFolder", "ERROR", "移動元:" & aSource & " / 移動先:" & aDestination & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■フォルダ名を変更
'----------------------------------------------------
'引数1:変更対象のパスorフォルダ名
'引数2:変更後の名前
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function ChangeFolderName(ByVal aPath As String, aFolderName As String) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フォルダ名の場合、カレントディレクトリ＋フォルダ名でパスにする
    If InStr(aPath, "\") = 0 Then aPath = CurDir & "\" & aPath
    '名前を変更
    fso.GetFolder(aPath).Name = aFolderName
    ChangeFolderName = True
    If logging Then AddLog "FolderUtil.ChangeFolderName", "INFO ", "対象:" & aPath & " / フォルダ名:" & aFolderName
    GoTo Finally
Err:
    If logging Then AddLog "FolderUtil.ChangeFolderName", "ERROR", "対象:" & aPath & " / フォルダ名:" & aFolderName & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■フォルダ名の一覧を取得
'----------------------------------------------------
'引数1:(Optional)取得するフォルダのパス   ※指定しなければカレントディレクトリ
'引数2:(Optional)取得する条件   ※Like演算子を使用(*,?)
'引数3:(Optional)フルパスにするか　※Trueならフルパス
'----------------------------------------------------
'戻り値:取得結果（Collection）
'----------------------------------------------------
Public Function GetFolderList(Optional ByVal aPath As String, Optional aLikeValue As String, Optional aIsFullPath As Boolean) As Collection
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim f As Variant
    Set GetFolderList = New Collection
    
    '引数(パス)を指定しなければカレントディレクトリにする
    If aPath = "" Then aPath = CurDir
    'フォルダ名を取得
    For Each f In fso.GetFolder(aPath).subFolders
        If aLikeValue = "" Or LCase(f.Name) Like aLikeValue Then
            If aIsFullPath Then GetFolderList.Add f.Path    'フルパス
            If Not aIsFullPath Then GetFolderList.Add f.Name    'フォルダ名
        End If
    Next
End Function

'----------------------------------------------------
'■フォルダ存在確認
'----------------------------------------------------
'引数:フルパスorフォルダ名
'----------------------------------------------------
'戻り値:確認結果     ※存在すればTrue
'----------------------------------------------------
Public Function ExistsFolder(aPath As String) As Boolean
    If (Dir(aPath, vbDirectory) <> "") Then ExistsFolder = True
End Function