Paski postępu w MS Access
MS Access w trakcie naprzemiennego uruchamiania Accessa 2007 i Accessa 2010 prezentuje paski nowszego typu
Nowsze paski postępu MS Access 2007 i 2010
Funkcja SysCmd obiektu Application umożliwia wyświetlenie wskaźnika zaawansowania operacji w dolnej części okna MS Access gdzie znajduje się pasek stanu, który służy do wyświetlania różnych informacji na temat danych w formularzu. Na przykład może zawierać opis pola, komunikaty o błędach, ostrzeżenia lub wspomniany wcześniej pasek postępu.
Private Sub testProgressBar()
Dim i As Long
Const cForTo As Long = 5000
'pokaż pasek stanu
Application.CommandBars("Status Bar").Visible = True
' zainicjuj pasek postępu
Application.SysCmd acSysCmdInitMeter, "MS Access 2016", cForTo
For i = 0 To cForTo
' aktualizuj pasek postępu
Application.SysCmd acSysCmdUpdateMeter, i
DoEvents: DoEvents: DoEvents
Next
' usuń pasek postępu
Application.SysCmd acSysCmdRemoveMeter
End Sub
Po wywołaniu procedury testProgressBar() w różnych wersjach MS Access, możemy zobaczyć jak zmieniał się pasek postępu i jego położenie w kolejnych odsłonach MS Access.
Wygląd paska postępu w różnych wersjach MS Access
Własny pasek postępu.
Minimalistyczny sposób utworzenie własnego paska postępu polega stopniowym zwiększaniu szerokości pojedynczej „kolorowej” etykiety w miarę zaawansowania wykonania operacji. Np. wykonanie 1% zadania powoduje zwiększenie szerokości 0,01*Maksymalna_szerokość_etykiety. Możemy w trakcie wykonywania zmieniać tekst etykiety na: „Wykonano x% operacji”, lub „Wykonano x z zaplanowanych Y operacji. Jeżeli zdecydujemy się na takie rozwiązanie, to etykietą musimy podzielić na początkową, (o stałej szerokości część) opisową i zwiększać rozmiar etykiety proporcjonalnie do zaawansowania wykonania operacji.
Ponieważ pasek postępu może nam być potrzebny wielokrotnie, to by nie powielać kodu w każdym formularzu wykorzystującym pasek postępu spróbujmy utworzyć moduł klasy, za pomocą którego będziemy mogli sterować podstawowymi właściwościami i metodami formularza spełniającego rolę paska postępu.
Moduł klasy
Moduł klasy jest specjalnym typem modułu standardowego. Jest on definicją obiektu i pozwala na tworzenie nowych egzemplarzy obiektów opartych na kodzie tego moduły klasy. Wszystkie właściwości, metody i zdarzenia, dostępne są w module klasy w formie procedur oznaczanych słowem kluczowym Public. Wszystkie procedury i funkcje który nie powinny być dostępne na zewnątrz modułu, powinien być oznaczony słowem kluczowym Private.
Wstawić moduł klasy
Aby wstawić do naszego projektu moduł klasy należy w oknie edytora VBA wybrać z menu pozycję „Insert” i następnie kliknąć na podmenu „Class Module”,
lub po kliknięciu prawym przyciskiem myszy w oknie Eksplorator projektu „Project” wybrać z menu podręcznego pozycję „Insert”, a potem pozycję „Class Module”.
Następnie w oknie właściwości nowo wstawionego modułu klasy „Properties Class1” nadajemy właściwości Name wartość clsProgBar. Od tej pory będziemy się mogli odwoływać do naszej klasy za pomocą jej nazwy clsProgBar.
Projekt modalnego formularza tworzącego pasek postępu.
Formularz zawiera 3 formanty typu Label, etykieta lblProgBack będąca tłem nad którą znajduje się właściwy pasek postępu lblProg. Poniżej znajduje się etykieta opisowa lblProgDscr. Ramkę wokół etykiet tworzy formant typu Rectangle o nazwie rctProgBorder.
Budowa i niektóre właściwości formularza tworzącego pasek postępu.
Option Compare Database
Option Explicit
' odwołania do formularza formantów paska postępu
Private m_frm As Access.Form
Private m_rctProg As Access.Rectangle
Private m_lblBack As Access.Label
Private m_lblProg As Access.Label
Private m_lblDscr As Access.Label
' tekst informacyjny etykiety opisowej
Private m_sPrefix As String
'ilość przewidywanych operacji
Private m_lMaxCount As Long
' przypisz do zmiennych odwołania do formantów tworzących pasek postępu
Private Sub Class_Initialize()
Set m_frm = New Form_frmProgressBar
DoCmd.Restore
With m_frm
Set m_rctProg = .Controls("rctProgBorder")
Set m_lblBack = .Controls("lblProgBack")
Set m_lblProg = .Controls("lblProg")
Set m_lblDscr = .Controls("lblProgDscr")
End With
' kolorowy pasek postępu
m_rctProg.BackColor = 1
' przezroczyste etykiety opisowe
m_lblBack.BackColor = 0
m_lblDscr.BackColor = 0
' tekst na początku etykiety opisowej
m_sPrefix = "Operacja: "
End Sub
Private Sub Class_Terminate()
' zniszcz zmienne obiektowe
Set m_lblDscr = Nothing
Set m_lblProg = Nothing
Set m_lblBack = Nothing
Set m_rctProg = Nothing
' zamknij formularz paska, bo kolejne
' wywołania powodują przesunięcie paska
DoCmd.Close acForm, m_frm.Name
Set m_frm = Nothing
End Sub
' przesuwa i zmienia rozmiar formularza i formantów tworzących pasek postępu
Public Sub pgMoveSize( _
Optional ByVal lLeft As Long = -1, _
Optional ByVal lTop As Long = -1, _
Optional ByVal lWidth As Long = -1)
' zmień rozmiar formularza i dostosuj
' wielkość formantów paska postępu
If lWidth > 0 Then
lWidth = CLng(lWidth)
m_frm.InsideWidth = lWidth - 25
m_rctProg.Width = lWidth - 100
m_lblBack.Width = lWidth - 200
m_lblDscr.Width = lWidth - 200
End If
' ustaw fokus na formularzu paska postępu
DoCmd.SelectObject acForm, m_frm.Name, False
' przesuń formularz paska postępu
If (lLeft > 0) And (lTop > 0) Then
DoCmd.MoveSize lLeft, lTop
ElseIf (lLeft > 0) Then
DoCmd.MoveSize lLeft
ElseIf (lTop > 0) Then
DoCmd.MoveSize , lTop
End If
End Sub
' aktualizacja paska postępu w/m ilości wykonanych operacji
Public Sub pgUpdateProgBar(ByVal lOperation As Long)
Dim lPercent As Long
Dim lWidthProgBar As Long
' oblicz % wykonania
lPercent = (lOperation / m_lMaxCount) * 100
With m_frm
' ustaw teksty "przenikających się" etykiet
m_lblProg.Caption = "Wykonano " & lPercent & "% zadania"
m_lblBack.Caption = "Wykonano " & lPercent & "% zadania"
' oblicz szerokość paska postępu
lWidthProgBar = m_lblBack.Width * (lPercent / 100)
' dla ostatnich operacji zmniejsz maksymalną szerokość
' paska postępu o 60 twipów (jest za długi)
If lWidthProgBar > m_lblBack.Width - 60 Then
m_lblProg.Width = m_lblBack.Width - 60
Else
m_lblProg.Width = lWidthProgBar
End If
' ustaw sformatowany tekst paska postępu
m_lblDscr.Caption = prpPrefix & _
Format$(CStr(lOperation), "### ### ### ###") & _
" z " & Format$(m_lMaxCount, "### ### ### ###")
' Czasami występuje nieprzyjemne migotanie paska postępu.
' Możemy na czas przemalowania formularza zablokować odświeżanie
' okien kosztem o wiele dłuższego czasu działania paska postępu
'On Error Resume Next
' Application.Echo False
DoEvents
' Application.Echo True
'On Error GoTo 0
End With
End Sub
' maksymalna ilość operacji
Public Property Let prpMaxCount(prpMaxCount As Long)
If prpMaxCount = 0 Then prpMaxCount = 1
m_lMaxCount = Abs(prpMaxCount)
End Property
Public Property Get prpMaxCount() As Long
prpMaxCount = m_lMaxCount
End Property
' szerokość formularza paska postępu
Public Property Get prpProgBarWidth() As Long
prpProgBarWidth = m_frm.InsideWidth
End Property
' tekst początkowy na pasku postępu
Public Property Let prpPrefix(sPrefix As String)
m_sPrefix = sPrefix
End Property
Public Property Get prpPrefix() As String
prpPrefix = m_sPrefix
End Property
' kolor tekstu tła paska postępu
Public Property Let prpDetailColorBack(lCol As Long)
'm_frm.Section(acDetail).BackStyle = 1
m_frm.Section(acDetail).BackColor = lCol
End Property
' kolor tekstu tła paska postępu
Public Property Let prpBackColorBack(lCol As Long)
m_lblBack.BackStyle = 1
m_lblBack.BackColor = lCol
End Property
' kolor tekstu tła paska postępu
Public Property Let prpBackColorText(lCol As Long)
m_lblBack.ForeColor = lCol
End Property
' kolor paska postępu
Public Property Let prpProgColorBack(lCol As Long)
m_lblProg.BackColor = lCol
m_lblProg.BorderColor = lCol
End Property
' kolor tekstu paska postępu
Public Property Let prpProgColorText(lCol As Long)
m_lblProg.ForeColor = lCol
End Property
' kolor tekstu opisu operacji
Public Property Let prpDscrColorText(lCol As Long)
m_lblDscr.ForeColor = lCol
End Property
' tekstu opisu operacji
Public Property Let prpDscrColorBack(lCol As Long)
m_lblDscr.BackStyle = 1
m_lblDscr.BackColor = lCol
End Property
' wysokość okna formularza paska postępu
Public Property Get prpProgBarHeight() As Long
prpProgBarHeight = m_frm.WindowHeight
End Property
Poniżej przykładowe wywołanie paska postępu z wykorzystaniem nowo utworzonej klasy clsProgressBar.
Private Sub SimpleProgressBar() Dim clsPgBar As clsProgressBar Dim i As Long Set clsPgBar = New clsProgressBar With clsPgBar ' ustaw domyślny rozmiar i położenie paska .pgMoveSize ' przekaż do klasy clsPgBar ilość powtórzeń pętli .prpMaxCount = 10000 ' wykonaj prostą pętlę 10 000 razy For i = 0 To 10000 ' tutaj wykonuj swoje instrukcje ! ' ... ' wydłuż czas działania pętli DoEvents: DoEvents: DoEvents .pgUpdateProgBar i Next End With Set clsPgBar = Nothing End Sub
Całkowity czas wykonania procedury SimpleProgBar() wraz z aktualizacją paska postępu w każdym kroku
pętli For ... Next (10 000 kroków pętli) zajmuje ok. 15 sekund .
Bez aktualizacji paska postępu czas wykonania procedury SimpleProgBar() wynosi ok. 8 sek.
ale na ekranie nic sensownego nie zobaczymy, poza paskiem po pierwszej aktualizacji (1%).
Wizualnie tekst górnego paska postępu pokazującego procentowe wykonanie ulega zmianie co 1%,
a dolny opisowy pasek zmienia się z każdym krokiem pętli. Prawdopodobnie dlatego
bardzo nieprzyjemnym efektem ubocznym jest intensywne „migotanie” elementów paska postępu.
Aby zminimalizować nieprzyjemne „migotanie” okien paska, możemy zastosować metodę Echo,
obiektu Application, by wyłączyć odświeżanie ekranu.
Application.Echo False DoEvents Application.Echo True
Włączanie i wyłączanie odświeżania ekranu spowodowało, że „migotanie” okien paska jest prawie niezauważalne,
Ale „coś za coś”. Czas wykonania procedury SimpleProgBar() wydłużył się dość znacznie:
- 32-bit Access 2007: z 13 sek. do 240 sek.
- 64-bit Access 2010: z 12 sek. do 180 sek.
- 64-bit Access 2016: z 10 sek. do 60 sek.
Podstawowe pytanie:
Po co aktualizować pasek postępu po wykonaniu każdej operacji (tut. 10 000 razy), kiedy wizualnie widoczna jest zmiana po wykonaniu 1% operacji. Jeżeli tak, to spróbujmy aktualizować pasek co 1%. Praktycznie (wizualnie), bez względu na ilość operacji, tekst paska postępu będzie się zmieniał tylko 100 razy (tak jak zmienia się procentowe zaawansowanie przebiegu operacji).
' aktualizuj co lModUpdate wywołań
lModUpdate = CLng(cRepeat * cPercentUpdate)
If i Mod lModUpdate = 0 Then
.pgUpdateProgBar i
End If
Jeśli tak, to aktualizujmy pasek postępu co 1% wykonanych operacji:
Private Sub ProgressBar() Dim clsPgBar As clsProgressBar Dim lModUpdate As Long Dim i As Long Const cRepeat As Long = 10000 Const cPercentUpdate As Single = 0.01 ' co ile operacji ma być aktualizowany pasek postępu lModUpdate = CLng(cRepeat * cPercentUpdate) Set clsPgBar = New clsProgressBar With clsPgBar ' ustaw domyślny rozmiar i położenie paska .pgMoveSize ' przekaż do klasy clsPgBar ilość powtórzeń pętli .prpMaxCount = cRepeat ' wykonaj prostą pętlę 10 000 razy For i = 0 To cRepeat ' tutaj wykonuj swoje instrukcje ! ' ... ' wydłuż czas działania pętli DoEvents: DoEvents: DoEvents ' aktualizuj co lModUpdate wywołań If i Mod lModUpdate = 0 Then .pgUpdateProgBar i End If Next End With Set clsPgBar = Nothing End Sub
Teraz jest o wiele lepiej. Pasek postępu prawie przestał „migotać”, a włączanie i wyłączanie odświeżania ekranu nie powoduje zbyt dużego wydłużenia czasu działania pętli For ... Next. Poniżej orientacyjny czas wykonywania procedury SimpleProgBar()
- 32-bit Access 2007: z 4,4 sek. do 6,3 sek.
- 64-bit Access 2010: z 3,2 sek. do 4,8 sek.
- 64-bit Access 2016: z 2,9 sek. do 3,5 sek.
W tym przypadku w wywołaniu procedury ProgressBar() pasek postępu jest aktualizowany 100 razy (zamiast 10 000 razy), co 1% kroków pętli. Czas wykonywania procedury wynosi ok. ~5 sekundy, co jest zbliżonym wynikiem do wywołania procedury bez aktualizacji paska postępu. Dodatkową korzyścią jest brak tzw. „migotania” okien paska postępu.
Wygląd paska postępu w trakcie pracy.
Kolorowy pasek postępu
Jeżeli nie podoba nam się szary wygląd paska postępu, możemy wykorzystać metody i właściwości klasy clsProgressBar by zmienić kolorystykę paska postępu. Przykładowe kolory zostały wybrane z użyciem zdefiniowanych stałych i nie mają nic wspólnego z estetyką ☺
#If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Private Sub ProgressBarColor() Dim clsPgBar As clsProgressBar ' referencyjna zmienna obiektowa do klasy Dim lModUpdate As Long ' numer operacji aktualizowania paska postępu Dim i As Long ' licznik Const cSleep As Long = 10 ' wydłużenie czasu działania pętli w milisekundach Const cRepeat As Long = 100 ' ilość powtórzeń Const cPercentUpdate As Single = 0.01 ' częstotliwość odświeżania paska Set clsPgBar = New clsProgressBar With clsPgBar ' przekaż do klasy clsPgBar ilość powtórzeń pętli .prpMaxCount = cRepeat ' przesuń pasek postępu pod formularzem i wycentruj go w poziomie .pgMoveSize Me.WindowLeft + (Me.InsideWidth - .prpProgBarWidth) \ 1, _ Me.WindowTop + Me.WindowHeight + 50, 9400 ' zmień kolor etykiety tła i tekstu .prpBackColorText = vbRed .prpBackColorBack = vbGreen ' kolor tła paska postępu i tekstu paska .prpProgColorText = vbYellow .prpProgColorBack = vbBlue ' zmień kolor tła etykiety opisowej i tekstu .prpDscrColorText = vbBlue .prpDscrColorBack = vbCyan ' zmień kolor tła sekcji Szczegóły .prpDetailColorBack = RGB(255, 0, 0) ' operacja aktualizowania paska postępu lModUpdate = CLng(cRepeat * cPercentUpdate) ' wykonaj prostą pętlę cRepeat razy For i = 0 To cRepeat ' tutaj wykonuj swoje instrukcje ! ' ... ' wydłuż czas działania pętli Call Sleep(cSleep) ' aktualizuj co lModUpdate wywołań If i Mod lModUpdate = 0 Then .pgUpdateProgBar i End If Next End With Set clsPgBar = Nothing End Sub
Zmiana kolorystyki paska postępu i jego szerokości ☺
Przesuwany pasek postępu (góra, środek, dół) formularza wywołującego.
#If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If ' miejsca ustawienia paska postępu Private Const m_TOP As Long = 1 Private Const m_MIDDLE As Long = 2 Private Const m_BOTTOM As Long = 3 Private Sub ProgressBarMoved(clsProgBar As clsProgressBar, lPosition As Long) Dim lModUpdate As Long ' numer operacji aktualizowania paska postępu Dim lAddLeft As Long ' Dim lAddTop As Long ' poprawki na rozmiar paska postępu Dim lAddWidth As Long ' Dim i As Long ' licznik Const cSleep As Long = 10 ' wydłużenie czasu działania pętli w milisekundach Const cRepeat As Long = 100 ' ilość powtórzeń Const cPercentUpdate As Single = 0.01 ' częstotliwość odświeżania paska With clsProgBar ' ustaw ilość powtórzeń pętli .prpMaxCount = cRepeat .prpPrefix = "Operacja:" ' poprawki na wymiary i położenie paska postępu ' gdyż wersje MS Access powyżej 2010 mają jednopikselowe obramowanie If Eval(Application.Version) > 14 Then lAddLeft = 15 lAddTop = 25 lAddWidth = 0 Else lAddLeft = 65 lAddTop = 50 lAddWidth = 50 End If ' sprawdź, gdzie ma być wyświetlony pasek postępu Select Case lPosition Case m_TOP ' przesuń pasek postępu na górę formularza i zmień jego szerokość .pgMoveSize Me.WindowLeft + lAddLeft, _ Me.WindowTop + lAddTop + 0, _ Me.InsideWidth + lAddWidth Case m_MIDDLE ' przesuń pasek postępu na środek wysokości formularza i zmień jego szerokość .pgMoveSize Me.WindowLeft + lAddLeft, _ Me.WindowTop + (Me.WindowHeight - .prpProgBarHeight) / 2 + lAddTop, _ Me.InsideWidth + lAddWidth Case m_BOTTOM ' przesuń pasek postępu na dół formularza i zmień jego szerokość .pgMoveSize Me.WindowLeft + lAddLeft, _ Me.WindowTop + (Me.WindowHeight - .prpProgBarHeight) - lAddTop, _ Me.InsideWidth + lAddWidth Case Else ' bez zmiany położenia .pgMoveSize End Select ' oblicz co ile wykonanych operacji ma być aktualizowany pasek postępu lModUpdate = CLng(cRepeat * cPercentUpdate) ' wykonaj prostą pętlę cRepeat razy For i = 0 To cRepeat ' tutaj wykonuj swoje instrukcje ! ' ... ' wydłuż czas działania pętli Call Sleep(cSleep) ' aktualizuj co lModUpdate wywołań If i Mod lModUpdate = 0 Then .pgUpdateProgBar i End If Next End With End Sub
Pasek postępu ustawiony na środku wysokości formularza wywołującego pasek postępu.
'przykładowe wywołanie Private Sub btnProgressBar_Click() Dim clsPgBar As clsProgressBar ' pasek postępu na górze formularza Set clsPgBar = New clsProgressBar Call ProgressBarMoved(clsPgBar, m_TOP) Set clsPgBar = Nothing ' pasek postępu na środku wysokości formularza Set clsPgBar = New clsProgressBar Call ProgressBarMoved(clsPgBar, m_MIDDLE) Set clsPgBar = Nothing ' kolorowy pasek postępu na dole formularza Set clsPgBar = New clsProgressBar ' pokoloruj pasek dolny pasek postępu '==================================== With clsPgBar ' zmień kolor etykiety tła i tekstu .prpBackColorText = vbRed .prpBackColorBack = vbBlue ' zmień kolor tła paska postępu i tekstu paska .prpProgColorText = vbYellow .prpProgColorBack = vbGreen ' zmień kolor tła etykiety opisowej i tekstu .prpDscrColorText = vbMagenta .prpDscrColorBack = vbCyan ' zmień kolor tła sekcji Szczegóły .prpDetailColorBack = RGB(125, 0, 125) End With Call ProgressBarMoved(clsPgBar, m_BOTTOM) Set clsPgBar = Nothing ' mały pasek postępu poniżej dolnej krawędzi formularza Call ProgressBar ' kolorowy pasek postępu poniżej dolnej krawędzi formularza Call ProgressBarColor End Sub
Do pobrania:
•