'ブックをまとめて開くマクロ

'新規ブックのモジュールシートに以下のマクロをコピーして
'MakeDialog()を実行後、一度ブックに名前を付けて保存します。

'BookGoup_DialogShow()を実行し、ブックグループを追加すると、
'現在開かれているブックの一覧が、マクロブック名.INIに保存されます。
'ブックグループを選択してOKボタンをクリックすると、登録された
'すべてのブックが開きます。

Option Explicit

Dim groupName() As String
Dim fileName() As String
Dim fileGroupNo() As Integer
Dim groupCount As Integer
Dim fileCount As Integer
Dim iniFileName As String

Dim procNo As Integer
Dim procParam As Variant

Const msgTitle As String = "ブックグループ"
Const dialogName As String = "Dialog1"

Private Function ReadIniFile(iniFileName As String) As Integer

    Dim fno As Integer
    Dim s As String

    On Error GoTo err_1

    groupCount = 0
    fileCount = 0

    If Dir$(iniFileName) = "" Then
        ReadIniFile = 0
        Exit Function
    End If

    fno = FreeFile()
    Open iniFileName For Input As #fno
    Do While Not EOF(fno)
        Line Input #fno, s
        s = Trim$(s)
        If StrComp(Left$(s, 6), "GROUP=") = 0 Then
            groupCount = groupCount + 1
            ReDim Preserve groupName(1 To groupCount)
            groupName(groupCount) = LTrim$(Mid$(s, 7))
        ElseIf StrComp(Left$(s, 5), "FILE=") = 0 Then
            If groupCount > 0 Then
                fileCount = fileCount + 1
                ReDim Preserve fileName(1 To fileCount)
                ReDim Preserve fileGroupNo(1 To fileCount)
                fileName(fileCount) = LTrim$(Mid$(s, 6))
                fileGroupNo(fileCount) = groupCount
            End If
        End If
    Loop
    Close #fno
    ReadIniFile = fileCount
    Exit Function
err_1:
    MsgBox Error(Err), vbExclamation, msgTitle
    ReadIniFile = -1
    Close #fno
End Function

Private Function WriteIniFile(iniFileName As String) As Integer

    Dim fno As Integer
    Dim i As Integer, j As Integer
    Dim s As String

    On Error GoTo err_1

    If Dir$(iniFileName) <> "" Then
        FileCopy iniFileName, _
            Left$(iniFileName, Len(iniFileName) - 3) & "BAK"
    End If
    fno = FreeFile()
    Open iniFileName For Output As #fno
    j = 1
    For i = 1 To groupCount
        If groupName(i) <> "" Then
            s = "GROUP=" & groupName(i)
            Print #fno, s
            Do While j <= fileCount
                If fileGroupNo(j) = i Then
                    s = "FILE=" & fileName(j)
                    Print #fno, s
                ElseIf fileGroupNo(j) > i Then
                    Exit Do
                End If
                j = j + 1
            Loop
        End If
    Next
    Close #fno
    WriteIniFile = fileCount
    Exit Function
err_1:
    MsgBox Error(Err), vbExclamation, msgTitle
    WriteIniFile = -1
    Close #fno
End Function

Sub BookGroup_DialogShow()
    Dim obj As Object
    Dim dlg1 As DialogSheet
    Dim lst1 As ListBox
    Dim i As Integer

    iniFileName = ThisWorkbook.FullName
    iniFileName = UCase$(Left(iniFileName, Len(iniFileName) - 3)) & "INI"
    Set dlg1 = ThisWorkbook.DialogSheets(dialogName)
    Set lst1 = dlg1.ListBoxes(1)

    If ReadIniFile(iniFileName) = -1 Then Exit Sub

    lst1.RemoveAllItems
    If groupCount > 0 Then
        lst1.List = groupName()
        lst1.ListIndex = 1
    End If

    procNo = 0
    Do While dlg1.Show
        Select Case procNo
            Case 1
                BookGroup_FileOpen
                Exit Do
            Case 2
                If BookGroup_Add() = 0 Then Exit Do
            Case 3
                If BookGroup_Update() = 0 Then Exit Do
            Case 4
                If BookGroup_Delete() = 0 Then Exit Do
        End Select
        procNo = 0
    Loop

    Erase groupName, fileName, fileGroupNo
    Exit Sub
err_1:
    Erase groupName, fileName, fileGroupNo
    MsgBox Error(Err), vbExclamation, ""
End Sub



Sub Dialog1_OK_Click()
    procNo = 1
    procParam = ActiveDialog.ListBoxes(1).ListIndex
End Sub

Sub Dialog1_Add_Click()
    procParam = InputBox( _
        "現在開かれているブックをメンバとする、ブックグループを追加します。" _
        & Chr$(10) & "グループ名を入力してください。", msgTitle)
    If procParam = "" Then Exit Sub
    procNo = 2
    ActiveDialog.Hide
End Sub

Sub Dialog1_Update_Click()
    procParam = ActiveDialog.ListBoxes(1).ListIndex
    If procParam < 1 Then Exit Sub
    If MsgBox(groupName(procParam) & _
        " のメンバを現在開かれているブックに更新し、再登録します。", _
        vbOKCancel Or vbExclamation, msgTitle) <> vbOK Then Exit Sub
    procNo = 3
    ActiveDialog.Hide
End Sub

