28

Microsoft Access 2010でクエリを実行していますが、正常に実行するには30分以上かかります。エンドユーザーにクエリのステータスを提示したいと思います。プログレスバーは便利ですが、必須ではありません。アクセスのスレッド化が不十分で、クエリの実行中にしっかりとロックされ、試行した更新が無効になっているようです。VSを作成して、これを行うために独自のアプリを作成したいのですが、Accessを使用せざるを得ません。

以前はデータベースにデータを入力するバッチスクリプトからこれを実行していましたが、すべてをAccessに自己完結させたいと考えています。具体的には、「クエリ」は実際には一連のホストにpingを実行するVBAスクリプトです。したがって、時間自体を最適化することについてはあまり心配していませんが、単に時間がロックされていないことをエンドユーザーに知らせることについては心配しています。

4

7 に答える 7

36

私はよくこのようなことをします

Dim n As Long, db As DAO.Database, rs As DAO.Recordset

'Show the hour glass
DoCmd.Hourglass True

Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ...")

rs.MoveLast 'Needed to get the accurate number of records

'Show the progress bar
SysCmd acSysCmdInitMeter, "working...", rs.RecordCount

rs.MoveFirst
Do Until rs.EOF
    'Do the work here ...

    'Update the progress bar
    n = n + 1
    SysCmd acSysCmdUpdateMeter, n

    'Keep the application responding (optional)
    DoEvents

    rs.MoveNext
Loop
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing

'Remove the progress bar
SysCmd acSysCmdRemoveMeter

'Show the normal cursor again
DoCmd.Hourglass False

注:もちろん、これを機能させるには、プログラムで作業を行う必要があります。Accessのコードなどで実行中のクエリを監視することはできません。おそらく、プログレスバーを更新する機会を得るために、遅いクエリの作業を小さな部分に分割することができます。ただし、砂時計はいつでも表示できます。これは、何かが起こっていることをユーザーに通知します。

于 2012-08-14T16:52:33.893 に答える
25

他の人がこれが役に立つと思うかもしれない場合のために、ここに私がこの目的のために書いたクラスがあります。私はAccess開発プロジェクトでいつもそれを使用しています。と呼ばれるクラスモジュールのプロジェクトにドロップし、次のclsLblProgように使用します。

ここに画像の説明を入力してください

これにより、小さなプログレスバーが生成されます。

ここに画像の説明を入力してください

フォームに必要なのは3つのラベルだけです。バックラベルを希望のサイズに設定し、他の2つを非表示にします。残りはクラスが行います。

ここに画像の説明を入力してください

そしてここにのコードがありますclsLblProg

Option Compare Database
Option Explicit

' By Adam Waller
' Last Modified:  12/16/05

'Private Const sngOffset As Single = 1.5    ' For Excel
Private Const sngOffset As Single = 15      ' For Access

Private mdblMax As Double   ' max value of progress bar
Private mdblVal As Double   ' current value of progress bar
Private mdblFullWidth As Double ' width of front label at 100%
Private mdblIncSize As Double
Private mblnHideCap As Boolean  ' display percent complete
Private mobjParent As Object    ' parent of back label
Private mlblBack As Access.Label     ' existing label for back
Private mlblFront As Access.Label   ' label created for front
Private mlblCaption As Access.Label ' progress bar caption
Private mdteLastUpdate As Date      ' Time last updated
Private mblnNotSmooth As Boolean    ' Display smooth bar by doevents after every update.

' This class displays a progress bar created
' from 3 labels.
' to use, just add a label to your form,
' and use this back label to position the
' progress bar.

Public Sub Initialize(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label)

    On Error GoTo 0    ' Debug Mode


    Dim objParent As Object ' could be a form or tab control
    Dim frm As Form

    Set mobjParent = BackLabel.Parent
    ' set private variables
    Set mlblBack = BackLabel
    Set mlblFront = FrontLabel
    Set mlblCaption = CaptionLabel

    ' set properties for back label
    With mlblBack
        .Visible = True
        .SpecialEffect = 2  ' sunken. Seems to lose when not visible.
    End With

    ' set properties for front label
    With mlblFront
        mdblFullWidth = mlblBack.Width - (sngOffset * 2)
        .Left = mlblBack.Left + sngOffset
        .Top = mlblBack.Top + sngOffset
        .Width = 0
        .Height = mlblBack.Height - (sngOffset * 2)
        .Caption = ""
        .BackColor = 8388608
        .BackStyle = 1
        .Visible = True
    End With

    ' set properties for caption label
    With mlblCaption
        .Left = mlblBack.Left + 2
        .Top = mlblBack.Top + 2
        .Width = mlblBack.Width - 4
        .Height = mlblBack.Height - 4
        .TextAlign = 2 'fmTextAlignCenter
        .BackStyle = 0 'fmBackStyleTransparent
        .Caption = "0%"
        .Visible = Not Me.HideCaption
        .ForeColor = 16777215   ' white
    End With
    'Stop

    Exit Sub

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Initialize", Erl
            Resume Next ' Resume at next line.
    End Select

