【VBA】FileUtil

Option Explicit

'v1
'****************************************************
'ファイル操作処理
'----------------------------------------------------
'FileUtil
'****************************************************
'DeleteFile           -ファイルを削除
'CopyFile             -ファイルをコピー
'MoveFile             -ファイルを移動
'ChangeFileName       -ファイル名を変更
'WriteText            -テキストファイル出力
'WriteTextByDialog    -テキストファイル出力(ダイアログから)
'ReadText             -テキストファイル読み込み
'ReadTextByDialog     -テキストファイル読み込み(ダイアログから)
'FullPathToName       -フルパスからファイル名に変換
'GetFileList          -ファイル名の一覧を取得
'ExistsFile           -ファイルの存在確認
'****************************************************

'----------------------------------------------------
'■ファイルを削除
'----------------------------------------------------
'引数:削除対象のフルパスorファイル名(拡張子必要)
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function DeleteFile(ByVal aFullPath As String) As Boolean
On Error GoTo Err
    'フルパスでない場合、カレントディレクトリ+ファイル名でフルパスにする
    If InStr(aFullPath, "\") = 0 Then aFullPath = CurDir & "\" & aFullPath
    'ファイルが存在しなければ警告
    If Not ExistsFile(aFullPath) Then GoTo Warn
    '完全削除
    Kill aFullPath
    DeleteFile = True
    If logging Then AddLog "FileUtil.DeleteFile", "INFO ", "対象:" & aFullPath
    Exit Function
Warn:
    DeleteFile = True
    If logging Then AddLog "FileUtil.DeleteFile", "WARN ", "対象:" & aFullPath & " / 警告内容:ファイルが存在しません"
    Exit Function
Err:
    If logging Then AddLog "FileUtil.DeleteFile", "ERROR", "対象:" & aFullPath & " / エラー内容:" & Err.Description
End Function

'----------------------------------------------------
'■ファイルをコピー
'----------------------------------------------------
'引数1:コピー元のフルパスorファイル名(拡張子必要)
'引数2:コピー先のフルパスorファイル名(拡張子必要)
'引数3:(Optional)上書きするか     ※Trueなら上書きする、デフォルトは上書きしない
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function CopyFile(ByVal aOrigin As String, ByVal aDestination As String, Optional aIsOverWrite As Boolean) As Boolean
On Error GoTo Err
    'フルパスでない場合、カレントディレクトリ+ファイル名でフルパスにする
    If InStr(aOrigin, "\") = 0 Then aOrigin = CurDir & "\" & aOrigin
    If InStr(aDestination, "\") = 0 Then aDestination = CurDir & "\" & aDestination
    '(上書きしない場合)
    'コピー先が存在すればコピーせず終了
    If Not aIsOverWrite Then
        If ExistsFile(aDestination) Then GoTo Err
    End If
    '(上書きする場合)
    'コピー
    FileCopy aOrigin, aDestination
    CopyFile = True
    If logging Then AddLog "FileUtil.CopyFile", "INFO ", "コピー元:" & aOrigin & " / コピー先:" & aDestination & " / 上書き:" & aIsOverWrite
    Exit Function
Err:
    If logging Then AddLog "FileUtil.CopyFile", "ERROR", "コピー元:" & aOrigin & " / コピー先:" & aDestination & " / 上書き:" & aIsOverWrite & " / エラー内容:" & Err.Description
End Function

'----------------------------------------------------
'■ファイルを移動
'----------------------------------------------------
'備考:移動先にファイルが存在していればエラー
'----------------------------------------------------
'引数1:移動元のフルパスorファイル名(拡張子必要)
'引数2:移動先のフルパスorファイル名(拡張子必要)
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function MoveFile(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 InStr(aDestination, "\") = 0 Then aDestination = CurDir & "\" & aDestination
    '移動
    fso.MoveFile aSource, aDestination
    MoveFile = True
    If logging Then AddLog "FileUtil.MoveFile", "INFO ", "移動元:" & aSource & " / 移動先:" & aDestination
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.MoveFile", "ERROR", "移動元:" & aSource & " / 移動先:" & aDestination & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■ファイル名を変更
'----------------------------------------------------
'引数1:変更対象のフルパスorファイル名(拡張子必要)
'引数2:変更後の名前(拡張子必要)
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function ChangeFileName(ByVal aFullPath As String, aFileName As String) As Boolean
On Error GoTo Err
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    'フルパスでない場合、カレントディレクトリ+ファイル名でフルパスにする
    If InStr(aFullPath, "\") = 0 Then aFullPath = CurDir & "\" & aFullPath
    '名前を変更
    fso.GetFile(aFullPath).name = aFileName
    ChangeFileName = True
    If logging Then AddLog "FileUtil.ChangeFileName", "INFO ", "対象:" & aFullPath & " / ファイル名:" & aFileName
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.ChangeFileName", "ERROR", "対象:" & aFullPath & " / ファイル名:" & aFileName & " / エラー内容:" & Err.Description
Finally:
    Set fso = Nothing
End Function

'----------------------------------------------------
'■テキストファイル出力
'----------------------------------------------------
'引数1:フルパスorファイル名(拡張子必要)
'引数2:出力対象
'引数3:(Optional)文字コード  ※省略時はUTF-8
'引数4:(Optional)存在すれば追記するか ※Trueならする、Falseなら存在すればエラー
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function WriteText(ByVal aFullPath As String, aValue As Variant, Optional aCharset As String = "UTF-8", Optional aIsOverWrite As Boolean) As Boolean
On Error GoTo Err
    Dim writeValue As String
    Dim ado As Object: Set ado = CreateObject("ADODB.Stream")
    
    'ストリームの設定
    With ado
        .Open
        .charset = aCharset
        .Type = 2
    End With
    
    'フルパスでない場合、カレントディレクトリ+ファイル名でフルパスにする
    If InStr(aFullPath, "\") = 0 Then aFullPath = CurDir & "\" & aFullPath
    '書き込み内容作成>writeValue
    '(配列,オブジェクトの場合)
    Dim v As Variant
    If IsArray(aValue) Or IsObject(aValue) Then
        For Each v In aValue
            writeValue = writeValue & v & vbLf
        Next
    Else
    '(配列,オブジェクト以外の場合)
        writeValue = aValue & vbLf
    End If
    
    '書き込み処理
    '追記するか
    Dim overWrite As Long: overWrite = IIf(aIsOverWrite, 2, 1)
    '(ファイルが存在する場合、追記orエラー)
    If ExistsFile(aFullPath) Then
        With ado
            .LoadFromFile aFullPath
            .Position = .Size
            .WriteText writeValue, 0    '改行しない
            .SaveToFile aFullPath, overWrite    '追記するか
        End With
    Else
    '(ファイルが存在しなければ新規作成)
        With ado
            .WriteText writeValue, 0    '改行しない
            .SaveToFile aFullPath, 1    'ファイルが存在すればエラー
        End With
    End If
    WriteText = True
    If logging Then AddLog "FileUtil.WriteText", "INFO ", "対象:" & aFullPath & " / 文字コード:" & aCharset
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.WriteText", "ERROR", "対象:" & aFullPath & " / 文字コード:" & aCharset & " / エラー内容:" & Err.Description
Finally:
    ado.Close
End Function

'----------------------------------------------------
'■テキストファイル出力(ダイアログから)
'----------------------------------------------------
'引数1:出力対象
'引数2:(Optional)文字コード  ※省略時はUTF-8
'引数3:(Optional)存在すれば追記するか ※Trueならする、Falseなら存在すればエラー
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function WriteTextByDialog(aValue As Variant, Optional aCharset As String = "UTF-8", Optional aIsOverWrite As Boolean) As Boolean
On Error GoTo Err
    Dim writeValue As String
    Dim fullPath As String
    Dim ado As Object: Set ado = CreateObject("ADODB.Stream")
    
    'ストリームの設定
    With ado
        .Open
        .charset = aCharset
    End With
    
    'ダイアログから選択
    fullPath = Application.GetSaveAsFilename()
    '選択しなければ終わる
    If fullPath = "False" Then GoTo Err
    '書き込み内容作成>writeValue
    '(配列,オブジェクトの場合)
    Dim v As Variant
    If IsArray(aValue) Or IsObject(aValue) Then
        For Each v In aValue
            writeValue = writeValue & v & vbLf
        Next
    Else
    '(配列,オブジェクト以外の場合)
        writeValue = aValue & vbLf
    End If
    
    '書き込み処理
    '追記するか
    Dim overWrite As Long: overWrite = IIf(aIsOverWrite, 2, 1)
    '(ファイルが存在する場合、追記orエラー)
    If ExistsFile(fullPath) Then
        With ado
            .LoadFromFile fullPath
            .Position = .Size
            .WriteText writeValue, 0    '改行しない
            .SaveToFile fullPath, overWrite    'ファイルが存在すれば上書き
        End With
    Else
    '(ファイルが存在しなければ新規作成)
        With ado
            .WriteText writeValue, 0    '改行しない
            .SaveToFile fullPath, 1    'ファイルが存在すればエラー
        End With
    End If
    WriteTextByDialog = True
    If logging Then AddLog "FileUtil.WriteTextByDialog", "INFO ", "対象:" & fullPath & " / 文字コード:" & aCharset
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.WriteTextByDialog", "ERROR", "対象:" & fullPath & " / 文字コード:" & aCharset & " / エラー内容:" & Err.Description
Finally:
    ado.Close
End Function

'----------------------------------------------------
'■テキストファイル読み込み
'----------------------------------------------------
'引数1:フルパスorファイル名(拡張子必要)
'引数2:結果の格納先
'引数3:(Optional)文字コード  ※省略時はUTF-8
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function ReadText(ByVal aFullPath As String, aReturn As Collection, Optional aCharset As String = "UTF-8") As Boolean
On Error GoTo Err
    Dim ado As Object: Set ado = CreateObject("ADODB.Stream")
    'ストリームの設定
    With ado
        .Open
        .charset = aCharset
        .LineSeparator = 10 '改行コード
    End With
    'フルパスでない場合、カレントディレクトリ+ファイル名でフルパスにする
    If InStr(aFullPath, "\") = 0 Then aFullPath = CurDir & "\" & aFullPath
    '読み込み処理
    ado.LoadFromFile aFullPath
    Do Until ado.EOS
        aReturn.Add ado.ReadText(-2)
    Loop
    ReadText = True
    If logging Then AddLog "FileUtil.ReadText", "INFO ", "対象:" & aFullPath & " / 文字コード:" & aCharset
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.ReadText", "ERROR", "対象:" & aFullPath & " / 文字コード:" & aCharset & " / エラー内容:" & Err.Description
Finally:
    ado.Close
End Function

'----------------------------------------------------
'■テキストファイル読み込み(ダイアログから)
'----------------------------------------------------
'引数1:結果の格納先
'引数2:(Optional)文字コード  ※省略時はUTF-8
'----------------------------------------------------
'戻り値:実行結果 ※エラーがなければTrue
'----------------------------------------------------
Public Function ReadTextByDialog(aReturn As Collection, Optional aCharset As String = "UTF-8") As Boolean
On Error GoTo Err
    Dim ado As Object: Set ado = CreateObject("ADODB.Stream")
    Dim fullPath As String
    'ストリームの設定
    With ado
        .Open
        .charset = aCharset
        .LineSeparator = 10 '改行コード
    End With
    'ダイアログから選択
    fullPath = Application.GetOpenFilename()
    '選択しなければ終わる
    If fullPath = "False" Then GoTo Err
    '読み込み処理
    ado.LoadFromFile fullPath
    Do Until ado.EOS
        aReturn.Add ado.ReadText(-2)
    Loop
    ReadTextByDialog = True
    If logging Then AddLog "FileUtil.ReadTextByDialog", "INFO ", "対象:" & fullPath & " / 文字コード:" & aCharset
    GoTo Finally
Err:
    If logging Then AddLog "FileUtil.ReadTextByDialog", "ERROR", "対象:" & fullPath & " / 文字コード:" & aCharset & " / エラー内容:" & Err.Description
Finally:
    ado.Close
End Function

'----------------------------------------------------
'■フルパスからファイル名に変換
'----------------------------------------------------
'引数1:フルパス
'引数2:(Optional)取得結果に拡張子をつけるか   ※Trueならつける、デフォルトはつける
'----------------------------------------------------
'戻り値:ファイル名
'----------------------------------------------------
Public Function FullPathToName(aFullPath As String, Optional aIsExtension As Boolean = True) As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    FullPathToName = IIf(aIsExtension, fso.GetFileName(aFullPath), fso.GetBaseName(aFullPath))
End Function

'----------------------------------------------------
'■ファイル名の一覧を取得
'----------------------------------------------------
'引数1:(Optional)取得するフォルダのパス   ※指定しなければカレントディレクトリ
'引数2:(Optional)取得する条件   ※Like演算子を使用(*,?)
'引数3:(Optional)フルパスにするか ※Trueならフルパス、デフォルトはフルパスにしない
'----------------------------------------------------
'戻り値:取得結果(Collection)
'----------------------------------------------------
Public Function GetFileList(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 GetFileList = New Collection
    
    '引数(パス)を指定しなければカレントディレクトリにする
    If aPath = "" Then aPath = CurDir
    'ファイル名を取得
    For Each f In fso.GetFolder(aPath).Files
        If aLikeValue = "" Or LCase(f.name) Like aLikeValue Then
            If aIsFullPath Then GetFileList.Add f.Path  'フルパス
            If Not aIsFullPath Then GetFileList.Add f.name  'ファイル名
        End If
    Next
End Function

'----------------------------------------------------
'■ファイル存在確認
'----------------------------------------------------
'引数:フルパスorファイル名(拡張子必要)
'----------------------------------------------------
'戻り値:確認結果     ※存在すればTrue
'----------------------------------------------------
Public Function ExistsFile(aFullPath As String) As Boolean
    If (Dir(aFullPath) <> "") Then ExistsFile = True
End Function