Pytanie Pasek postępu w MS Access


Mam kwerendę uruchomioną w programie Microsoft Access 2010 i normalnie działa ponad 30 minut. Chciałbym przedstawić użytkownikowi końcowemu pewien status zapytania. Pasek postępu byłby miły, ale nie wymagany. Dostęp wydaje się być słabo gwintowany i blokuje się podczas wykonywania zapytania negującego wszelkie aktualizacje, które próbuję. Chociaż wolę pobić VS i napisać własną aplikację, aby to zrobić, jestem zmuszony korzystać z Access.

Jakieś pomysły?

EDYTOWAĆ

Zwykłem uruchamiać to ze skryptu wsadowego, który zapełniał bazę danych, ale chciałbym, aby wszystko było zawarte w Access. Mówiąc dokładniej, "zapytanie" to tak naprawdę skrypt VBA, który wywołuje serię hostów. Nie martwię się więc o optymalizację czasu per se, ale po prostu niech użytkownik końcowy wie, że nie został zablokowany.


21
2017-08-14 16:35


pochodzenie


Jak przypominam, Access zaczyna mieć problemy z średniej wielkości bazami danych (~ 100 000 rekordów). - Woot4Moo
Jest szansa, że ​​zapytanie może zostać przyspieszone, jeśli publikujesz sql. 30 minut jest niezwykłe. - Fionnuala
@ Woot4Moo Masz na myśli daleką przeszłość. Każda baza danych ma problemy, jeśli nie może korzystać z indeksów, na przykład. Dostęp jest w porządku z zaledwie 100 000 rekordów, chyba że są to naprawdę bardzo duże rekordy. - Fionnuala
Tak, Remou. Proszę pokazać nam swoje zapytanie Menefee! - Olivier Jacot-Descombes
Nie można dodać paska postępu do procesu uruchamiania pojedynczego zapytania, ponieważ jest to akcja "atomowa" w programie Access. BTW, optymalizacja może czasami być również wykonana poprzez podzielenie dużego zapytania na kilka mniejszych zapytań, co może w sumie wymagać mniej pamięci. - Christoph Jüngling


Odpowiedzi:


Często robię coś takiego

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

Uwaga: Oczywiście program musi działać programowo, aby to działało. Nie można oglądać zapytania w kodzie lub tym podobnych w programie Access. Możliwe, że podzielisz pracę powolnego zapytania na mniejsze fragmenty, aby mieć szansę na aktualizację paska postępu. Ale zawsze możesz pokazać klepsydrę; to mówi użytkownikowi, że coś się dzieje.


25
2017-08-14 16:52



I myślę, że to jest właśnie problem. Chciałbym znać postęp bieżącego zapytania, ale silnik JET DB nie aktualizuje wątku nadrzędnego, więc wydaje się to niemożliwe. Mam nadzieję, że się mylę ... - Menefee
Nie, niestety masz rację. Może ktoś może ulepszyć twoje zapytanie, jeśli pokazujesz SQL. - Olivier Jacot-Descombes
Jeśli zapytanie dotyczy dużej liczby wierszy, możesz ulepszyć tę metodę za pomocą bufora transakcji i zatwierdzić zmianę zestawu rekordów tylko raz na końcu. - Matt Donnan


Jeśli inni mogą uznać to za przydatne, oto klasa, którą napisałem w tym celu. Używam go cały czas w moich projektach rozwojowych Access. Po prostu prześlij go do swojego projektu w module klasy o nazwie clsLblProgi użyj tego tak:

enter image description here

Tworzy to ładny mały pasek postępu:

enter image description here

W formularzu potrzebujesz tylko trzech etykiet. Ustaw tylną etykietę na żądany rozmiar i pozostaw pozostałe dwa ukryte. Klasa zajmie się resztą.

enter image description here

A oto kod dla 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

14
2018-01-30 20:34



Dobra klasa ... Wygląda trochę staroszkolnie, ale spełnia swoją funkcję. Potwierdzam, że działa w MS Access 2010 - 32bit - Combinatix
gdzie mogę umieścić proces? Przykro mi, nie jest to dla mnie oczywiste, ale gdzie mogę umieścić mój proces - na przykład DoCmd.OpenQuery ("LongQuery") - monty327
@ monty327 - Zwykle używałbyś tego, gdy robisz pętlę przez kod. Jeśli masz jedno długie zapytanie, możesz potrzebować nieco innego podejścia, aby móc korzystać z paska postępu. Mam nadzieję, że pomaga! - AdamsTips
Działa to bardzo dobrze. Dzięki! - Freeman Helmuth


Z powodu problemów z dostępną kontrolą stworzyłem domowy pasek postępu, używając 2 prostokątów. Granica i solidny pasek, który jest zmieniany w miarę postępów. Prostokąt postępu przed krawędzią. Używać

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

Można powiązać linię statusu z paskiem postępu, który ogłasza, który element jest przetwarzany. Lubić:   123. District SomeWhere, agent sprzedaży WhomEver

======== Zastępca paska postępu 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

1
2017-10-04 09:39





Użyj polecenia DoEvents po aktualizacji paska postępu (acSysCmdUpdateMeter).

W przypadku dużej liczby rekordów uruchamiaj DoEventa co x razy, ponieważ spowalnia to nieco twoją aplikację.


1
2018-04-29 09:44





To nie jest profesjonalny sposób, ale można go zastosować, jeśli ci się podoba. Jeśli używasz formularza Możesz mieć małe pole tekstowe w wygodnym miejscu domyślnie z zielonym kolorem.

Przypuśćmy, że nazwa pola to Nazwa TxtProcessing,
Właściwości mogą być jak poniżej.

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

1) W swoim skrypcie VB możesz umieścić Me.TxtProcessing.BackColor = vbRed który będzie w kolorze czerwonym i oznacza to zadanie w procesie.
2) możesz napisać cały zestaw skryptów
3) W końcu możesz umieścić Me.TxtProcessing.BackColor = vbGreen

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

Your Code here.....

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

:-) Śmieszne, ale cel został osiągnięty.


0
2018-02-18 12:02





Po prostu dodaję moją część do powyższej kolekcji dla przyszłych czytelników.

Jeśli szukasz mniej kodu i może fajnego interfejsu użytkownika. Sprawdź mój GitHub dla Progressbar dla VBA enter image description here

konfigurowalny:

enter image description here

Dll jest uważany za MS-Access, ale powinien działać na wszystkich platformach VBA z niewielkimi zmianami. Wszystkie kody można znaleźć w przykładowej bazie danych.

Ten projekt jest obecnie w trakcie opracowywania i nie wszystkie błędy są uwzględnione. Więc możesz oczekiwać!

Powinieneś się martwić o bibliotekach innych firm, a jeśli tak, możesz użyć dowolnego zaufanego antywirusa online przed zaimplementowaniem biblioteki dll.


0
2018-05-08 16:41





Najpierw przeciągnij pasek postępu w formularzu MS Access, a następnie zmień nazwę paska postępu jak aa.

Następnie idź do form property, na zegarze :write W kodzie

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

odstęp czasowy 300 zgodnie z wyborem. Uruchom formularz, a zobaczysz pasek postępu


-2
2017-09-06 08:45