Paski postępu w MS Access

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.

Wygląd paska postępu w różnych wersjach MS Access

Własny pasek postępu w formularzu

Najprostszy pasek postępu, to pojedyncza kolorowa etykieta, której szerokość zmienia się proporcjonalnie do zaawansowania operacji. Przykładowo wykonanie 1% zadania powoduje zwiększenie szerokości 0,01*Maksymalna_szerokość_etykiety. Po każdej zmianie szerokości etykiety możemy również zmieniać tekst etykiety na: „Wykonano x% operacji”. lub „Wykonano x z zaplanowanych Y operacji. W takim przypadku etykietą musimy podzielić na część opisową, (o stałej szerokości) i zwiększać rozmiar etykiety proporcjonalnie do zaawansowania wykonania operacji.

Na stronie Modalny pasek postępu dość dokładnie opisałem paski postępu i przedstawiłem przykładową klasę clsProgressBar dzięki której możemy sterować paskiem postępu utworzonym za pomocą modalnego formularza. Formularz ten był ustawiany nad formularzem wywołującym, w sposób stwarzający wrażenie, że jest integralną częścią formularza z poziomu którego został wywołany.

Jeżeli pasek postępu wykorzystywany będzie w kilku formularzach naszej bazy, to aby nie powielać kodu i mieć większą kontrolę nad kodem, 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.

Projekt prostego pasek postępu osadzonego w formularzu wywołującym.

Pasek postępu tworzyć będą 3 formanty typu Label, etykieta lblProgBack będąca tłem właściwego paska postępu lblProg. Poniżej znajduje się etykieta opisowa lblProgDscr. Ramkę wokół etykiet tworzy formant typu Rectangle o nazwie rctProgBorder. Formanty tworzące pasek postępu umieszczamy w dowolnej sekcji formularza. Moim zdaniem najbardziej oczywistą jest sekcja stopka formularza (acFooter)

Rozmieszczenie formantów tworzących prosty pasek postępu.

Umieszczamy formanty tworzące pasek postępu w sekcji Stopka formularza (acFooter) dopasowujemy położenie, rozmiar i wygląd poszczególnych formantów i możemy już uruchamiać pasek postępu. Dodatkowo możemy sekcję Stopka formularza ukryć, by na czas działania paska postępu ją odkryć wraz z formantami które się w niej znajdują.

Option Compare Database
Option Explicit

' referencyjne zmienne do formularza
' i formantów tworzących pasek 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
Private m_lblSect           As Access.Section

' tekst początkowy na pasku postępu
Private m_sPrefix           As String
'ilość przewidywanych operacji
Private m_lMaxCount         As Long
' poprawka na szerokość etykiety paska (m_lblProg), gdyż
' etykieta ta jest przesunięta w prawo w/m etykiety m_lblBack
Private m_lCorrection         As Long

Private Sub Class_Initialize()
'
End Sub
Private Sub Class_Terminate()
	' ukryj elementy paska postępu
	m_rctProg.Visible = False
	m_lblBack.Visible = False
	m_lblProg.Visible = False
	m_lblDscr.Visible = False

	' zniszcz zmienne obiektowe
	Set m_lblDscr = Nothing
	Set m_lblProg = Nothing
	Set m_lblBack = Nothing
	Set m_rctProg = Nothing

	Set m_frm = Nothing
End Sub

' przypisz do zmiennych odwołania do formantów tworzących pasek postępu
Public Sub pgSetProgBar(frmPrg As Access.Form, _
												lblProgBack As Access.Label, _
												lblProgBar As Access.Label, _
												lblProgDescr As Access.Label, _
												rctProgBar As Access.Rectangle)

	' utwórz odwołania do elementów paska
	Set m_frm = frmPrg
	Set m_rctProg = rctProgBar
	Set m_lblBack = lblProgBack
	Set m_lblProg = lblProgBar
	Set m_lblDscr = lblProgDescr

	' poprawka na szerokości paska postępu bo jest przesunięty
	' w/m etykiety lblProgBack w prawo
	m_lCorrection = (m_lblProg.Left - m_lblBack.Left) * 2

	'pokaż elementy paska
	m_rctProg.Visible = True
	m_lblBack.Visible = True
	m_lblProg.Visible = True
	m_lblProg.Width = 0
	m_lblDscr.Visible = True

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 50 twipów (przekracza prawą krawędź etykiety pod spodem)
		If lWidthProgBar > m_lblBack.Width - m_lCorrection Then
		 m_lblProg.Width = m_lblBack.Width - m_lCorrection
		Else
			m_lblProg.Width = lWidthProgBar
		End If

		' ustaw 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 nieco 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
