Option Explicit

Private Const sAppName = "自動コピー保存"

'設定値の構造体
Private Type ascParameters
    iAutoSave As Integer
    iFrequency As Integer
    iSaveAll As Integer
    iPrompt As Integer
    iSaveNewBook As Integer
    iBackup As Integer
    iKeepDays As Integer
    iPromptDelete As Integer
    iTestFlag As Integer
    sTempPath(1 To 4) As String
End Type


'Auto_Open
'
'INIファイルの読み取り、バックアップコピー、古いファイルの削除、
'自動保存マクロの起動を行います。

Sub Auto_Open()
    On Error GoTo ErrorHandler
'    Application.EnableCancelKey = xlDisabled
    ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value = -1
    If ascReadIniFile() < 0 Then Exit Sub
    If ascBackupCopy() = 0 Then Exit Sub
    ascAutoSaveCopy
    Exit Sub

ErrorHandler:
    MsgBox "予期せぬエラーです。", vbExclamation, sAppName
    Exit Sub
End Sub


'Auto_Remove
'
'自動保存マクロの解除を行います。

Sub Auto_Remove()
    Application.EnableCancelKey = xlDisabled
    ascCancelSave
    On Error Resume Next
    Application.Toolbars("自動コピー保存").Visible = False
    On Error GoTo 0
End Sub


'自動保存を解除する関数
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Public Function ascCancelSave() As Integer
    Dim dfSaveTime As Double

    ascCancelSave = 0
    On Error GoTo ErrorHandler

    '現在の起動時刻を取得。
    dfSaveTime = ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value

    '0以下の場合は解除は不要なので終了します。
    If dfSaveTime <= 0 Then
        ascCancelSave = 1
        Exit Function
    End If

    '自動保存マクロを解除。
    Application.OnTime dfSaveTime, ThisWorkbook.Name & "!ascAutoSaveCopy", , False
    
    '解除が成功したら現在の起動時刻に 0 を設定。
    ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value = 0
    ascCancelSave = 1
    Exit Function

ErrorHandler:
    MsgBox "自動保存の解除でエラーが発生しました。", vbExclamation, sAppName
    Exit Function
End Function


'自動保存マクロの登録をチェックする関数
'
'[戻り値]
'0 : 正しく登録されている。
'1 : 登録されていない。
'2 : 登録解除に失敗している。
'-1: エラー。

Public Function ascOnTimeCheck() As Integer
    Dim dfSaveTime As Double
    Dim iErr As Long

    ascOnTimeCheck = -1
    On Error GoTo ErrorHandler

    '現在の起動時刻を取得。
    dfSaveTime = ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value

    '0以下の場合は終了します。
    If dfSaveTime <= 0 Then
        ascOnTimeCheck = 1
        Exit Function
    End If

    '自動保存マクロを解除。
    On Error Resume Next
    Application.OnTime dfSaveTime, ThisWorkbook.Name & "!ascAutoSaveCopy", , False
    iErr = Err
    On Error GoTo ErrorHandler

    If iErr = 0 Then
        '自動保存マクロを再登録
        On Error Resume Next
        Application.OnTime dfSaveTime, ThisWorkbook.Name & "!ascAutoSaveCopy"
        iErr = Err
        On Error GoTo ErrorHandler
        If iErr = 0 Then
            ascOnTimeCheck = 0
        Else
            '再登録に失敗したら現在の起動時刻に 0 を設定。
            ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value = 0
            ascOnTimeCheck = 2
        End If
    Else
        '解除に失敗したら現在の起動時刻に 0 を設定。
        ThisWorkbook.Sheets("Settings").Range("ascSaveTime").Value = 0
        ascOnTimeCheck = 2
    End If
    Exit Function

ErrorHandler:
    Exit Function
End Function


'自動保存マクロ
Public Sub ascAutoSaveCopy()
    Dim iRet As Integer

    On Error GoTo ErrorHandler
    
    'キャンセルキーを使用不可にします。
    '(ファイル保存時には使用可能にします。)
    Application.EnableCancelKey = xlDisabled

    '自動保存の実行
    iRet = ascAutoSaveCopy2
    If iRet = 0 Then
        MsgBox "自動保存は異常終了しました。", vbExclamation, sAppName
    End If
    Application.EnableCancelKey = xlInterrupt
    On Error GoTo 0
    Exit Sub
ErrorHandler:
    MsgBox "予期せぬエラーです。", vbExclamation, sAppName
    Exit Sub
End Sub


