ShowStatusBarProgress

'ShowStatusBarProgress・・・元場所：IkiAddin.ModOther



Public Function ShowStatusBarProgress(ByRef Value As Long, _
                                   ByRef MaxValue As Long, _
                            Optional ByRef Divide As Long = 1, _
                           Optional ByRef Message As String = "") _
                                                  As String
'進行状況をステータスバーに表示する
'20220204
'20220421 経過時間、終了予定時刻なども表示可能に
'20220530 先頭にメッセージを表示可能に
'20221217 分割幅(Divide)を指定可能に
'20230219 イミディエイトウィンドウにも表示
'20250217 返り値で表示メッセージを返す
'https://www.softex-celware.com/post/showstatusbarprogress

'引数
'Value    ・・・現在個数
'MaxValue ・・・全体個数
'[Divide] ・・・分割幅(Valueが何回に1回のときにスターテスバーを更新するか)/省略なら1で毎回更新
'[Message]・・・先頭メッセージ
    
    Static StartTime As Double
    If StartTime = 0 Then
        StartTime = Now()
    End If
    
    If Value Mod Divide <> 0 Then 'Divide=10の場合、Value=1,11,21...のときのみ処理
        If Value <> MaxValue Then 'Value=MaxValueのとき(最後の位置)は処理する
            Exit Function '処理しない
        End If
    End If
    
    Dim Per           As Double: Per = Value / MaxValue                          '作業完了率
    Dim ElapsedTime   As Double: ElapsedTime = Now() - StartTime                 '経過時間
    Dim TimePerSingle As Double: TimePerSingle = ElapsedTime / Value             '1件当たり作業時間
    Dim RemainTime    As Double: RemainTime = (MaxValue - Value) * TimePerSingle '残り予定時間
    Dim FinishTime    As Double: FinishTime = RemainTime + Now()                 '終了予定時刻
        
    On Error Resume Next
    Dim strMessage As String: strMessage = Format(Per, "0.0%完了") & ", " & _
                                           Value & "/" & MaxValue & ", " & _
                                           "残り時間：" & Format(RemainTime, "h時間nn分ss秒") & ", " & _
                                           "完了予定時刻：" & Format(FinishTime, "h時nn分") & ", " & _
                                           "経過時間：" & Format(ElapsedTime, "h時nn分ss秒")
    On Error GoTo 0
                                               
'    strMessage = Message & " " & strMessage
    strMessage = strMessage & " " & Message
                                   
    Application.StatusBar = strMessage
    Debug.Print strMessage 'イミディエイトウィンドウにも表示'20230219
    DoEvents 'スターテスバー表示で固まらないようにするための処理
    
    If Value = MaxValue Then StartTime = 0
    
    ShowStatusBarProgress = strMessage
    
End Function