Access

  MS Access 2010+  |  Formularze  |   VBA 7.0

• Pasek postępu (Progress bar).

Pasek postępu jest graficznym elementem kontrolnym używanym do wizualizacji postępu operacji wykonywanej przez system, takich jak pobieranie danych, przesyłanie plików, postęp instalacji programu. W MS Access pasek postępu może informować o przetwarzanie kolejnych rekordów, bądź plików.

Klasyczny pasek postępu
Klasyczne (stare) paski postępu.

Paski postępu w MS Access

MS Access w trakcie naprzemiennego uruchamiania Accessa 2007 i Accessa 2010 prezentuje paski nowszego typu

Paski postępu Access 2007 i 2010
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.

Paski postępu w 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”,

Wstawianie modułu klasy z menu

lub po kliknięciu prawym przyciskiem myszy w oknie Eksplorator projektu „Project” wybrać z menu podręcznego pozycję „Insert”, a potem pozycję „Class Module”.

Wstawianie modułu klasy z menu podręcznego

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.

Formularz jako pasek postępu
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.

Pasek 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

Zmieniony pasek postępu
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
Zmieniony pasek postępu
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
Pobierz    Do pobrania:Modalny pasek postępu pobrano () razy