'自動保存を実行する関数
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Private Function ascAutoSaveCopy2()
    Dim oBooks() As Workbook
    Dim iBookFlags() As Integer
    Dim iBookIndex As Integer
    Dim iBookCount As Integer
    Dim iSaveCount As Integer
    Dim utParam As ascParameters
    Dim bFlag As Boolean
    Dim sFileName As String
    Dim sTempPath As String
    Dim sTempPath1 As String
    Dim sTempPath2 As String
    Dim vRet As Variant
    Dim iRet As Long
    Dim iRow As Long
    Dim oBook As Workbook
    Dim oRange As Range
    Dim oRange_Count As Range
    Dim obj As Object
    Dim dfSaveTime As Double
    Dim i As Long

    ascAutoSaveCopy2 = 0

    On Error GoTo ErrorHandler

    '自動保存の起動時刻を取得し、0 クリアします。
    Set oRange = ThisWorkbook.Sheets("Settings").Range("ascSaveTime")
    dfSaveTime = oRange.Value
    oRange.Value = 0

    '設定の取得。
    If ascGetParameters(utParam) = 0 Then
        Exit Function
    End If

    '自動保存しない場合は終了する。
    If utParam.iAutoSave = 0 Then
        ascAutoSaveCopy2 = 1
        Exit Function
    End If

    '保存間隔のチェック。
    If utParam.iFrequency <= 0 Then
        MsgBox "保存間隔の設定が不正です。", vbExclamation, sAppName
        Exit Function
    End If

    '保存用フォルダ1, 2 の切り替え。
    Set oRange = ThisWorkbook.Sheets("Settings").Range("ascCurrentTemp")
    If dfSaveTime <= 0 Then
        '起動時刻が0以下の場合は、フォルダのチェックと自動保存マクロの登録
        'だけを行い、次の保存時にはフォルダ1が使用されるようにします。
        sTempPath = utParam.sTempPath(1)
        oRange.Value = 0
    ElseIf oRange.Value = 0 Then
        sTempPath = utParam.sTempPath(1)
        oRange.Value = 1
    Else
        sTempPath = utParam.sTempPath(2)
        oRange.Value = 0
    End If

    '保存用フォルダのチェック。
    If sTempPath = "" Then
        MsgBox "保存用フォルダが設定されていません。", vbExclamation, sAppName
        Exit Function
    End If
    If Not DirExists(sTempPath) Then
        MsgBox sTempPath & " は存在しません。", vbExclamation, sAppName
        Exit Function
    End If

    '起動時刻が 0 以下の場合は保存せず、自動保存マクロの登録だけ行います。
    If dfSaveTime <= 0 Then
        GoTo Label_OnTime
    End If

    'パス区切りの追加。
    sTempPath = AddPathSeparator(sTempPath)

    '保存するブックのリストを取得。
    If utParam.iSaveAll = 1 Then
        iBookCount = Workbooks.Count
        ReDim oBooks(1 To iBookCount)
        ReDim iBookFlags(1 To iBookCount)
        For iBookIndex = 1 To iBookCount
            Set oBooks(iBookIndex) = Workbooks(iBookIndex)
        Next
    Else
        iBookCount = 1
        ReDim oBooks(1 To iBookCount)
        ReDim iBookFlags(1 To iBookCount)
        Set oBooks(iBookCount) = ActiveWorkbook
    End If

    '保存するかチェック
    iSaveCount = 0
    For iBookIndex = 1 To iBookCount
    
        Set oBook = oBooks(iBookIndex)

        '保存済みブックは保存しません。
        If oBook.Saved Then
            iBookFlags(iBookIndex) = 0

        '自動保存フォルダ内のブックファイルは保存しません。
        ElseIf StrComp(oBook.Path, Left(sTempPath, Len(sTempPath) - 1), 1) = 0 Then
            iBookFlags(iBookIndex) = 0

        '新規ブックの場合。
        ElseIf oBook.Path = "" Then
            If utParam.iSaveNewBook = 1 Then
                iBookFlags(iBookIndex) = 3
            Else
                iBookFlags(iBookIndex) = 0
            End If

        '非表示ブックは保存しません。
        Else
            bFlag = False
            For Each obj In oBook.Windows
                If obj.Visible Then
                    bFlag = True
                    Exit For
                End If
            Next
            If bFlag Then
                iBookFlags(iBookIndex) = 1
            Else
                iBookFlags(iBookIndex) = 0
            End If
        End If
        If iBookFlags(iBookIndex) <> 0 Then
            iSaveCount = iSaveCount + 1
        End If
    Next
    
    'メッセージの表示。
    If iSaveCount > 0 Then
        If utParam.iPrompt = 1 Then
            iRet = MsgBox("自動コピー保存を開始します。", vbOKCancel Or vbExclamation, sAppName)
            If iRet <> vbOK Then
                GoTo Label_OnTime
            End If
        End If
    Else
        If utParam.iPrompt <> 0 Then
            MsgBox "保存するブックはありません。", vbInformation, sAppName
        End If
        GoTo Label_OnTime:
    End If

    'ブックの保存処理
    For iBookIndex = 1 To iBookCount
        Select Case iBookFlags(iBookIndex)
            Case 1
                Set oBook = oBooks(iBookIndex)
                sFileName = sTempPath & oBook.Name
                GoSub Sub_SaveCopy
            Case 3
                '新規ブックの保存処理
                Set oBook = oBooks(iBookIndex)
                GoSub Sub_NewBook
                sFileName = sTempPath & sFileName
                GoSub Sub_SaveCopy
        End Select
    Next

    GoTo Label_OnTime
    Exit Function

