'-----------------------------------
'Form_Mainのモジュール
'-----------------------------------
Option Compare Database
Option Explicit

Private Sub ゲージテスト開始_Click()
    Const CounterMax = 1000
    Dim cdbs As Database, rst As Recordset, Counter As Long
    On Error GoTo Err_Trap
    
    DoCmd.Hourglass True
    LsGauge "開始", CounterMax, Me
    Set cdbs = CurrentDb()
    cdbs.Execute "delete * from TestData"
    Set rst = cdbs.OpenRecordset("TestData")
    With rst
        For Counter = 1 To CounterMax
            .AddNew
            !TestData = Counter
            .Update
            LsGauge "表示", Counter, Me
        Next Counter
    End With
    LsGauge "終了", 1, Me
Exit_ゲージテスト開始_Click:
    DoCmd.Hourglass False
Exit Sub

Err_Trap:
    Resume Exit_ゲージテスト開始_Click
End Sub

'-----------------------------------
'標準モジュール
'-----------------------------------
Option Compare Database
Option Explicit

Function LsGauge(kbn As String, prm As Long, fm As Form) 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
                    !ゲージ.Width = LsGaugeLen * p / 100
                    !ゲージラベル青.Caption = Int(100 - p) & "%"
                    wWidth = !ゲージ.Left + !ゲージ.Width - !ゲージラベル青.Left
                    If wWidth > 0 Then
                        !ゲージラベル白.Caption = !ゲージラベル青.Caption
                        If wWidth <= !ゲージラベル青.Width Then !ゲージラベル白.Width = wWidth
                    End If
                    LsGauge = Int(100 - p)
                    .Repaint
                End With
                DoEvents
            End If
        End If
    Case "開始"
        wP = 100
        TalCnt = prm
        With fm
            !ゲージボックス.Visible = True
            LsGaugeLen = !ゲージボックス.Width
            !ゲージ.Width = 1
            !ゲージ.Top = !ゲージボックス.Top
            !ゲージ.Left = !ゲージボックス.Left
            !ゲージ.Height = !ゲージボックス.Height
            !ゲージ.Visible = True
            !ゲージラベル白.Width = 0
            !ゲージラベル白.Top = !ゲージラベル青.Top
            !ゲージラベル白.Left = !ゲージラベル青.Left
            !ゲージラベル白.Height = !ゲージラベル青.Height
            !ゲージラベル白.Visible = True
            !ゲージラベル青.Visible = True
            .Repaint
        End With
    Case "終了"
        With fm
            !ゲージボックス.Visible = False
            !ゲージラベル青.Visible = False
            !ゲージラベル白.Visible = False
            !ゲージ.Visible = False
            .Repaint
        End With
    End Select
Exit_LsGauge:
Exit Function

Err_Trap:
    Resume Exit_LsGauge
End Function