【VBA】BookUtill

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

'v1
'****************************************************
'ブック操作処理
'----------------------------------------------------
'BookUtil
'****************************************************
'MakeBook             -新規ブックを作成
'OpenBook             -ブックを開く(フルパスorファイル名から) ※拡張子必要
'OpenBookByDialog     -ブックを開く(ダイアログから)
'SaveBook             -ブック上書き保存
'SaveNewBook          -ブックを名前を付けて保存(フルパスorファイル名から) ※拡張子なくても可
'SaveNewBookByDialog  -ブックを名前を付けて保存(ダイアログから)
'CloseBook            -ブックを閉じる
'IsBookOpen           -ブックオープン確認
'IsReadOnly           -読み取り専用確認
'****************************************************

'----------------------------------------------------
'■新規ブックを作成
'----------------------------------------------------
'引数1:格納先ワークブック
'引数2:(Optional)シート数   ※デフォルトは1シート
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function MakeBook(aReturn As Workbook, Optional aSheetCnt As Long = 1) As Boolean
On Error GoTo Err
    'シート数を設定する
    Application.SheetsInNewWorkbook = aSheetCnt
    'ブック作成
    Set aReturn = Workbooks.Add
    MakeBook = True
    If logging Then AddLog "BookUtil.MakeBook", "INFO ", "シート数:" & aSheetCnt
    Exit Function
Err:
    If logging Then AddLog "BookUtil.MakeBook", "ERROR", "シート数:" & aSheetCnt & " / エラー内容:" & Err.Description
End Function