End Sub

Private Sub Class_Terminate()

    On Error GoTo 0    ' Debug Mode

    On Error Resume Next
    mlblFront.Visible = False
    mlblCaption.Visible = False
    On Error GoTo 0    ' Debug Mode

    Exit Sub

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Class_Terminate", Erl
            Resume Next ' Resume at next line.
    End Select

End Sub

Public Property Get Max() As Double

    On Error GoTo 0    ' Debug Mode

    Max = mdblMax

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Max", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Let Max(ByVal dblMax As Double)

    On Error GoTo 0    ' Debug Mode

    mdblMax = dblMax

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Max", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Get Value() As Double

    On Error GoTo 0    ' Debug Mode

    Value = mdblVal

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Value", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Let Value(ByVal dblVal As Double)

    On Error GoTo 0    ' Debug Mode

    'update only if change is => 1%
    If (CInt(dblVal * (100 / mdblMax))) > (CInt(mdblVal * (100 / mdblMax))) Then
        mdblVal = dblVal
        Update
    Else
        mdblVal = dblVal
    End If

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Value", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Get IncrementSize() As Double

    On Error GoTo 0    ' Debug Mode

    IncrementSize = mdblIncSize

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "IncrementSize", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Let IncrementSize(ByVal dblSize As Double)

    On Error GoTo 0    ' Debug Mode

    mdblIncSize = dblSize

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "IncrementSize", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Get HideCaption() As Boolean

    On Error GoTo 0    ' Debug Mode

    HideCaption = mblnHideCap

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "HideCaption", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Public Property Let HideCaption(ByVal blnHide As Boolean)

    On Error GoTo 0    ' Debug Mode

    mblnHideCap = blnHide

    Exit Property

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "HideCaption", Erl
            Resume Next ' Resume at next line.
    End Select

End Property

Private Sub Update()

    On Error GoTo 0    ' Debug Mode

    Dim intPercent As Integer
    Dim dblWidth As Double
    'On Error Resume Next
    intPercent = mdblVal * (100 / mdblMax)
    dblWidth = mdblVal * (mdblFullWidth / mdblMax)
    mlblFront.Width = dblWidth
    mlblCaption.Caption = intPercent & "%"
    'mlblFront.Parent.Repaint    ' may not be needed

    ' Use white or black, depending on progress
    If Me.Value > (Me.Max / 2) Then
        mlblCaption.ForeColor = 16777215   ' white
    Else
        mlblCaption.ForeColor = 0  ' black
    End If

    If mblnNotSmooth Then
        If mdteLastUpdate <> Now Then
            ' update every second.
            DoEvents
            mdteLastUpdate = Now
        End If
    Else
        DoEvents
    End If

    Exit Sub

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Update", Erl
            Resume Next ' Resume at next line.
    End Select

End Sub

Public Sub Increment()

    On Error GoTo 0    ' Debug Mode

    Dim dblVal As Double
    dblVal = Me.Value
    If dblVal < Me.Max Then
        Me.Value = dblVal + 1
        'Call Update
    End If

    Exit Sub

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Increment", Erl
            Resume Next ' Resume at next line.
    End Select

End Sub

Public Sub Clear()

    On Error GoTo 0    ' Debug Mode

    Call Class_Terminate

    Exit Sub

ErrHandler:

    Select Case Err.Number
        Case Else
            LogErr Err, "clsLblProg", "Clear", Erl
            Resume Next ' Resume at next line.
    End Select

End Sub

Private Function ParentForm(ctlControl As Control) As String

    ' returns the name of the parent form
    Dim objParent As Object

    Set objParent = ctlControl

    Do While Not TypeOf objParent Is Form
       Set objParent = objParent.Parent
    Loop

    ' Now we should have the parent form
    ParentForm = objParent.Name

End Function