'次の自動保存マクロの登録処理。
Label_OnTime:
    dfSaveTime = Now() + utParam.iFrequency / 1440
    With ThisWorkbook.Sheets("Settings").Range("ascSaveTime")
        .Value = dfSaveTime
        dfSaveTime = .Value
    End With
    Application.OnTime dfSaveTime, ThisWorkbook.Name & "!ascAutoSaveCopy"
    ascAutoSaveCopy2 = 1
    Exit Function


'新規ブックの処理。
Sub_NewBook:

    sFileName = ""

    'ブック名とファイル名の表範囲を取得。
    Set oRange_Count = ThisWorkbook.Sheets("Settings").Range("ascNewBookCount")
    Set oRange = ThisWorkbook.Sheets("Settings").Range("ascNewBook")
    iRow = oRange_Count.Value
    If iRow <= 0 Then
        iRow = 1
    Else
        '登録エントリがある場合､ブック名を検索｡
        vRet = Application.Match(oBook.Name, oRange.Resize(iRow, 1), 0)
        If IsError(vRet) Then
            iRow = iRow + 1
        Else
            '見つかったら、そのブックのファイル名を取得します。
            sFileName = oRange.Cells(vRet, 2).Value
        End If
    End If

    'ブック名が未登録の場合は新規に割り当てる。
    If sFileName = "" Then

        '割り当て可能なファイル名を検索する。
        sTempPath1 = AddPathSeparator(utParam.sTempPath(1))
        sTempPath2 = AddPathSeparator(utParam.sTempPath(2))
        bFlag = False
        For i = 0 To 9999
            sFileName = "XLS" & Format$(i, "0000") & ".TMP"
            If Dir(sTempPath1 & sFileName) = "" Then
                If Dir(sTempPath2 & sFileName) = "" Then
                    bFlag = True
                    Exit For
                End If
            End If
        Next
        If bFlag Then
            'ブック名とファイル名をセル範囲に追加する。
            oRange_Count.Value = iRow
            oRange.Cells(iRow, 1).Value = "'" & oBook.Name
            oRange.Cells(iRow, 2).Value = "'" & sFileName
        Else
            MsgBox oBook.Name & " の保存でエラーが発生しました。", vbExclamation, sAppName
            sFileName = ""
            Exit Function
        End If
    End If

    Return
    Exit Function


'コピー保存処理。
Sub_SaveCopy:

    If utParam.iPrompt = 2 Then
        iRet = MsgBox(oBook.Name & " のコピーを保存しますか?", vbYesNoCancel Or vbQuestion, sAppName)
        Select Case iRet
            Case vbYes
                iRet = ascSaveCopy(oBook, sFileName)
            Case vbNo
            Case vbCancel
                GoTo Label_OnTime
        End Select
    Else
        iRet = ascSaveCopy(oBook, sFileName)
        If iRet <> 0 Then
            If utParam.iSaveAll = 1 Then
                iRet = MsgBox("続行しますか?", vbOKCancel Or vbQuestion, sAppName)
                If iRet <> vbOK Then
                    GoTo Label_OnTime
                End If
            End If
        End If
    End If
    Return
    Exit Function

ErrorHandler:
    MsgBox Error(Err) & " (" & CStr(Err) & ")", vbExclamation, sAppName
    Exit Function
End Function


'コピー保存する関数
'
'[引数]
'oBook     : ブックオブジェクト
'sFileName : コピー保存先ファイル名
'
'[戻り値]
'0 : 正常終了。
'2 : ユーザーによる保存のキャンセル。
'-1: エラー。

Private Function ascSaveCopy(ByVal oBook As Workbook, ByVal sFileName As String) As Integer
    Dim iErr As Long
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableCancelKey = xlInterrupt
    oBook.SaveCopyAs sFileName
    iErr = Err

    'キャンセルキーを無効にします。
    'ただし、この処理自体がキャンセルされ、マクロの中断ダイアログボックスが
    '表示されることがあります。ユーザーによって中断されても、問題がないように
    'する必要があります。
    Application.EnableCancelKey = xlDisabled
    Application.DisplayAlerts = True

    Select Case iErr
        Case 0
            ascSaveCopy = 0
        Case 18
            MsgBox "ファイルの保存がキャンセルされました。", vbExclamation, sAppName
            ascSaveCopy = 2
        Case Else
            MsgBox Error(iErr) & " (" & CStr(iErr) & ")", vbExclamation, sAppName
            MsgBox "ファイルの保存でエラーが発生しました。", vbExclamation, sAppName
            ascSaveCopy = -1
    End Select
