Poněkud zvláštním požadavkem, je určení, do kterého měsíce spadá zadané číslo týdne. Problémem je skutečnost, že některé týdny spadají současně do dvou měsíců. Následující funkce tedy zjišťuje do kterého měsíce patří poslední den týdne zadaného čísla.
Function Mesic_tyden (T As Long) As Long
' *******************************************************
' vrací číslo měsíce ve kterém leží uvedený týden
' *******************************************************
On Error GoTo Err_mesic_tyden
Dim V As Variant, M1 As Variant, M As Variant
Dim T1 As Variant
Mesic_tyden = 0
If IsNull(T) Then
' není zadáno číslo týdne
Else
' do M1 určení prvního dne roku
M1 = "1.1." & Str(Year(Date))
M1 = DateValue(M1)
' určení který den v týdnu je M1
' 1 = po, 2 - út, ..., 7 - Ne
T1 = Weekday(M1) - 1
If T1 < 1 Then
T1 = T1 + 7
End If
' Určení délky prvního týdne
T1 = 8 - T1
' Určení počtu dnů od počátku roku do posledního dne žádaného týdne
T1 = T1 + (T - 1) * 7
' Určení datumu, které přísluší poslednímu dni zadaného týdne
M = M1 + T1
' Vrácení měsíce posledního dne zadaného měsíce
Mesic_tyden = Format(M, "m")
End If
Exit Function
' *************************************************
' obsluha chyby
' *************************************************
Err_mesic_tyden:
V = MsgBox("Došlo k chybě č. " + Str(Err) + " '" + Error + "'. Informujte autora, jak se Vám to povedlo", 64, "Hledání sestavy")
Resume Next
End Function
Tento požadavek je zdánlivě snadno řešitelný pomocí vstupní masky. Bohužel se při její realizaci projevovaly potíže související s nekompatibilitou oddělovačů. Vstupní maska (Input Mask) zadaná u této položky v tabulce má tvar 99,9;0;*. Při vložení této položky do formuláře se přenese také vstupní maska, avšak ve tvaru 99.9;0;*. Rozdíl mezi tečkou a čárkou způsobuje, že do prázdné položky je možno zapsat hodnotu skutečně jen na jednu desetinu, ale nelze ji pak opravit. Jedině zrušit její obsah a následně zadat nový obsah (pokud to ovšem není v rozporu s požadovaným obsahem položky - Validation Rule). Pokus o vyřešení problému zadáním formátu (Format) Fixed s udáním počtu platných míst (Decimal Places) na 1 nemá na počet vkládaných míst žádný vliv. Problém se podařilo vyřešit až úpravou podmínky pro obsah položky (Validation Rule) ve znění:
Fix([položka]*10 + 0,001)/10=[položka]
Za povšimnutí stojí zejména použití funkce Fix(), která vrací celou část čísla. Ve srovnání s podobnou funkcí Int(), platí následující:
Fix(99,6) = 99 Int(99,6) = 99
Fix(-99,5) = -99 Int(-99,5) = -100
Pokud někomu není zřejmý důvod přičtení konstanty 0,001 k argumentu funkce, nechž si vyzkouší vypočítat 15% z 5000,- Kč se zaokrouhlením na celé koruny dolů (typický výpočet srážkové daně). Pomocí funkce Fix() zjistíme, že Fix(0,15 * 5000) = 749. To se zajisté liší od správné částky 750 Kč. Důvodem je nepřesné ukládání čísel v počítači. Výsledek operace v argumentu funkce je pro uložení zaokrouhlen dolů a funkce Fix() vrátí skutečně nejblíže nižší celé číslo, tedy nutně 749.
Pokud se nám z nějakého důvodu nehodí použít pro vkládání hodnot standardní objekt Combo Box nebo List Box, můžeme využít vkládání pomocí nabídky hodnot. Pro její otevření se obvykle používá tlačítko se třemi tečkami. Důvodem může být např. požadavek na možnost editovat, doplňovat či vypouštět nabízené hodnoty. V seznamu hodnot, např. viz obr. 38, vybereme požadovanou hodnotu, po uzavření formuláře je vybraná hodnota přenesena do hlavního formuláře.
Často je vhodné, aby uživatel nemohl přímo manipulovat s jednotlivými hodnotami seznamu. Proto je formulář se seznamem hodnot nastaven jen pro čtení (Read Only). K manipulaci s hodnotami slouží speciální tlačítka v jeho dolní části, která vyvolají speciální funkci a po jejím skončení vyvolají činnost zobrazení všech záznamů z menu (Records-Show All Records), jinak by se provedené zrušení nebo vložení nové hodnoty ve formuláři správně neprojevilo. To se netýká opravy hodnoty, u ní je to zbytečné.
Obr. 38. Formulář pro práci se seznamem hodnot
Function NabidkaOpravText (TB As String, Pol As String, TEX As String)
' ****************************************************************
' V zadané tabulce nabídek najde v zadané položce zadanou hodnotu,
' a zamění ji za hodnotu zadanou ručně.
' ****************************************************************
Dim D As Database, R As Recordset
NabidkaOpravText = False
If IsNull(TB) Or TB = "" Then
' Nebyla zadána požadovaná tabulka
Exit Function
End If
If IsNull(Pol) Or Pol = "" Then
' Nebyla zadána požadovaná položka
Exit Function
End If
If IsNull(TEX) Or TEX = "" Then
' Nebyla zadána požadovaná hodnota
Exit Function
End If
Set D = DBENGINE(0)(0)
If Not Je_tabulka(TB, D) Then
' Požadovaná tabulka neexistuje
Exit Function
End If
Set R = D.OpenRecordset(TB, DB_OPEN_DYNASET)
On Error GoTo Err_NabidkaOpravText
Do Until R.EOF
If R(Pol) = TEX And Len(R(Pol)) = Len(TEX) Then
' Načtení požadované hodnoty
TEX = InputBox("Zadejte požadovanou novou hodnotu :")
If IsNull(TEX) Or TEX = "" Then
' Nebyla zadána požadovaná hodnota
Exit Function
End If
' Nekontroluje se, zda není hodnota zadána duplicitně
R.Edit
R(Pol) = TEX
R.Update
NabidkaOpravText = True
Exit Function
End If
R.MoveNext
Loop
' Požadovaná hodnota nebyla nalezena
Exit Function
Err_NabidkaOpravText:
Exit Function
End Function
Function NabidkaSmazText (TB As String, Pol As String, TEX As String)
' ****************************************************************
' V zadané tabulce nabídek najde v zadané položce žádanou hodnotu
' a smaže ji. Pokud je současně otevřen formulář zpřístupňující
' nabídkovou tabulku, je třeba vynutit příkaz menu
' Records-Show All Records k překreslení formuláře
' ****************************************************************
Dim D As Database, R As Recordset
NabidkaSmazText = False
If IsNull(TB) Or TB = "" Then
' Nebyla zadána požadovaná tabulka
Exit Function
End If
If IsNull(Pol) Or Pol = "" Then
' Nebyla zadána požadovaná položka
Exit Function
End If
If IsNull(TEX) Or TEX = "" Then
' Nebyla zadána požadovaná hodnota
Exit Function
End If
Set D = DBENGINE(0)(0)
If Not Je_tabulka(TB, D) Then
' Požadovaná tabulka neexistuje
Exit Function
End If
Set R = D.OpenRecordset(TB, DB_OPEN_DYNASET)
On Error GoTo Err_NabidkaSmazText
Do Until R.EOF
If R(Pol) = TEX And Len(R(Pol)) = Len(TEX) Then
R.Delete
NabidkaSmazText = True
Exit Function
End If
R.MoveNext
Loop
Exit Function
Err_NabidkaSmazText:
Exit Function
End Function
Function NabidkaVlozText (TB As String, Pol As String)
' ****************************************************************
' Do zadané tabulky nabídek, do zadané položky vloží ručně
' zadanou novou hodnotu, pokud se tam dosud nenachází
' a zamění ji za hodnotu zadanou ručně.
' Pokud je současně otevřen formulář zpřístupňující nabídkovou
' tabulku, je třeba vynutit příkaz menu Records-Show All Records
' k překreslení formuláře
' ****************************************************************
Dim D As Database, R As Recordset, TEX As String
NabidkaVlozText = False
If IsNull(TB) Or TB = "" Then
' Nebyla zadána požadovaná tabulka
Exit Function
End If
If IsNull(Pol) Or Pol = "" Then
' Nebyla zadána požadovaná položka
Exit Function
End If
' Načtení požadované hodnoty
TEX = InputBox("Zadejte požadovanou novou hodnotu :")
If IsNull(TEX) Or TEX = "" Then
' Nebyla zadána požadovaná hodnota
Exit Function
End If
Set D = DBENGINE(0)(0)
If Not Je_tabulka(TB, D) Then
' Požadovaná tabulka neexistuje
Exit Function
End If
Set R = D.OpenRecordset(TB, DB_OPEN_DYNASET)
On Error GoTo Err_NabidkaVlozText
Do Until R.EOF
If R(Pol) = TEX And Len(R(Pol)) = Len(TEX) Then
Exit Function
End If
R.MoveNext
Loop
' Požadovaná hodnota nebyla nalezena
R.AddNew
R(Pol) = TEX
R.Update
NabidkaVlozText = True
Exit Function
Err_NabidkaVlozText:
Exit Function
End Function
V některých aplikacích je požadováno, aby uživatel mohl měnit přístup k položkám formuláře během práce s ním (tedy bez jeho uzavření a opětovného otevření). Nejjednodušší je vyvolat podle požadavku funkci, která změní nastavení vlastnosti Default Editing určeného formuláře podle konkrétního požadavku.
Výhodou tohoto řešení je skutečnost, že tato změna se neprojeví v uložené definici formuláře, takže po jeho opětovném otevření bude nastavení opět původní.
Function ZmenaPristupu (FR As String, Stav As Integer)
' ************************************************************
' Pokud je zadaný formulář FR otevřen, nastaví přístup
' k datům podle požadovaného stavu
' 1 - Data Entry - jen vkládání záznamů
' 2 - Alow Edits - editace i vkládání záznamů
' 3 - Read Only - jen pro čtení
' 4 - Can't Add Records - nelze přidávat záznamy
' ************************************************************
ZmenaPristupu = False
If IsNull(FR) Or FR = "" Then
' Nebyl zadán požadovaný formulář
Exit Function
End If
If Stav < 1 Or Stav > 4 Then
' Požadovaný stav není možno nastavit
Exit Function
End If
If Not Formular_otevren(FR) Then
' Formulář není otevřen
Exit Function
End If
On Error GoTo Err_ZmenaPristupu
Forms(FR).DefaultEditing = Stav
ZmenaPristupu = True
Exit Function
Err_ZmenaPristupu:
Exit Function
End Function
Druhou možností je změna vlastností Enabled (případně Locked) u jednotlivých objektů formuláře. Následující funkce provádí nastavení u všech datových objektů určeného formuláře podle požadovaného nastavení. Při konkrétním použití je třeba si uvědomit rozdíl v těchto vlastnostech. Vlastnost Enabled má hodnoty True - objekt je přístupný, False - objekt není přístupný, nevstupuje do něj kurzor, navíc je zobrazen šedou barvou, včetně svázaného popisu (připojený objekt Label). Naproti tomu vlastnost Locked má hodnoty True - objekt nemá povoleno měnit obsah, kurzor do něj však vstupuje, barva zobrazení se nemění, False - objekt je přístupný, lze měnit jeho obsah.
Function ZmenaEnabled (FR As String, Stav As Integer)
' ************************************************************
' Pokud je zadaný formulář FR otevřen, nastaví u všech objektů
' pro vkládání údajů vlastnost Enabled na hodnotu Stav.
' Pokud je objekt právě používán, nelze ho změnit, proto
' je nutno funkci spouštět tlačítkem, které se nemění.
' ************************************************************
Dim F As Form, C As Control, I As Integer
ZmenaEnabled = False
If IsNull(FR) Or FR = "" Then
' Nebyl zadán požadovaný formulář
Exit Function
End If
If Stav <> True And Stav <> False Then
' Požadovaný stav není možno nastavit
Exit Function
End If
If Not Formular_otevren(FR) Then
' Formulář není otevřen
Exit Function
End If
On Error Resume Next
Set F = Forms(FR)
For I = 0 To F.Count - 1
Set C = F(I)
If TypeOf C Is BoundObjectFrame Then
C.Enabled = Stav
End If
If TypeOf C Is ComboBox Then
C.Enabled = Stav
End If
If TypeOf C Is ToggleButton Then
C.Enabled = Stav
End If
If TypeOf C Is CheckBox Then
C.Enabled = Stav
End If
If TypeOf C Is OptionButton Then
C.Enabled = Stav
End If
If TypeOf C Is SubForm Then
C.Enabled = Stav
End If
If TypeOf C Is OptionGroup Then
C.Enabled = Stav
End If
If TypeOf C Is ListBox Then
C.Enabled = Stav
End If
If TypeOf C Is TextBox Then
C.Enabled = Stav
End If
Next I
ZmenaEnabled = True
End Function
Někdy je však popsané řešení nedostatečné, zejména tehdy, když jsou ve formuláři některé položky, které mají být přístupné vždy a jiné, které se mají měnit. Nejjednodušší úpravou, která nesnižuje příliš obecnost řešení, je využití vlastnosti Tag položek, jejichž přístupnost chceme měnit. Např. do této vlastnosti umístíme text „Enabled", „Locked" apod., podle toho, kterou změnu mají povolenu. Funkci pak doplníme ihned za připojení objektu formuláře (Set C = F(I)) testem
If InStr(C.Tag, "Enabled") > 0 Then
.... provedení změny
End If
Výhodou tohoto řešení je možnost povolit u každého objektu změnu libovolné kombinace vlastností.