'----------------------------------------------------
'■ブックを開く
'----------------------------------------------------
'引数1:開くファイルのフルパスまたはファイル名(拡張子必要)
'引数2:格納先ワークブック
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function OpenBook(ByVal aFullPath As String, aReturn As Workbook) As Boolean
On Error GoTo Err
    'フルパスでない場合、カレントディレクトリ＋ファイル名でフルパスにする
    If InStr(aFullPath, "\") = 0 Then aFullPath = CurDir & "\" & aFullPath
    '読み取り専用推奨メッセージを表示しない
    Application.DisplayAlerts = False
    '既に開かれていなければ開く
    If Not IsBookOpen(Dir(aFullPath)) Then
        Set aReturn = Workbooks.Open(aFullPath)
    Else
        Set aReturn = Workbooks(Dir(aFullPath))
    End If
    OpenBook = True
    If logging Then AddLog "BookUtil.OpenBook", "INFO ", "対象:" & aFullPath
    GoTo Finally
Err:
    If logging Then AddLog "BookUtil.OpenBook", "ERROR", "対象:" & aFullPath & " / エラー内容:" & Err.Description
Finally:
    Application.DisplayAlerts = True
End Function

'----------------------------------------------------
'■ブックを開く（ダイアログから）
'----------------------------------------------------
'引数:格納先ワークブック
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function OpenBookByDialog(aReturn As Workbook) As Boolean
On Error GoTo Err
    'ダイアログから選択
    Dim fullPath As String: fullPath = Application.GetOpenFilename("Excel,*.xls?")
    '選択しなければ終わる
    If fullPath = "False" Then GoTo Err
    '読み取り専用推奨メッセージを表示しない
    Application.DisplayAlerts = False
    '既に開かれていなければ開く
    If Not IsBookOpen(Dir(fullPath)) Then
        Set aReturn = Workbooks.Open(fullPath)
    Else
        Set aReturn = Workbooks(Dir(fullPath))
    End If
    OpenBookByDialog = True
    If logging Then AddLog "BookUtil.OpenBookByDialog", "INFO ", "対象:" & fullPath
    GoTo Finally
Err:
    If logging Then AddLog "BookUtil.OpenBookByDialog", "ERROR", "対象:" & fullPath & " / エラー内容:" & Err.Description
Finally:
    Application.DisplayAlerts = True
End Function

'----------------------------------------------------
'■ブック上書き保存
'----------------------------------------------------
'引数:保存するワークブック
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function SaveBook(aWorkBook As Workbook) As Boolean
On Error GoTo Err
    '読み取り専用ならエラー
    If IsReadOnly(aWorkBook) Then GoTo Err_ReadOnly
    '保存
    aWorkBook.Save
    If logging Then AddLog "BookUtil.SaveBook", "INFO ", "対象:" & aWorkBook.Name
    SaveBook = True
    Exit Function
Err:
    If logging Then AddLog "BookUtil.SaveBook", "ERROR", "エラー内容:" & Err.Description
    Exit Function
Err_ReadOnly:
    If logging Then AddLog "BookUtil.SaveBook", "ERROR", "対象:" & aWorkBook.Name & " / エラー内容:読み取り専用のため上書き保存できません"
End Function

'----------------------------------------------------
'■ブックを名前を付けて保存
'----------------------------------------------------
'引数1:保存するワークブック
'引数2:保存するフルパスorファイル名(拡張子なしでも可)
'引数3:(Optional)上書きするか　※デフォルトは上書きしない
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function SaveNewBook(aWorkBook As Workbook, ByVal aFullPath As String, Optional aIsOverWrite As Boolean) As Boolean
On Error GoTo Err
    'フルパスでない場合
    If InStr(aFullPath, "\") = 0 Then
        '拡張子がついていない場合拡張子をつける
        If InStr(aFullPath, ".") = 0 Then
            '(新規の場合)拡張子xlsxをつける
            If InStr(aWorkBook.FullName, "\") = 0 Then
                aFullPath = aFullPath & ".xlsx"
            '(新規以外の場合)保存元の拡張子をつける
            Else
                aFullPath = aFullPath & Mid(aWorkBook.Name, InStrRev(aWorkBook.Name, "."))
            End If
        End If
        'カレントディレクトリ+ファイル名でフルパスにする
        aFullPath = CurDir & "\" & aFullPath
    End If
    '上書きしない場合は存在確認をする
    If Not aIsOverWrite Then
        '存在すれば保存せず終了
        If (Dir(aFullPath) <> "") Then GoTo Err_Exist
    '上書きする場合はメッセージが表示されないようにする
    Else
        Application.DisplayAlerts = False
    End If
    '保存（マクロブックの場合）
    If InStr(aFullPath, ".xlsm") Then
        aWorkBook.SaveAs Filename:=aFullPath, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    '保存（マクロブック以外）
    Else
        aWorkBook.SaveAs Filename:=aFullPath
    End If
    SaveNewBook = True
    If logging Then AddLog "BookUtil.SaveNewBook", "INFO ", "保存元:" & aWorkBook.Name & " / 保存先:" & aFullPath & " / 上書きモード:" & aIsOverWrite
    GoTo Finally
Err_Exist:
    If logging Then AddLog "BookUtil.SaveNewBook", "ERROR", "保存先:" & aFullPath & " / 上書きモード:" & aIsOverWrite & " / エラー内容:ファイルが既に存在します"
    Exit Function
Err:
    If logging Then AddLog "BookUtil.SaveNewBook", "ERROR", "保存元:" & aWorkBook.Name & " / 保存先:" & aFullPath & " / 上書きモード:" & aIsOverWrite & " / エラー内容:" & Err.Description
Finally:
    Application.DisplayAlerts = True
End Function

'----------------------------------------------------
'■ブックを名前を付けて保存（ダイアログから）
'----------------------------------------------------
'引数:保存するワークブック
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function SaveNewBookByDialog(aWorkBook As Workbook) As Boolean
On Error GoTo Err
    Dim fullPath As String
    Dim filterIndex As Long: filterIndex = 1
    
    '保存元の拡張子を確認し、ダイアログのデフォルトにセット
    If InStr(aWorkBook.Name, ".xlsm") > 0 Then filterIndex = 2
    If InStr(aWorkBook.Name, ".csv") > 0 Then filterIndex = 3
    'ダイアログから選択
    fullPath = Application.GetSaveAsFilename(FileFilter:="Excelファイル,*.xlsx,Excelマクロ,*.xlsm,CSVファイル,*.csv", filterIndex:=filterIndex)
    '選択しなければ終わる
    If fullPath = "False" Then GoTo Err
    '上書き確認を出さないようにする
    Application.DisplayAlerts = False
    '保存（マクロブックの場合）
    If InStr(fullPath, ".xlsm") Then
        aWorkBook.SaveAs Filename:=fullPath, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    '保存（マクロブック以外）
    Else
        aWorkBook.SaveAs Filename:=fullPath
    End If
    SaveNewBookByDialog = True
    If logging Then AddLog "BookUtil.SaveNewBookByDialog", "INFO ", "保存元:" & aWorkBook.Name & " / 保存先:" & fullPath
    GoTo Finally
Err:
    If logging Then AddLog "BookUtil.SaveNewBookByDialog", "ERROR", "保存先:" & fullPath & " / エラー内容:" & Err.Description
Finally:
    Application.DisplayAlerts = True
End Function

'----------------------------------------------------
'■ブックを閉じる
'----------------------------------------------------
'引数:閉じるワークブック
'----------------------------------------------------
'戻り値:実行結果　※エラーがなければTrue
'----------------------------------------------------
Public Function CloseBook(aWorkBook As Workbook) As Boolean
On Error GoTo Err
    '閉じる
    aWorkBook.Close savechanges:=False
    CloseBook = True
    If logging Then AddLog "BookUtil.CloseBook", "INFO ", "対象:" & aWorkBook.Name
    Exit Function
Err:
    If logging Then AddLog "BookUtil.CloseBook", "ERROR", "エラー内容:" & Err.Description
End Function

'----------------------------------------------------
'■ブックオープン確認
'----------------------------------------------------
'引数:確認するワークブック名
'----------------------------------------------------
'戻り値:確認結果　※開いていればTrue
'----------------------------------------------------
Public Function IsBookOpen(aBookName As String) As Boolean
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = aBookName Then
            IsBookOpen = True
            Exit For
        End If
    Next
End Function

'----------------------------------------------------
'■読み取り専用確認
'----------------------------------------------------
'引数:確認するワークブック
'----------------------------------------------------
'戻り値:確認結果　※読み取り専用ならTrue
'----------------------------------------------------
Public Function IsReadOnly(aWorkBook As Workbook) As Boolean
    If aWorkBook.ReadOnly Then IsReadOnly = True
End Function