End Function


'アドイン起動時のバックアップ処理を行う関数
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Public Function ascBackupCopy()
    Dim utParam As ascParameters
    Dim iDirs() As Integer
    Dim iDirs2(1 To 2) As Integer
    Dim iDirCount2 As Integer
    Dim dtFileDate1 As Date
    Dim dtFileDate2 As Date
    Dim iErr As Long
    Dim iErrorCount As Integer
    Dim sFileName As String
    Dim sFileName2 As String
    Dim sFileName3 As String
    Dim sFileNames() As String
    Dim iFileCount As Integer
    Dim iRet As Integer
    Dim i As Integer
    Dim j As Integer

    ascBackupCopy = 0

    On Error GoTo ErrorHandler_DeleteFile

    If ascGetParameters(utParam) = 0 Then
        Exit Function
    End If
    
    If utParam.iAutoSave = 0 Then
        ascBackupCopy = 1
        Exit Function
    End If

    'パス区切りを追加
    For i = 1 To 4
        utParam.sTempPath(i) = AddPathSeparator(utParam.sTempPath(i))
    Next

'ファイル削除処理
Label_DeleteFile:

    If utParam.iKeepDays = 0 Then
        GoTo Label_BackupCopy
    End If

    '基準日の取得
    dtFileDate1 = Date - utParam.iKeepDays
    iErrorCount = 0

    '保存用フォルダをすべて検査する。
    For i = 1 To 4

        'フォルダが指定されているかチェック。
        If utParam.sTempPath(i) = "" Then
            GoTo Label_Continue
        End If

        'ファイルリストの取得
        iFileCount = GetFileList(utParam.sTempPath(i), sFileNames())
        If iFileCount < 0 Then
            MsgBox utParam.sTempPath(i) & " のファイルリストの取得でエラーが発生しました。", vbExclamation, sAppName
            Exit Function
        End If

        If iFileCount = 0 Then
            GoTo Label_Continue
        End If

        If utParam.iPromptDelete <> 0 Then
            'テスト用バージョンでは削除を行いません。
            If utParam.iTestFlag = 0 Then
                iRet = MsgBox(utParam.sTempPath(i) & " の " & _
                    Format(dtFileDate1 - 1, "yyyy/m/d") & _
                    " 以前のファイルを削除します。" & Chr$(10) & _
                    "(このバージョンでは実際の削除は行いません。)", _
                    vbOKCancel Or vbExclamation, sAppName)
            Else
                iRet = MsgBox(utParam.sTempPath(i) & " の " & _
                    Format(dtFileDate1 - 1, "yyyy/m/d") & _
                    " 以前のファイルを削除します。", vbOKCancel Or vbExclamation, sAppName)
                If iRet <> vbOK Then
                    GoTo Label_Continue
                End If
            End If
        End If

        For j = 1 To iFileCount

            'フルパス名の取得
            sFileName = utParam.sTempPath(i) & sFileNames(j)

            'ファイル日付の取得
            dtFileDate2 = FileDateTime(sFileName)

            '基準日より前であれば削除する。
            If dtFileDate2 < dtFileDate1 Then
                'テスト用バージョンでは削除を行いません。
                If utParam.iTestFlag = 0 Then
                    If utParam.iPromptDelete <> 0 Then
                        Debug.Print "自動保存による削除対象: " & sFileName
                    End If
                Else
                    'ファイルの削除。
                    iRet = ascDeleteFile(utParam.sTempPath(i), sFileNames(j))
                    If iRet = 0 Then
                        iErrorCount = iErrorCount + 1
                    End If
                End If
            End If
        Next
Label_Continue:
    Next

    Erase sFileNames

    If iErrorCount <> 0 Then
        MsgBox "削除できないファイルがありました。", vbExclamation, sAppName
    End If

