Pasek postępu w MS Access
Mam zapytanie uruchomione w Microsoft Access 2010 i trwa ponad 30 min, aby uruchomić normalnie. Chciałbym przedstawić użytkownikowi końcowemu pewien status zapytania. Pasek postępu byłby miły, ale nie jest wymagany. Access wydaje się być słabo gwintowany i zamyka się mocno podczas wykonywania zapytania negując wszelkie aktualizacje, które próbuję. Chociaż wolałbym whip VS i napisać własną aplikację, aby to zrobić, jestem zmuszony do korzystania z dostępu.
Jakieś pomysły?
EDIT
Kiedyś to prowadziłem ze skryptu wsadowego, który wypełnił bazę danych, ale chciałbym, aby wszystko było samodzielne W Access. Mówiąc dokładniej, "zapytanie" jest tak naprawdę skryptem VBA, który pinguje serię hostów. Więc nie mam się martwić o optymalizację czasu per se, ale po prostu dać użytkownikowi końcowemu wiedzieć, że nie został zamknięty.
7 answers
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 musisz wykonać pracę programowo, aby to zadziałało. Nie można oglądać zapytania uruchamianego w kodzie lub tym podobne w programie Access. Ewentualnie możesz podzielić pracę powolnego zapytania na mniejsze części, aby uzyskać szansę aktualizacji paska postępu. Ale zawsze możesz pokazać szkło godzinne; to mówi użytkownikowi, że coś się dzieje.
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2015-03-10 18:13:53
W przypadku, gdyby inni uznali to za przydatne, oto klasa, którą napisałem w tym celu. Używam go cały czas w moich projektach Access development. Po prostu wrzuć go do swojego projektu w module klasowym o nazwie clsLblProg
i użyj go w następujący sposób:
To tworzy ładny pasek postępu:
Na formularzu, wszystko, czego potrzebujesz, to trzy etykiety. Ustaw tylną etykietę na żądany rozmiar, a pozostałe dwa Ukryj. Klasa robi odpoczywaj.
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
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2015-01-30 20:34:15
Z powodu problemów z dostępnym sterowaniem stworzyłem domowy pasek postępu przy użyciu 2 prostokątów. Ramka i stały pasek, który jest zmieniany w miarę postępu prac. Prostokąt postępu przed granicą. Do użycia
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 informuje, jaki element jest przetwarzany. Jak: 123. District SomeWhere, sales agent WhomEver
======== pasek postępu zastępuje 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
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2013-10-04 09:39:45
Użyj polecenia DoEvents po zaktualizowaniu paska postępu (acSysCmdUpdateMeter).
W przypadku dużej liczby rekordów wykonuj tylko DoEvents co x razy, ponieważ to trochę spowalnia Twoją aplikację.
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2014-04-29 09:44:51
Nie jest to profesjonalny sposób, ale można go zastosować, jeśli ci się podoba. Jeśli korzystasz z formularza Możesz mieć małe pole tekstowe w wygodnym miejscu domyślnym kolorem zielonym.
Przypuśćmy, że nazwa pola tekstowego jest TxtProcessing
,
właściwości mogą być następujące.
Name : TxtProcessing
Visible : Yes
Back color : Green
Locked: Yes
Enter Key Behavior : Default
1) w skrypcie VB możesz umieścić Me.TxtProcessing.BackColor = vbRed
, który będzie na Czerwono i oznacza zadanie w trakcie.
2) możesz napisać cały swój 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 jest / align = "left" /
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2014-02-18 12:21:26
Właśnie dodaję swoją część do powyższej kolekcji dla przyszłych czytelników.
Jeśli jesteś po mniej kodu i może fajne UI. Sprawdź mój GitHub dla Progressbara dla VBA
Konfigurowalny:
Dll jest przeznaczony dla 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 fazie rozwoju i nie wszystkie błędy są objęte. Więc spodziewajcie się!
Powinieneś martwić się o biblioteki DLL innych firm, a jeśli tak, prosimy korzystać z dowolnego zaufanego antywirusa online przed wdrożeniem dll.
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2018-05-08 16:41:34
Najpierw przeciągnij kontrolkę progresywnego paska w formularzu MS Access, a następnie zmień nazwę paska progresywnego jak aa
.
Następnie przejdź do form property
, na timerze :write
w kodzie
me.aa.value=me.aa.value+20
Przedział czasu 300 według twojego wyboru. Uruchom formularz zobaczysz progresywny pasek
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2014-09-06 09:17:00