Kontynuujemy wątek tablic w VBA. Dzisiaj opiszę bardzo ciekawy problem, na który natrafiłem ostatnio projektując formularz.
Dwa Pola Listy
Otóż, na formularzu mamy dwie kontrolki typu ListBox. Na potrzeby notki, niech pierwsza z nich przechowuje nazwy dni tygodnia (od poniedziałku do niedzieli), natomiast druga z nich – nazwy miesięcy (od stycznia do grudnia).
W obu przypadkach zezwalamy użytkownikowi na wybór wielu wpisów, natomiast konieczne jest, aby użytkownik zaznaczył przynajmniej jedną wartość z każdej listy – tylko wtedy możemy w naszym kodzie przejść dalej.
Kod Formularza
Kod w module formularza wygląda tak.
Private Const ms_MODUL As String = "UTest"
Option Explicit
'Żródła danych dla list rozwijanych
Private m_avListaDniTygodnia(1 To 7) As Variant
Private m_avListaMiesiecy(1 To 12) As Variant
'Wybrane wartości na liście
Private m_avWybraneDniTygodnia As Variant
Private m_avWybraneMiesiace As Variant
'Przycisk OK lub Anuluj
Private m_bOK As Boolean
Property Get OK() As Boolean: OK = m_bOK: End Property
Property Get WybraneDniTygodnia() As Variant: WybraneDniTygodnia = m_avWybraneDniTygodnia: End Property
Property Get WybraneMiesiace() As Variant: WybraneMiesiace = m_avWybraneMiesiace: End Property
Private Sub UserForm_Initialize()
Dim x As Integer
'Załaduj do tablic listę dni tyg. i miesięcy
1 For x = 1 To 12
2 m_avListaMiesiecy(x) = MonthName(x, False)
3 If x <= 7 Then
4 m_avListaDniTygodnia(x) = WeekdayName(x, False, vbMonday)
5 End If
6 Next x
'Załaduj tablice jako źródła dla list rozwijanych
7 Me.lstDniTygodnia.List = m_avListaDniTygodnia
8 Me.lstMiesiace.List = m_avListaMiesiecy
End Sub
Private Sub lstDniTygodnia_Change()
m_avWybraneDniTygodnia = avWybraneWpisy(Me.lstDniTygodnia)
End Sub
Private Sub lstMiesiace_Change()
m_avWybraneMiesiace = avWybraneWpisy(Me.lstMiesiace)
End Sub
Private Function avWybraneWpisy(ByRef ListBox As MSForms.ListBox) As Variant
Dim avTemp() As Variant ' Tablica tymczasowa (nie znamy jej wymiaru)
Dim x As Integer, r As Integer ' Liczniki pętli
'Przejdź w pętli po wszystkich elementach listy rozwijanej
1 For x = 0 To ListBox.ListCount - 1
'Dodaj do tablicy zaznaczone elementy
2 If ListBox.Selected(x) = True Then
'Zwiększ licznik
3 r = r + 1
'Zaczytaj wartość do tablicy
4 ReDim Preserve avTemp(1 To r)
5 avTemp(r) = ListBox.List(x)
6 End If '// If ListBox.Selected(x) = True Then
7 Next x '// For x = 0 To ListBox.ListCount - 1
'Zaczytaj wartość zmiennej do wyniku funkcji
8 avWybraneWpisy = avTemp
End Function
' Obsługa przycisku OK.
Private Sub cmdOK_Click()
1 m_bOK = True
2 Me.Hide
End Sub
' Obsługa przycisku Anuluj.
Private Sub cmdAnuluj_Click()
1 m_bOK = False
2 Me.Hide
End Sub
' Powoduje, że znak [x] zachowuje się tak samo, jak przycisk Anuluj.
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
1 If CloseMode = vbFormControlMenu Then
2 m_bOK = False
3 Me.Hide
4 Cancel = True
5 End If
End Sub
Problem Braku Wyboru
Tradycyjnie traktuję formularz jak obiekt, więc WybraneDniTygodnia i WybraneMiesiace traktuję jako właściwości obiektu UTest. Obie właściwości powinny zwracać w wyniku tablice typu Variant. Właściwość OK, informuje mnie z kolei czy użytkownik kliknął przycisk OK czy Anuluj.
W teorii wszystko wydaje się bardzo proste gdy użytkownik wybierze coś na każdej z list.
Załóżmy jednak taką sytuację, że użytkownik pierwszą listę lstDniTygodnia zostawia w spokoju, natomiast na drugiej klika w styczeń, ale po chwili odznacza go. Na końcu użytkownik klika w przycisk OK.
I teraz najciekawsze. Pomimo tego, że w obu przypadkach użytkownik niczego nie wybrał, VBA traktuje te zachowania jako odmienne, co pokazuje screen poniżej.
W pierwszym przypadku avMojeDniTyg w ogóle nie jest tablicą! Łatwo się o tym przekonać wywołując w okienku Immediate funkcję VB IsArray – zwróci ona False.
W drugim przypadku zaś mamy do czynienia z tablicą, dla avMojeMiesiace IsArray zwróci True.
To nie koniec ciekawostek… Pomimo tego, że jest to tablica, to próba sprawdzenia czy coś w tej tablicy jest (za pomocą Ubound lub WorksheetFunction.CountA) wygeneruje nam błąd, odpowiednio 9 lub 5. Tak jakby ta avMojeMiesiace nie była tablicą, a przecież jest….
Rozwiązanie Problemu
Jak zatem sprawdzić czy użytkownik w ogóle coś zaznaczył?
Ja sobie poradziłem w ten sposób. Najpierw sprawdzam czy funkcja IsArray zwraca w wyniku True. Jeżeli nie, już wiem, że użytkownik niczego nie wybrał.
Jeżeli natomiast zwraca True, to sprawdzam jeszcze jeden warunek – właśnie za pomocą funkcji WorksheetFunction.CountA czyli ILE.NIEPUSTYCH sprawdzam czy coś w tej tablicy jest.
Ale wcześniej oczywiście nakazuję ignorować przez chwilę błędy. Jeżeli coś w tej tablicy jest, to funkcja zwróci mi w wyniku wartość różną od zera (i nie wygeneruje błędu), w przeciwnym razie funkcja zwróci wartość 0 i wygeneruje błąd (ale zostanie on zignorowany, więc kod się “nie wysypie”).
Funkcja bCzySaDane pozwala mi właśnie określić czy użytkownik wybrał coś na formularzu i to jest kluczowe z punktu widzenia dalszego działania programu.
Function bCzySaDane(ByRef avDane As Variant) As Boolean
Dim lNiepuste As Long
1 If IsArray(avDane) Then
2 On Error Resume Next
3 lNiepuste = WorksheetFunction.CountA(avDane)
4 On Error GoTo 0
5 If lNiepuste <> 0 Then
6 bCzySaDane = True
7 End If
8 End If
End Function
Kod Wywołujący Formularz
Poniższy kod znajduje się w module zwykłym. Wywołujemy w nim formularz.
Private Const ms_MODUL As String = "MModulGlowny"
Option Explicit
Public Sub ZaczytajDane()
Dim frmTest As UTest ' Egzemplarz obiektu UTest
Dim avMojeDniTyg As Variant ' Wybrane na formie dni tyg.
Dim avMojeMiesiace As Variant ' Wybrane na formie miesiące
Dim bCzyOk As Boolean ' Czy user kliknął OK czy Anuluj
Const sPROC As String = "ZaczytajDane"
'Aktywuj obsługę błędów na starcie
1 On Error GoTo ObslugaBledu
'Utwórz egzemplarz obiektu UTest
2 Set frmTest = New UTest
'Wyświetl formę
3 frmTest.Show vbModal
'Zaczytaj do zmiennych
4 With frmTest
5 bCzyOk = .OK
6 avMojeDniTyg = .WybraneDniTygodnia
7 avMojeMiesiace = .WybraneMiesiace
8 End With
'Wyloguj formę
9 Unload frmTest
'Działaj gdy user kliknął OK i gdy tablice nie są puste
10 If bCzyOk Then
11 If bCzySaDane(avMojeDniTyg) Then
12 If bCzySaDane(avMojeMiesiace) Then
13 MsgBox "Jest OK! - można działać dalej... "
14 End If
15 End If
16 End If '// If bCzyOk Then
Wyjscie:
17 Set frmTest = Nothing
18 On Error GoTo 0
19 Exit Sub
ObslugaBledu:
20 Application.ScreenUpdating = True
21 MsgBox Title:="Błąd programu!", Buttons:=vbInformation, _
Prompt:="Informacje dotyczące błędu: " & vbCr & vbCr & _
"Numer: " & vbTab & Err.Number & vbCr & _
"Opis: " & vbTab & Err.Description & vbCr & vbCr & _
"Moduł: " & vbTab & ms_MODUL & vbCr & _
"Makro: " & vbTab & sPROC & vbCr & _
"Linia: " & vbTab & Erl()
23 GoTo Wyjscie
End Sub