'バックアップコピー処理
Label_BackupCopy:
    
    On Error GoTo ErrorHandler_BackupCopy

    If utParam.iBackup = 0 Then
        ascBackupCopy = 1
        Exit Function
    End If

    '保存用フォルダ1, 2のチェック
    For i = 1 To 2
        If utParam.sTempPath(i) = "" Then
            MsgBox "保存用フォルダ" & CStr(i) & "が設定されていません。", vbExclamation, sAppName
            Exit Function
        ElseIf Not DirExists(utParam.sTempPath(i)) Then
            MsgBox "保存用フォルダ" & CStr(i) & "が存在しません。", vbExclamation, sAppName
            Exit Function
        End If
    Next

    '保存用フォルダ3, 4(コピー先)のチェック
    '配列 Dirs2 に 保存用フォルダのインデックスをセットする。
    iDirCount2 = 0
    For i = 3 To 4
        If utParam.sTempPath(i) <> "" Then
            If DirExists(utParam.sTempPath(i)) Then
                iDirCount2 = iDirCount2 + 1
                iDirs2(iDirCount2) = i
            Else
                MsgBox "保存用フォルダ" & CStr(i) & "が存在しません。", vbExclamation, sAppName
                Exit Function
            End If
        End If
    Next

    If iDirCount2 = 0 Then
        MsgBox "保存用フォルダ3, 4が存在しません。", vbExclamation, sAppName
        Exit Function
    End If

    '保存用フォルダ1 のファイルリストを作成。
    iFileCount = GetFileList(utParam.sTempPath(1), sFileNames())
    If iFileCount < 0 Then
        MsgBox utParam.sTempPath(1) & " のファイル一覧取得でエラーが発生しました。", vbExclamation, sAppName
        Exit Function
    End If
    If iFileCount > 0 Then
        ReDim iDirs(1 To iFileCount)
        For i = 1 To iFileCount
            iDirs(i) = 1
        Next
    End If

    '保存用フォルダ2 のファイルをリストに追加。
    iFileCount = GetFileList2(utParam.sTempPath(2), sFileNames(), iDirs(), iFileCount, 2)
    If iFileCount < 0 Then
        MsgBox utParam.sTempPath(2) & " のファイル一覧取得でエラーが発生しました。", vbExclamation, sAppName
        Exit Function
    End If

    'ファイル日付の新しいファイルをコピー対象にする。
    For i = 1 To iFileCount
        If iDirs(i) = 3 Then
            dtFileDate1 = FileDateTime(utParam.sTempPath(1) & sFileNames(i))
            dtFileDate2 = FileDateTime(utParam.sTempPath(2) & sFileNames(i))
            If dtFileDate1 >= dtFileDate2 Then
                iDirs(i) = 1
            Else
                iDirs(i) = 2
            End If
        End If
    Next

    iErrorCount = 0

    For i = 1 To iFileCount

        'コピー元ファイルのフルパス名の取得。
        sFileName = utParam.sTempPath(iDirs(i)) & sFileNames(i)

        'ファイル日付の最小値を設定。
        dtFileDate1 = FileDateTime(sFileName)

        sFileName2 = ""
        For j = 1 To iDirCount2

            'コピー元と同名のフルパス名の取得。
            sFileName3 = utParam.sTempPath(iDirs2(j)) & sFileNames(i)

            '同名ファイルがあるかチェック。
            If Dir(sFileName3) = "" Then
                '同名ファイルがない場合は、そのフォルダへコピー。
                sFileName2 = sFileName3
                Exit For
            Else
                '同名ファイルがある場合は、ファイル日付を比較。
                dtFileDate2 = FileDateTime(sFileName3)
                If dtFileDate2 < dtFileDate1 Then
                    'ファイル日付の最小値とそのフルパス名を更新
                    dtFileDate1 = dtFileDate2
                    sFileName2 = sFileName3
                End If
            End If
        Next

        '同名ファイルがないフォルダ、または最も以前の同名ファイルへコピー。
        If sFileName2 <> "" Then
            On Error Resume Next
            FileCopy sFileName, sFileName2
            iErr = Err
            On Error GoTo ErrorHandler_BackupCopy
            If iErr <> 0 Then
                iErrorCount = iErrorCount + 1
            End If
        End If
    Next

    If iErrorCount <> 0 Then
        MsgBox "コピーできないファイルがありました。", vbExclamation, sAppName
    End If

    ascBackupCopy = 1
    Exit Function

ErrorHandler_DeleteFile:
    MsgBox Error(Err) & " (" & CStr(Err) & ")", vbExclamation, sAppName
    MsgBox "ファイルの削除でエラーが発生しました。", vbExclamation, sAppName
    Exit Function

ErrorHandler_BackupCopy:
    MsgBox Error(Err) & " (" & CStr(Err) & ")", vbExclamation, sAppName
    MsgBox "ファイルのコピーでエラーが発生しました。", vbExclamation, sAppName
    Exit Function

End Function


