G-Tool2-Form-M01_WS比較用

Option Explicit
Private ErrProsName As String

'================================================
'    ファイルを読み取りリンク更新なしで開く
'================================================
Sub openFile()
    Dim FilePath As String
    Dim fName As String
    Dim bookName As String
    Dim IsOpen As Boolean
    Dim wb As Workbook
    Dim OpenBook As Workbook
    Dim i As Long
    
    On Error GoTo openFile_Err
    
    Call SetObject
    Call StopUpdating
    
    IsOpen = False
    
    '指定ファイルを開く
    With wsComp

        If Application.Caller = "開く１" Then
            FilePath = .Range("E8").Value
            fName = "比較ファイル①"
        ElseIf Application.Caller = "開く２" Then
            FilePath = Range("E10").Value
            fName = "比較ファイル② "
        End If
        
        If FilePath = "" Then
            MsgBox fName & "ファイルパスを確認して下さい｡ " & vbCr & _
                "処理を終了します｡", vbExclamation
            GoTo openFile_Exit
        End If
    End With
    

    For Each wb In Workbooks
        If wb.Name = bookName Then
            IsOpen = True
            Exit For
        End If
    Next wb
    
    If IsOpen Then
        MsgBox fName & ": 同名ファイルを既に開いています｡ " & vbCr & _
            "処理を終了します｡", vbExclamation
        GoTo openFile_Exit
    End If
        
    If IsBookOpened(FilePath) Then
        MsgBox fName & ": 他のPCで開かれていますが､" & vbCr & _
            "読み取りで開きます｡", vbExclamation
    End If
    '読み取り、リンク更新なしで開く
    Set OpenBook = Workbooks.Open(FilePath, ReadOnly:=True, UpdateLinks:=0)
    On Error Resume Next
    '開いたファイル
    With OpenBook
        For i = .Worksheets.Count To 1 Step -1
            '最初に再計算が走らないように全シート設定
            .Worksheets(i).EnableCalculation = False
        Next i
    End With
    'エラー制御を戻す
    On Error GoTo 0
        
openFile_Exit:
    On Error Resume Next
    Call ReSetObject
    Call Updating
    Exit Sub
openFile_Err:
    '【ESC】で止められた場合
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            DoEvents
            Resume
        End If
    'その他のエラー
    Else
        MsgBox "実行時エラー：" & Err.Number & "" & _
            Err.Description & vbCr & _
            "処理を終了します。", vbExclamation
    End If
    Resume openFile_Exit:
End Sub
'================================================
'    【保存して閉じる】ボタン押下で作動
'     実行ファイル以外の開いているファイルに
'     対して実行
'================================================
Sub exeSaveClose()
    Dim i As Long
    Dim ii As Long
    Dim MaxRow As Long
    Dim buf As String
    Dim Cnt As Long
    Dim wb As Workbook
    Dim FilePath As String
    Dim fName As String
    Dim bookName As String
    Dim myWbName As String
    Dim strRng As String
    
    Dim myProcd As String

    ErrProsName = "exeSaveClose"
    On Error GoTo exeSaveClose_Err
    
    myProcd = "【保存して閉じる】"
    Application.StatusBar = "保存後ブックを閉じています。"
    
    Call SetObject
    Call StopUpdating
    
    '指定ファイルを開じる
    With wsComp
        If Application.Caller = "保存１" Then
            FilePath = .Range("E8").Value
            strRng = "L8"
            fName = "比較ファイル①"
        ElseIf Application.Caller = "保存２" Then
             FilePath = .Range("E10").Value
            strRng = "L10"
            fName = "比較ファイル②"
        End If
        
    End With

    FilePath = Replace(FilePath, " /", "\")
    bookName = Mid(FilePath, InStrRev(FilePath, "*") + 1)
    
    If IsBookOpened(FilePath) Then
        MsgBox fName & " : 他のPCで開かれていますので、" & vbCr & _
                        "処理を終了します。", vbExclamation
        GoTo exeSaveClose_Exit
    End If
    
    myWbName = ThisWorkbook.Name

    Call showStatus("更新して保存中")
    
    For Each wb In Workbooks
        '実行ファイル以外の開いているファイルの場合
        If wb.Name = bookName Then
            'エラーを無視
            On Error Resume Next
            With wb
                '読み取り設定の場合
                If .ReadOnly Then
                    '編集可能な設定に変更
                    .ChangeFileAccess Mode:=xlReadWrite
                End If
                .Save
                .Close
            End With
            'エラー制御を戻す
            On Error GoTo 0
        End If
    Next wb

    ThisWorkbook.Activate
    With wsComp
        .Range(strRng).Value = FileDateTime(FilePath)
    End With
    
    DoEvents
    MsgBox "完了♪"
    
exeSaveClose_Exit:
    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
exeSaveClose_Err:
    '【ESC】で止められた場合
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            DoEvents
            Resume
        End If
    'その他のエラー
    Else
        Bln_Err = True
        MsgBox "実行時エラー:" & Err.Nuer & "" & _
            Err.Description & vbCr & _
            "処理を終了します。", vbExclamation, ErrProsName
    End If
    Resume exeSaveClose_Exit:
End Sub
'ファイルが開かれているかチェック
'filecheckは「フルパス」を設定
Public Function IsBookOpened(filecheck As String) As Boolean
    IsBookOpened = False
    If filecheck = "" Then
        IsBookOpened = False
    Else
        On Error Resume Next
        '保存済みのファイルか判定
        Open filecheck For Append As #1
        Close #1
        
        If Err.Number > 0 Then
            '既に開かれている場合
            IsBookOpened = True
        Else
            '開かれていない場合
            IsBookOpened = False
        End If
    End If
    On Error GoTo 0
End Function