Sub Dialog1_Delete_Click()
    procParam = ActiveDialog.ListBoxes(1).ListIndex
    If procParam < 1 Then Exit Sub
    If MsgBox(groupName(procParam) & " を削除します。", _
        vbOKCancel Or vbExclamation, msgTitle) <> vbOK Then Exit Sub
    procNo = 4
    ActiveDialog.Hide
End Sub

Sub Dialog1_View_Click()
    Dim s As String
    Dim i As Integer, j As Integer
    j = ActiveDialog.ListBoxes(1).ListIndex
    If j < 1 Then Exit Sub
    For i = 1 To fileCount
        If fileGroupNo(i) = j Then
            s = s & fileName(i) & Chr$(10)
        ElseIf fileGroupNo(i) > j Then
            Exit For
        End If
    Next
    MsgBox s, vbInformation, msgTitle
End Sub

Private Function BookGroup_Add() As Integer
    BookGroup_AddFile CStr(procParam)
    If BookGroup_Reset = 0 Then
        BookGroup_Add = 0
    Else
        With ThisWorkbook.DialogSheets(dialogName).ListBoxes(1)
            .ListIndex = .ListCount
        End With
        BookGroup_Add = 1
    End If
End Function

Private Function BookGroup_Update()
    Dim s As String
    s = groupName(procParam)
    groupName(procParam) = ""
    BookGroup_AddFile s
    If BookGroup_Reset = 0 Then
        BookGroup_Update = 0
    Else
        With ThisWorkbook.DialogSheets(dialogName).ListBoxes(1)
            .ListIndex = .ListCount
        End With
        BookGroup_Update = 1
    End If
End Function

Private Function BookGroup_Delete() As Integer
    Dim i As Integer
    i = procParam
    groupName(i) = ""
    If BookGroup_Reset = 0 Then
        BookGroup_Delete = 0
    Else
        With ThisWorkbook.DialogSheets(dialogName).ListBoxes(1)
            If .ListCount > 0 Then
                If i + 1 > .ListCount Then
                    .ListIndex = .ListCount
                Else
                    .ListIndex = i + 1
                End If
            End If
        End With
        BookGroup_Delete = 1
    End If
End Function

Private Function BookGroup_Reset() As Integer
    If WriteIniFile(iniFileName) = -1 Then
        BookGroup_Reset = 0
    ElseIf ReadIniFile(iniFileName) = -1 Then
        BookGroup_Reset = 0
    Else
        With ThisWorkbook.DialogSheets(dialogName).ListBoxes(1)
            .RemoveAllItems
            If groupCount > 0 Then
                .List = groupName()
                .ListIndex = 1
            End If
        End With
        BookGroup_Reset = 1
    End If
End Function

Private Sub BookGroup_AddFile(s As String)
    Dim obj As Object
    groupCount = groupCount + 1
    ReDim Preserve groupName(1 To groupCount)
    groupName(groupCount) = s
    For Each obj In Workbooks
        If StrComp(obj.Name, ThisWorkbook.Name, 1) <> 0 _
                And StrComp(obj.Name, "PERSONAL.XLS", 1) <> 0 _
                And (obj.Path <> "") Then
            fileCount = fileCount + 1
            ReDim Preserve fileName(1 To fileCount)
            ReDim Preserve fileGroupNo(1 To fileCount)
            fileName(fileCount) = obj.FullName
            fileGroupNo(fileCount) = groupCount
        End If
    Next
End Sub

Private Sub BookGroup_FileOpen()
    Dim i As Integer, j As Integer
    On Error GoTo err_1
    j = procParam
    For i = 1 To fileCount
        If fileGroupNo(i) = j Then
            Workbooks.Open(fileName(i)).RunAutoMacros xlAutoOpen
        ElseIf fileGroupNo(i) > j Then
            Exit For
        End If
    Next
    Exit Sub
err_1:
    MsgBox Error(Err), vbExclamation, msgTitle
    Resume Next
End Sub


Sub MakeDialog()
    Dim dlg As DialogSheet
    Dim gw As Double
    Set dlg = DialogSheets.Add
    With dlg
        .Name = "Dialog1"
        gw = .Buttons(1).Height / 3
        .DialogFrame.Left = gw * 13
        .DialogFrame.Top = gw * 4
        .DialogFrame.Width = gw * 50
        .DialogFrame.Height = gw * 28
        .DialogFrame.Caption = "ブックグループを開く"
        .DrawingObjects.Delete
    End With
    With dlg.Labels.Add(Left:=gw * 14, Top:=gw * 8, _
            Width:=gw * 37, Height:=gw * 3)
        .Caption = "ブックグループを選択してください。"
    End With
    With dlg.ListBoxes.Add(Left:=gw * 14, Top:=gw * 12, _
            Width:=gw * 37, Height:=gw * 19)
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 8, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "OK"
        .OnAction = "Dialog1_OK_Click"
        .DismissButton = True
        .CancelButton = False
        .DefaultButton = True
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 12, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = StrConv("キャンセル", vbNarrow)
        .CancelButton = True
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 16, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "追加"
        .OnAction = "Dialog1_Add_Click"
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 20, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "更新"
        .OnAction = "Dialog1_Update_Click"
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 24, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "削除"
        .OnAction = "Dialog1_Delete_Click"
    End With
    With dlg.Buttons.Add(Left:=gw * 52, Top:=gw * 28, _
            Width:=gw * 10, Height:=gw * 3)
        .Caption = "表示"
        .OnAction = "Dialog1_View_Click"
    End With
End Sub