'ファイルを削除する関数
'
'[引数]
'sDir       :フォルダ名。(相対指定可。""の場合はエラーを返します。)
'sFileName  :ファイル名。
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Private Function ascDeleteFile(ByVal sDir As String, ByVal sFileName As String) As Integer
    ascDeleteFile = 0

    On Error GoTo ErrorHandler
    
    If Len(sDir) < 2 Then
        Exit Function
    End If

    If Len(sFileName) = 0 Then
        Exit Function
    End If

    Select Case Left(sFileName, 1)
        Case "*", "."
            Exit Function
    End Select

    sDir = AddPathSeparator(sDir)

    On Error Resume Next
    Kill sDir & sFileName
    If Err = 0 Then
        On Error GoTo 0
        ascDeleteFile = 1
    Else
        On Error GoTo 0
    End If
    Exit Function

ErrorHandler:
    Exit Function
End Function


'ファイル名一覧を作成する関数
'
'[引数]
'sDir       :フォルダ名。(相対指定可。""の場合はエラーを返します。)
'sFileNames :ファイル名一覧を格納する動的配列。
'
'[戻り値]
'0以上 : ファイル名の個数。
'-1    : エラー。

Private Function GetFileList(sDir As String, sFileNames() As String) As Integer
    Dim iCount As Integer
    Dim sFileName As String

    GetFileList = -1
    On Error GoTo ErrorHandler

    If sDir = "" Then
        Exit Function
    End If

    Erase sFileNames
    iCount = 0
    sFileName = Dir(sDir)
    Do Until sFileName = ""
        iCount = iCount + 1
        ReDim Preserve sFileNames(1 To iCount)
        sFileNames(iCount) = sFileName
        sFileName = Dir()
    Loop
    GetFileList = iCount
    Exit Function
ErrorHandler:
    Exit Function
End Function


'ファイル名一覧へ追加する関数
'
'[引数]
'sDir       : フォルダ名。(相対指定可。""の場合はエラーを返します。)
'sFileNames : ファイル名一覧を格納する動的配列。
'iDirs      : 各ファイルのフォルダインデックスを格納する動的配列。
'iUBound    : 指定された動的配列の上限。
'iParam     : 設定するフォルダインデックス。
'
'[戻り値]
'0以上 : ファイル名の個数。
'-1    : エラー。
'
'[詳細]
'既存のファイル名一覧に、指定されたフォルダのファイル名一覧を追加します。
'各ファイルのフォルダはフォルダインデックス配列 iDirs() で識別されます。
'同名のファイルがあった場合は、追加は行わずに、iDirs() に iParamの値を
'加算します。

Private Function GetFileList2(sDir As String, sFileNames() As String, iDirs() As Integer, iUBound As Integer, iParam As Integer) As Integer
    Dim sFileName As String
    Dim iCount As Integer
    Dim iFound As Integer
    Dim i As Integer

    GetFileList2 = -1
    On Error GoTo ErrorHandler

    If sDir = "" Then
        Exit Function
    End If

    iCount = iUBound
    sFileName = Dir(sDir)
    Do Until sFileName = ""
        iFound = 0
        For i = 1 To iUBound
            If StrComp(sFileNames(i), sFileName, 1) = 0 Then
                iFound = i
                Exit For
            End If
        Next
        If iFound = 0 Then
            iCount = iCount + 1
            ReDim Preserve sFileNames(1 To iCount)
            ReDim Preserve iDirs(1 To iCount)
            sFileNames(iCount) = sFileName
            iDirs(iCount) = iParam
        Else
            iDirs(iFound) = iDirs(iFound) + iParam
        End If
        sFileName = Dir()
    Loop
    GetFileList2 = iCount
    Exit Function
ErrorHandler:
    Exit Function
End Function


'INIファイルを読み取る関数
'
'[戻り値]
'0  : 正常終了。
'2  : INIファイルを新規作成した。
'-1  : エラー。
'

