Set2-ZZZ

2023.09.19

Bace Procedure Set 2（実行時間記入）

  1. 下記ボックス内をコピーし、標準モジュールに貼り付ける。
  2. モジュール名を【ZZZ_BasePros 】に変更する。
  3. 利用時には使用する標準モジュールにプロシージャをコピーし、☆☆☆、★★★、●●● 等の記号は、【Ctrl】+【H】で、適宜プロシージャー名を変更し、使用する。
　Module : ZZZ_BasePros 　　‘開発時使用モジュール
Option Explicit

Public IsCall As Boolean
Public ErrProsName As String

'====================================================
'   Main Sub  
'====================================================
Sub ☆☆☆()

    Dim myMsg As String
    Dim myProcd As String
    Dim shtName As String
    Dim strRng As String
    Dim sttTime As Date
    Dim endTime As Date
    Dim exeTime As Date
    
    ErrProsName = "☆☆☆"
    On Error GoTo ☆☆☆_Err
   
    Application.StatusBar = " ～～中"
    
    myProcd = "Main処理"
    shtName = "shtName"
    strRng = "B2"
    
    sttTime = Now()
    
    ''【shtName】シート セルB2 に開始時間記入
    'Call InputSttSht(shtName, strRng, myProcd)
    
    Call StopUpdating
    Call SetObject
    
    
    
    endTime = Now()
    exeTime = endTime - sttTime
    '【Main】シート 作業終了時間記入
    Call InputEnd("H8", exeTime)
    ''【shtName】シート セルB2 に作業終了時間記入
    'Call InputEndSht(shtName, "B2", myProcd, exeTime)

    ''    IsCall = True
    ''    Call ★★★
    ''    IsCall = False
    
    MsgBox " 完了♪"

☆☆☆_Exit:

    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub

☆☆☆_Err:

    endTime = Now()
    exeTime = endTime - sttTime
    '【ESC】で止められた場合
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            '実行中のマクロに戻る
            Resume
        Else
            Call exeBreak
            Err.Clear       'エラー情報クリア
            On Error GoTo ☆☆☆_Err
        End If

    'その他のエラー
    Else
        MsgBox "実行時エラー:" & Err.Nuer & "" & _
            Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, ErrProsName
            ''【Main】シート エラー日時記入
        Call exeBreak
        Call InputErr("H8")
        ''エラー日時記入
        Call InputErrShtEnd(shtName, strRng, myProcd)
        Err.Clear       'エラー情報クリア
        On Error GoTo ☆☆☆_Err
    End If
    
End Sub
'-----------------------------------------------------------------------
'   Call Sub    Callされる
'-----------------------------------------------------------------------
Sub ★★★()

    Dim myMsg As String
    Dim myProcd As String
    Dim shtName As String
    Dim strRng As String
    Dim sttTime As Date
    Dim endTime As Date
    Dim exeTime As Date
    
    ErrProsName = "★★★"
    On Error GoTo ★★★_Err
   
    Application.StatusBar = " ～～中"
     If Bln_Err = False Then
        If IsCall = False Then
            myProcd = "Main処理"
            shtName = "shtName"
            strRng = "B2"
            
            sttTime = Now()
            
            ''【shtName】シート”セルB2 に開始時間記入
            'Call InputSttSht(shtName, strRng, myProcd)
            
            Call StopUpdating
            Call SetObject
        End If
        
        MsgBox " 完了♪"
    End If

★★★_Exit:

    'エラーを無視
    On Error Resume Next
    If IsCall = False Then
        Call ReSetObject
        Call Updating
    
        endTime = Now()
        exeTime = endTime - sttTime
        '【Main】シート 作業終了時間記入
        Call InputErr("H8")
        ''【shtName】シート セルB2 に作業終了時間記入
        'Call InputEndSht(shtName, "B2", myProcd, exeTime)
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub

★★★_Err:

    Bln_Err = True
    endTime = Now()
    exeTime = endTime - sttTime
    
    '【ESC】で止められた場合
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            Resume
        Else
            Call exeBreak
            ''メッセージ欄 を空白にする
            'Call InputResume(shtName, strRng)
            Err.Clear       'エラー情報クリア
            GoTo ★★★_Exit
        End If

    'その他のエラー
    Else
        MsgBox "実行時エラー:" & Err.Nuer & "" & _
            Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, ErrProsName
            '【Main】シート エラー日時記入
        Call exeBreak
        Call InputErr(strRng)
        ''エラー日時記入
        'Call InputErrShtEnd(shtName, strRng, myProcd)
        Err.Clear       'エラー情報クリア
        GoTo ★★★_Exit
    End If
End Sub
'-----------------------------------------------------------------------
'   Midi Call Sub   CallされCallする
'-----------------------------------------------------------------------
Sub ●●●()
    Dim BlnCall As Boolean    'このプロシージャー内で宣言

    Dim myMsg As String
    Dim myProcd As String
    Dim shtName As String
    Dim strRng As String
    Dim sttTime As Date
    Dim endTime As Date
    Dim exeTime As Date
    
    ErrProsName = "●●●"
    On Error GoTo ●●●_Err
   
    Application.StatusBar = " ～～中"
    If Bln_Err = False Then
        If IsCall = False Then
            myProcd = "Main処理"
            shtName = "shtName"
            strRng = "B2"
            
            sttTime = Now()
            
            ''【shtName】シート”セルB2 に開始時間記入
            'Call InputSttSht(shtName, strRng, myProcd)
            
            Call StopUpdating
            Call SetObject
        Else
            BlnCall = True
        End If

        
    ''    BlnCall = True
    ''    Call ●●●2
    ''    BlnCall = False
    
 
        MsgBox " 完了♪"
    End If

●●●_Exit:

    'エラーを無視
    On Error Resume Next
    If IsCall = False Then
        Call ReSetObject
        Call Updating
    
        endTime = Now()
        exeTime = endTime - sttTime
        '【Main】シート 作業終了時間記入
        Call InputEnd("H8", exeTime)
        ''【shtName】シート セルB2 に作業終了時間記入
        'Call InputEndSht(shtName, "B2", myProcd, exeTime)
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub

●●●_Err:

    Bln_Err = True
    endTime = Now()
    exeTime = endTime - sttTime
    
    '【ESC】で止められた場合
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            Call exeBreak
            ''メッセージ欄 を空白にする
            'Call InputResume(shtName, strRng)
            Resume
        End If
    'その他のエラー
    Else
        MsgBox "実行時エラー:" & Err.Nuer & "" & _
            Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, ErrProsName
        Call exeBreak
        '【Main】シート エラー日時記入
        Call InputErr("H8")
        ''エラー日時記入
        'Call InputErrShtEnd(shtName, strRng, myProcd)
    End If

    Resume
    GoTo ●●●_Exit

End Sub

 

 

コメント

タイトルとURLをコピーしました