'Userform-------------------------
Option Explicit
'Controlは背面から前面へ次の順に配置してください
'GaugeBoxW
'GaugeBoxB
'GaugeTxtB
'GaugeTxtW
'＊GaugeTxtBとGaugeTxtWをLabelにすると中間点で白の数字がうまく表示されません。

Private Sub CommandButton1_Click()
    Const CounterMax = 1000
    Dim Counter As Long
    Dim cc As Long
    On Error GoTo Err_Trap
    
    Me.MousePointer = fmMousePointerHourGlass
    LsGauge "開始", CounterMax, Me
    For Counter = 1 To CounterMax
        For cc = 1 To 5000
        Next cc
        LsGauge "表示", Counter, Me
    Next Counter
Exit_GaugeBoxW_Click:
    LsGauge "終了", 1, Me
    Me.MousePointer = fmMousePointerDefault
Exit Sub
Err_Trap:
    Resume Exit_GaugeBoxW_Click
End Sub

'Module1-------------------------
Option Explicit

Function LsGauge(kbn As String, prm As Long, fm As Object) As Long
    Static LsGaugeLen As Long, wP As Long, TalCnt As Long
    Dim strSeq As String, p As Single, wWidth As Single
    
    Select Case kbn
    Case "表示"
        p = (prm / TalCnt) * 100
        If wP > Int(100 - p) Then
            If Int(100 - p) >= 0 Then
                With fm
                    !GaugeBoxB.Width = LsGaugeLen * p / 100
                    !GaugeTxtB.Text = Int(100 - p) & "%"
                    wWidth = !GaugeBoxB.Left + !GaugeBoxB.Width - !GaugeTxtB.Left + 0.5
                    If wWidth > 0 Then
                        !GaugeTxtW.Text = Int(100 - p) & "%"
                        If wWidth <= !GaugeTxtB.Width Then !GaugeTxtW.Width = wWidth
                    End If
                    LsGauge = Int(100 - p)
                    .Repaint
                End With
                DoEvents
            End If
        End If
    Case "開始"
        'Controlは背面から前面へ次の順に配置してください
        'GaugeBoxW
        'GaugeBoxB
        'GaugeTxtB
        'GaugeTxtW
        '＊GaugeTxtBとGaugeTxtWをLabelにすると中間点で白の数字がうまく表示されません。
        wP = 100
        TalCnt = prm
        With fm
            !GaugeBoxW.Visible = True
            LsGaugeLen = !GaugeBoxW.Width - 1
            !GaugeBoxB.Width = 0
            !GaugeBoxB.Top = !GaugeBoxW.Top + 0.5
            !GaugeBoxB.Left = !GaugeBoxW.Left + 0.5
            !GaugeBoxB.Height = !GaugeBoxW.Height - 2
            !GaugeBoxB.Visible = True
            !GaugeTxtW.Width = 0
            !GaugeTxtW.Top = !GaugeTxtB.Top
            !GaugeTxtW.Left = !GaugeTxtB.Left
            !GaugeTxtW.Height = !GaugeTxtB.Height
            !GaugeTxtW.Visible = True
            !GaugeTxtB.Visible = True
            .Repaint
        End With
    Case "終了"
        With fm
            !GaugeBoxW.Visible = False
            !GaugeTxtB.Visible = False
            !GaugeTxtW.Visible = False
            !GaugeBoxB.Visible = False
            .Repaint
        End With
    End Select
Exit_LsGauge:
Exit Function

Err_Trap:
    Resume Exit_LsGauge
End Function