Private Function ascReadIniFile() As Integer
    Dim utParam As ascParameters
    Dim iRet As Long
    Dim hFile As Integer
    Dim sFileName As String
    Dim sLine As String
    Dim sValue As String
    Dim sData As String
    Dim iPos As Integer

    ascReadIniFile = -1
    On Error GoTo ErrorHandler

    sFileName = GetIniFileName()
    If Dir(sFileName) = "" Then
        utParam.iAutoSave = 0
        utParam.iFrequency = 15
        utParam.iPrompt = 1
        utParam.iPromptDelete = 1
        ascSetParameters utParam
        iRet = ascWriteIniFile()
        If iRet < 0 Then
            Exit Function
        End If
        ascReadIniFile = 2
        Exit Function
    End If

    hFile = FreeFile()
    Open sFileName For Input As #hFile
    Do While Not EOF(hFile)
        Line Input #hFile, sLine
        sLine = Trim(sLine)
        iPos = InStr(1, sLine, "=", 0)
        If iPos > 0 Then
            sValue = UCase(Trim(Left(sLine, iPos - 1)))
            sData = Trim(Mid(sLine, iPos + 1))
            Select Case sValue
                Case "AUTOSAVE"
                    utParam.iAutoSave = GetValueFromText(sData, vbInteger, 0)
                Case "FREQUENCY"
                    utParam.iFrequency = GetValueFromText(sData, vbInteger, 0)
                Case "SAVEALL"
                    utParam.iSaveAll = GetValueFromText(sData, vbInteger, 0)
                Case "PROMPT"
                    utParam.iPrompt = GetValueFromText(sData, vbInteger, 0)
                Case "SAVENEWBOOK"
                    utParam.iSaveNewBook = GetValueFromText(sData, vbInteger, 0)
                Case "BACKUP"
                    utParam.iBackup = GetValueFromText(sData, vbInteger, 0)
                Case "KEEPDAYS"
                    utParam.iKeepDays = GetValueFromText(sData, vbInteger, 0)
                Case "PROMPTDELETE"
                    utParam.iPromptDelete = GetValueFromText(sData, vbInteger, 0)
                Case "TESTFLAG"
                    utParam.iTestFlag = GetValueFromText(sData, vbInteger, 0)
                Case "PATH1"
                    utParam.sTempPath(1) = AddPathSeparator(sData)
                Case "PATH2"
                    utParam.sTempPath(2) = AddPathSeparator(sData)
                Case "PATH3"
                    utParam.sTempPath(3) = AddPathSeparator(sData)
                Case "PATH4"
                    utParam.sTempPath(4) = AddPathSeparator(sData)
            End Select
        End If
    Loop
    Close #hFile
    hFile = 0

    If ascSetParameters(utParam) = 0 Then
        Exit Function
    End If
    
    ascReadIniFile = 0
    Exit Function

ErrorHandler:
    If hFile <> 0 Then
        Close #hFile
    End If
    MsgBox "設定ファイルの読み込みでエラーが発生しました。", vbExclamation, sAppName
    Exit Function

End Function


'INIファイルを出力する関数
'
'[戻り値]
'0  : 正常終了。
'-1  : エラー。

Public Function ascWriteIniFile() As Integer
    Dim utParam As ascParameters
    Dim hFile As Integer
    Dim sFileName As String

    ascWriteIniFile = -1
    On Error GoTo ErrorHandler

    If ascGetParameters(utParam) = 0 Then
        Exit Function
    End If

    sFileName = GetIniFileName()

    hFile = FreeFile()
    Open sFileName For Output As #hFile
    Print #hFile, "[AutoSaveCopy]"
    Print #hFile, "AutoSave=" & CStr(utParam.iAutoSave)
    Print #hFile, "Frequency=" & CStr(utParam.iFrequency)
    Print #hFile, "SaveAll=" & CStr(utParam.iSaveAll)
    Print #hFile, "Prompt=" & CStr(utParam.iPrompt)
    Print #hFile, "SaveNewBook=" & CStr(utParam.iSaveNewBook)
    Print #hFile, "Backup=" & CStr(utParam.iBackup)
    Print #hFile, "KeepDays=" & CStr(utParam.iKeepDays)
    Print #hFile, "PromptDelete=" & CStr(utParam.iPromptDelete)
    If utParam.iTestFlag <> 0 Then
        Print #hFile, "TestFlag=" & CStr(utParam.iTestFlag)
    End If
    Print #hFile, "Path1=" & utParam.sTempPath(1)
    Print #hFile, "Path2=" & utParam.sTempPath(2)
    Print #hFile, "Path3=" & utParam.sTempPath(3)
    Print #hFile, "Path4=" & utParam.sTempPath(4)
    Close #hFile
    hFile = 0
    ascWriteIniFile = 0
    Exit Function

ErrorHandler:
    If hFile <> 0 Then
        Close #hFile
    End If
    MsgBox "設定ファイルの保存でエラーが発生しました。", vbExclamation, sAppName
    Exit Function

End Function


'INI ファイル名を取得する関数
'
'[戻り値]
'INI ファイル名。

Private Function GetIniFileName() As String
    Const sFileType = ".XLA"
    Dim sFileName As String
    sFileName = ThisWorkbook.FullName
    If UCase(Right(sFileName, 4)) = sFileType Then
        sFileName = Left(sFileName, Len(sFileName) - 4)
    End If
    GetIniFileName = sFileName & ".ini"
End Function


'文字列を数値(Integer)に変換する関数
'
'[引数]
'sData : 変換対象の文字列。
'iType : 変換する型。VarType関数の戻り値で指定します。
'vDefault : デフォルト値。
'
'[戻り値]
'変換結果。

Private Function GetValueFromText(ByVal sData As String, ByVal iType As Integer, ByVal vDefault As Variant) As Variant
    On Error GoTo ErrorHandler
    Select Case iType
        Case vbInteger
            GetValueFromText = CInt(sData)
        Case Else
            GetValueFromText = vDefault
    End Select
    Exit Function