' tekst początkowy na pasku postępu
Public Property Let prpPrefix(sPrefix As String)
	
End Property
Public Property Get prpPrefix() As String
	prpPrefix = m_sPrefix
End Property

Przykładowe wywołanie prostego paska postępu osadzonego w sekcji Stopka formularza

W tym konkretnym przypadku ilość wykonywanych operacji (powtórzeń pętli) wynosi 1 000 000. Pasek postępu aktualizowany jest co 1% (cPercentUpdate As Single = 0.01) liczby operacji tj. po każdych 10 000 wykonanych operacjach.

Option Compare Database
Option Explicit
#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 Form_Load()
  Me.Section(acFooter).Visible = False
End Sub

' uruchom pasek postępu
Private Sub btnProgBar_Click()
Dim cls               As clsProgressSimple ' referencyjna zmienna obiektowa do klasy
Dim lModUpdate        As Long              ' numer operacji aktualizowania paska postępu
Dim i                 As Long              ' licznik
Const cRepeat         As Long = 100        ' ilość powtórzeń
Const cPercentUpdate  As Single = 0.01     ' częstotliwość odświeżania paska
Const cSleep          As Long = 20         ' wydłużenie czasu działania pętli w milisekundach

	' pokaż sekcję Stopka formularza
	Me.Section(acFooter).Visible = True

	Set cls = New clsProgressSimple
		With cls
			' zainicjuj pasek postępu (formanty znajdują się w bieżącym formularzu)
			.pgSetProgBar Me, Me.lblProgBack, Me.lblProg, Me.lblProgDscr, Me.rctProgBorder
			' ustaw tekst początkowy na pasku postępu
			.prpPrefix = "Operacja:"
			' ustaw ilość powtórzeń pętli
			.prpMaxCount = cRepeat
		
			 ' 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
		
	Set cls = Nothing

	' ukryj sekcję Stopka formularza
	Me.Section(acFooter).Visible = False

End Sub

Wywołanie prostego paska postępu.

Moim skromnym zdaniem ten „prosty pasek postępu” spełnia podstawowe zadanie jakiego oczekuje się od paska postępu. Jest prosty, w trakcie projektowania ustawia się jego podstawowe właściwości takie jak: położenie, rozmiar, styl obramowania, wielkość i kolor czcionki. Właściwości te można także zmienić za pomocą VBA.
Pasek jest po prostu„prosty” ☺

Zaawansowany pasek postępu osadzony w formularzu

Życie można sobie ułatwić, bądź skomplikować. By nie dopracowywać co do piksela, a raczej twipa, położenia elementów paska postępu, możemy w dowolnym miejscu wybranej sekcji formularza wstawić elementy paska,

Projekt zaawansowanego paska postępu.

a resztą zajmie się klasa clsProgressBarInFrm, która ustawi domyślne położenie i rozmiar elementów paska. Można także sterować wymiarami paska i jego położeniem przekazując w metodzie pgMoveSize(...) wszystkie potrzebne dane dotyczące rozmiaru i położenia.

Public Sub pgMoveSize( _
              Optional ByVal lLeft As Long = -1, _
              Optional ByVal lTop As Long = -1, _
              Optional ByVal lWidth As Long = -1, _
              Optional ByVal lHeight As Long = -1)

Poniżej kilka słów o niedostatkach projekty zaawansowanego paska postępu. Dlatego też kod jest ukryty, ale nie zabraniam go oglądać ☺. Wystarczy kliknąć w odsyłacz.

Minimalna wysokość sekcji w której znajdują się formanty tworzące pasek postępu powinna być większa od 700 twipów tj. ok. 1,25cm. Dla mniejszych wysokości sekcji zmniejszona będzie wysokość paska postępu i wielkość czcionki. Ale niestety zmniejszy się czytelność tekstu na pasku postępu. W skrajnym przypadku może pojawić się pionowy pasek przewijania formularza. Dodatkowo należy zapamiętać w zmiennych klasy niektóre początkowe właściwości formantów by je przywrócić przed następnym wywołaniem paska postępu. No i na dodatek cała masa empirycznych (na tzw. „oko”) poprawek na położenie i wymiary elementów paska.