Public Property Get Smooth() As Boolean
    ' Display the progress bar smoothly.
    ' True by default, this property allows the call
    ' to doevents after every increment.
    ' If False, it will only update once per second.
    ' (This may increase speed for fast progresses.)
    '
    ' negative to set default to true
    Smooth = mblnNotSmooth
End Property

Public Property Let Smooth(ByVal IsSmooth As Boolean)
    mblnNotSmooth = Not IsSmooth
End Property

Private Sub LogErr(objErr, strMod, strProc, intLine)
    ' For future use.
End Sub
于 2015-01-30T20:34:15.627 に答える
4

将来の読者のために、上記のコレクションに私の部分を追加するだけです。

あなたがより少ないコードと多分クールなUIを求めているなら。私のGitHubforProgressbarforVBAをチェックしてください ここに画像の説明を入力してください

カスタマイズ可能なもの:

ここに画像の説明を入力してください

DllはMS-Access用と考えられていますが、マイナーな変更を加えるだけですべてのVBAプラットフォームで機能するはずです。すべてのコードはサンプルデータベースにあります。

このプロジェクトは現在開発中であり、すべてのエラーがカバーされているわけではありません。だから、いくつか期待してください!

サードパーティのdllについて心配する必要があります。心配している場合は、dllを実装する前に、信頼できるオンラインアンチウイルスを自由に使用してください。

于 2018-05-08T16:41:34.960 に答える
2

使用可能なコントロールに問題があるため、2つの長方形を使用して自家製のプログレスバーを作成しました。境界線、および物事が進むにつれてサイズが変更される実線のバー。境界線の前にある進行状況の長方形。使用するには

If pbar Is Nothing Then
    Set pbar = New pBar_sub
    pbar.init Me.Progressbar_border, Me.ProgressBar_Bar
End If
pbar.value = 0
pbar.show
pbar.max = 145 ' number of interations
...
...
Do While Not recset.EOF
    count = count + 1
    pbar.value = count
'   get next 
    recset.MoveNext
Loop

ステータスラインを、処理中の要素を通知するプログレスバーに関連付けることができます。のように:123。地区どこか、販売代理店WhomEver

========プログレスバーの代替pBar_sub==============

Option Compare Database
Option Explicit

Dim position    As Long
Dim maximum     As Long
Dim increment   As Single
Dim border      As Object
Dim bar         As Object

Sub init(rect As Object, b As Object)
    Set border = rect
    Set bar = b
    bar.width = 0
    hide
End Sub
Sub hide()
    bar.visible = False
    border.visible = False
End Sub
Sub show()
    bar.visible = True
    border.visible = True
End Sub
Property Get Max() As Integer
    Max = maximum
End Property
Property Let Max(val As Integer)
    maximum = val
    increment = border.width / val
End Property
Property Get value() As Integer
    value = position
End Property
Property Let value(val As Integer)
    position = val
    bar.width = increment * value
End Property
于 2013-10-04T09:39:45.893 に答える
1

プログレスバー(acSysCmdUpdateMeter)を更新した後、コマンドDoEventsを使用します。

レコード数が多い場合は、アプリケーションの速度が少し低下するため、x回ごとにDoEventsを実行するだけです。

于 2014-04-29T09:44:51.527 に答える
0

これは専門的な方法ではありませんが、必要に応じて適用できます。フォームを使用している場合便利な場所に小さなテキストボックスをデフォルトで緑色にすることができます。

テキストボックスの名前が、であるとするとTxtProcessing
プロパティは次のようになります。

Name : TxtProcessing
Visible : Yes
Back color : Green
Locked: Yes
Enter Key Behavior : Default

1)VBスクリプトMe.TxtProcessing.BackColor = vbRedに、赤で表示されるものを入力できます。これは、処理中のタスクを示します。
2)スクリプトのすべてのセットを書くことができます
3)最後に置くことができますMe.TxtProcessing.BackColor = vbGreen

Me.TxtProcessing.BackColor = vbRed
Me.TxtProcessing.SetFocus
Me.Refresh

Your Code here.....

Me.TxtProcessing.BackColor = vbGreen
Me.TxtProcessing.SetFocus

:-)面白いですが、目的は達成されています。

于 2014-02-18T12:02:15.000 に答える
-2

最初にMSAccessフォームでプログレッシブバーコントロールをドラッグしてから、のようにプログレッシブバーの名前を変更しますaa

次に、コードform propertyのタイマーでに移動します:write

me.aa.value=me.aa.value+20

選択に応じて時間間隔300。フォームを実行すると、プログレッシブバーが表示されます

于 2014-09-06T08:45:28.400 に答える