ErrorHandler:
    GetValueFromText = vDefault
    Exit Function
End Function


'パス区切り文字を追加する関数
'
'[引数]
'sPath : フォルダ名。
'
'[戻り値]
'結果のフォルダ名。

Private Function AddPathSeparator(sPath As String) As String
    Dim sSeparator As String
    If sPath = "" Then
        AddPathSeparator = ""
        Exit Function
    End If
    sSeparator = Application.PathSeparator
    If Right(sPath, 1) = sSeparator Then
        AddPathSeparator = sPath
    Else
        AddPathSeparator = sPath & sSeparator
    End If
End Function


'自動保存の設定値をシートから取得する関数
'
'[引数]
'utParam   : 自動保存の設定。
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Private Function ascGetParameters(utParam As ascParameters) As Integer
    Dim oSheet As Worksheet
    ascGetParameters = 0
    On Error GoTo ErrorHandler
    Set oSheet = ThisWorkbook.Sheets("Settings")
    utParam.iAutoSave = oSheet.Range("ascAutoSave").Value
    utParam.iFrequency = oSheet.Range("ascFrequency").Value
    utParam.iSaveAll = oSheet.Range("ascSaveAll").Value
    utParam.iPrompt = oSheet.Range("ascPrompt").Value
    utParam.iSaveNewBook = oSheet.Range("ascSaveNewBook").Value
    utParam.iBackup = oSheet.Range("ascBackup").Value
    utParam.iKeepDays = oSheet.Range("ascKeepDays").Value
    utParam.iPromptDelete = oSheet.Range("ascPromptDelete").Value
    utParam.iTestFlag = oSheet.Range("ascTestFlag").Value
    utParam.sTempPath(1) = oSheet.Range("ascTempPath1").Value
    utParam.sTempPath(2) = oSheet.Range("ascTempPath2").Value
    utParam.sTempPath(3) = oSheet.Range("ascTempPath3").Value
    utParam.sTempPath(4) = oSheet.Range("ascTempPath4").Value
    ascGetParameters = 1
    Exit Function
ErrorHandler:
    MsgBox "パラメーターの取得でエラーが発生しました。", vbExclamation, sAppName
    Exit Function
End Function


'自動保存の設定値をシートへ格納する関数
'
'[引数]
'utParam   : 自動保存の設定。
'
'[戻り値]
'0 : エラー。
'1 : 正常終了。

Private Function ascSetParameters(utParam As ascParameters) As Integer
    Dim oSheet As Worksheet
    ascSetParameters = 0
    On Error GoTo ErrorHandler
    Set oSheet = ThisWorkbook.Sheets("Settings")
    oSheet.Range("ascAutoSave").Value = utParam.iAutoSave
    oSheet.Range("ascFrequency").Value = utParam.iFrequency
    oSheet.Range("ascSaveAll").Value = utParam.iAutoSave
    oSheet.Range("ascPrompt").Value = utParam.iPrompt
    oSheet.Range("ascSaveNewBook").Value = utParam.iSaveNewBook
    oSheet.Range("ascBackup").Value = utParam.iBackup
    oSheet.Range("ascKeepDays").Value = utParam.iKeepDays
    oSheet.Range("ascPromptDelete").Value = utParam.iPromptDelete
    oSheet.Range("ascTestFlag").Value = utParam.iTestFlag
    oSheet.Range("ascTempPath1").Value = "'" & utParam.sTempPath(1)
    oSheet.Range("ascTempPath2").Value = "'" & utParam.sTempPath(2)
    oSheet.Range("ascTempPath3").Value = "'" & utParam.sTempPath(3)
    oSheet.Range("ascTempPath4").Value = "'" & utParam.sTempPath(4)
    ascSetParameters = 1
    Exit Function
ErrorHandler:
    MsgBox "パラメーターの設定でエラーが発生しました。", vbExclamation, sAppName
    Exit Function
End Function


'フォルダの有無を調べる関数
'
'[引数]
'sDir :フォルダ名。(相対指定可。""の場合は False を返します。)
'
'[戻り値]
'True  : フォルダは存在する。
'False : フォルダは存在しない。

Function DirExists(ByVal sPath As String) As Boolean
    Dim sSeparator As String

    On Error GoTo ErrorHandler

    If sPath = "" Then
        DirExists = False
        Exit Function
    End If

    sSeparator = Application.PathSeparator
    If Right(sPath, 1) = sSeparator Then
        sPath = Left(sPath, Len(sPath) - 1)
    End If
    If Dir(sPath, vbDirectory) = "" Then
        DirExists = False
    Else
        DirExists = True
    End If
    Exit Function

ErrorHandler:
    DirExists = False
    Exit Function
End Function