Klasa clsProgressBarInFrm i przykładowe wywołanie zaawansowanego paska postępu.

Option Compare Database
Option Explicit
' referencyjne zmienne do formularza
' i formantów tworzących pasek 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
Private m_lblSect           As Access.Section

' wysokość sekcji z paskiem postępu
Private m_lLblSectHeight    As Long
' identyfikator sekcji z paskiem  postępu
Private m_lInSection        As Long

' rozmiar fontu w etykietach paska
Private m_iLblBackFontSize  As Integer
Private m_iLblProgFontSize  As Integer
Private m_iLblDscrFontSize  As Integer

' tekst początkowy na pasku postępu
Private m_sPrefix           As String
'ilość przewidywanych operacji
Private m_lMaxCount         As Long

Private Sub Class_Terminate()

	' ukryj elementy paska postępu
	m_rctProg.Visible = False
	m_lblBack.Visible = False
	m_lblProg.Visible = False
	m_lblDscr.Visible = False

	' zmniejsz i przesuń do góry elementy paska
	m_rctProg.Height = 0: m_rctProg.Top = 0
	m_lblBack.Height = 0: m_lblBack.Top = 0
	m_lblProg.Height = 0: m_lblProg.Top = 0
	m_lblDscr.Height = 0: m_lblDscr.Top = 0
	' przywróć rozmiar sekcji paska postępu
	m_frm.Section(m_lInSection).Height = m_lLblSectHeight
	' przywróć rozmiar czcionki etykiet paska
	m_lblBack.FontSize = m_iLblBackFontSize
	m_lblProg.FontSize = m_iLblProgFontSize
	m_lblDscr.FontSize = m_iLblDscrFontSize

	' zniszcz zmienne obiektowe
	Set m_lblDscr = Nothing
	Set m_lblProg = Nothing
	Set m_lblBack = Nothing
	Set m_rctProg = Nothing

	Set m_frm = Nothing

End Sub

' przypisz do zmiennych odwołania do formantów tworzących pasek postępu
Public Sub pgSetProgBar(frmPrg As Access.Form, _
                            lblProgBack As Access.Label, _
                            lblProgBar As Access.Label, _
                            lblProgDescr As Access.Label, _
                            rctProgBar As Access.Rectangle)

	' utwórz odwołania do elementów paska
	Set m_frm = frmPrg
	Set m_rctProg = rctProgBar
	Set m_lblBack = lblProgBack
	Set m_lblProg = lblProgBar
	Set m_lblDscr = lblProgDescr

	' pobierz identyfikator sekcji i jej wysokość
	m_lInSection = m_frm.Controls(m_lblProg.Name).Section
	Set m_lblSect = m_frm.Section(m_lInSection)
	m_lLblSectHeight = m_lblSect.Height

	'pokaż elementy paska
	m_rctProg.Visible = True
	m_lblBack.Visible = True
	m_lblProg.Visible = True
	m_lblProg.Width = 0
	m_lblDscr.Visible = True

	' pobierz rozmiary czcionek etykiet paska postępu
	m_iLblBackFontSize = m_lblBack.FontSize
	m_iLblProgFontSize = m_lblProg.FontSize
	m_iLblDscrFontSize = m_lblDscr.FontSize

End Sub

' przesuwa i zmienia rozmiar 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, _
              Optional ByVal lHeight As Long = -1)
Dim lBottom    As Long
Dim lLblHeight As Long
Dim fDefHeight As Boolean

	' ustaw pasek postępu przy lewej krawędzi sekcji
	If lLeft <= -1 Then lLeft = 75

	' ustaw domyślną wysokość paska postępu
	If lHeight <= -1 Then
		fDefHeight = True
		lHeight = 620
	End If

	' jeżeli sekcja jest za niska zmniejsz wysokość paska postępu i czcionkę
	With m_frm.Section(m_lInSection)
		' sprawdź tylko dla domyślnej wysokości
		If fDefHeight = True Then
			If .Height < (lHeight + 75) Then
				m_lblBack.FontSize = (m_iLblBackFontSize * .Height / lHeight) - 1
				m_lblProg.FontSize = (m_iLblProgFontSize * .Height / lHeight) - 1
				m_lblDscr.FontSize = (m_iLblDscrFontSize * .Height / lHeight) - 1
				lHeight = .Height - 175
			End If
		End If
	End With

	' ustaw domyślną szerokość paska postępu
	If lWidth <= -1 Then lWidth = m_frm.InsideWidth - 125

	' empiryczna poprawka na szerokość selektora rekordów (gdy jest widoczny)
	If m_frm.RecordSelectors = True Then
		lWidth = lWidth - 300
	End If

	' ustaw domyślne położenie paska postępu w pionie
	If lTop = -1 Then
		If m_lInSection = acDetail Then
			' ustaw pasek postępu na dole sekcji Szczegóły
			lBottom = m_frm.InsideHeight
			On Error Resume Next
				' pułapkuj błędy, sumuj wysokości sekcji
				lBottom = lBottom - m_frm.Section(acHeader).Height
				lBottom = lBottom - m_frm.Section(acFooter).Height
			On Error GoTo 0
			lTop = lBottom - lHeight - 100
			If lTop < 0 Then lTop = 100
		Else
			' pasek postępu nie znajduje się w sekcji Szczegóły
			' ustaw pasek 50 twipów poniżej górnej krawędzi sekcji
			lTop = 50
		End If
	End If

	' oblicz wysokość pojedynczego paska
	lLblHeight = (lHeight - 3 * 50) \ 2

	' Dla bardzo małych wysokości może być mniejsze od zera
	If lLblHeight - 35 < 0 Then lLblHeight = 100

	' ramka paska postępu
	m_rctProg.Left = lLeft
	m_rctProg.Top = lTop
	m_rctProg.Width = lWidth
	m_rctProg.Height = lHeight

	' etykieta tła
	m_lblBack.Left = lLeft + 50
	m_lblBack.Top = lTop + 50
	m_lblBack.Width = lWidth - 100
	m_lblBack.Height = lLblHeight

	' pasek postępu
	m_lblProg.Left = lLeft + 55
	m_lblProg.Top = lTop + 63
	m_lblProg.Width = 0
	m_lblProg.Height = lLblHeight - 35

	' etykieta opisowa
	m_lblDscr.Left = lLeft + 50
	m_lblDscr.Top = m_lblBack.Top + m_lblBack.Height + 50
	m_lblDscr.Width = lWidth - 100
	m_lblDscr.Height = lLblHeight

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 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 nieco 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
' 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

Option Compare Database
Option Explicit
#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 Form_Load()
  Me.Section(acFooter).Visible = False
End Sub

' uruchom pasek postępu
Private Sub btnProgBar_Click()
Dim cls               As clsProgressBarInFrm ' referencyjna zmienna obiektowa do klasy
Dim lModUpdate        As Long                ' numer operacji aktualizowania paska postępu
Dim i                 As Long                ' licznik
Const cRepeat         As Long = 100          ' ilość powtórzeń
Const cPercentUpdate  As Single = 0.01       ' częstotliwość odświeżania paska
Const cSleep          As Long = 20           ' wydłużenie czasu działania pętli w milisekundach

	Me.Section(acFooter).Visible = True

	Set cls = New clsProgressBarInFrm
		With cls
			' zainicjuj pasek postępu (formanty znajdują się w bieżącym formularzu)
			.pgSetProgBar Me, Me.lblProgBack, Me.lblProg, Me.lblProgDscr, Me.rctProgBorder
			' zainicjuj domyślne ustawienia paska postępu
			'.pgMoveSize
			'----------------------------------------------------------------------------------------
			' można też ustalić swoje wymiary paska: wycentruj pasek
			'  w poziomie i przesuń pasek postępu pod formularz
			.pgMoveSize Me.InsideWidth / 4, 75, Me.InsideWidth / 2, Me.Section(acFooter).Height - 120
			'----------------------------------------------------------------------------------------
			
			' ustaw tekst początkowy na pasku postępu
			.prpPrefix = "Operacja:"
			' ustaw ilość powtórzeń pętli
			.prpMaxCount = cRepeat
		
			 ' 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
	Set cls = Nothing

	Me.Section(acFooter).Visible = False

End Sub

Widok zaawansowanego paska postępu po wywołaniu metody:

.pgMoveSize Me.InsideWidth / 4, 75, Me.InsideWidth / 2, _
Me.Section(acFooter).Height - 120

Do pobrania: • Pasek postępu osadzony w formularzu pobrano () razy

MS Access 2010+ | Formularze | VBA 7.0

• Pasek postępu osadzony w formularzu.