Microsoft Access

Na podstawie wersji 2003 zainstalowanej na Windows XP na QEMU/KVM.

• Plik źródłowy autora tabel aplikacji: source-database.mdb
• Plik roboczy tabel: database.mdb
• Plik źródłowy autora formularzy: source-forms.mdb
• Plik roboczy formularzy: forms.mde
• Jeżeli z bazą pracuje kilku użytkowników to plik database.mdb udostępniony w udziale sieciowym, a pliki forms.mde, forms-1.mde, forms-n.mde na każdym z komputerów użytkowników.

przy uruchomieniu aplikacji:

W oknie Visual Basic. Okno Immediate.

CurrentDb.Properties.Append CurrentDb.CreateProperty("AllowBypassKey", 1, False)

Przywrócenie

CurrentDb.Properties.Append CurrentDb.CreateProperty("AllowBypassKey", 1, True)

• Narzędzia → Uruchamianie > Wyświetl okno bazy danych: off
• Narzędzia → Uruchamianie > Użyj specjalnych klawiszy programu access: off
• Narzędzia → Uruchamianie > Wyświetl formularz/stronę: Wybrać formularz startowy
• Narzędzia → Uruchamianie > Zezwalaj na pełne menu: off
• Narzędzia → Uruchamianie > Zezwalaj na wbudowane paski narzędzi: off

• Nazwa tabeli: ludzie
• Nazwy pól w tabeli: ID, txtImie, txtNazwisko, txtNrEwid
• Wszystkie pola dodane do formularza. Pole ID jako niewidoczne.

Dodanie skryptu do formularza.

Private Sub Form_BeforeUpdate(Cancel As Integer)
    Dim strImie As String
    Dim strNazwisko As String
    Dim strNrEwid As String
 
    ' Sprawdź puste pola
    If IsNull(Me.txtImie) Or Trim(Me.txtImie & "") = "" Then
        MsgBox "Pole 'Imię' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtImie.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    If IsNull(Me.txtNazwisko) Or Trim(Me.txtNazwisko & "") = "" Then
        MsgBox "Pole 'Nazwisko' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtNazwisko.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    If IsNull(Me.txtNrEwid) Or Trim(Me.txtNrEwid & "") = "" Then
        MsgBox "Pole 'Nr ewidencyjny' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtNrEwid.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    ' Przypisz wartości
    strImie = Me.txtImie & ""
    strNazwisko = Me.txtNazwisko & ""
    strNrEwid = Me.txtNrEwid & ""
 
    ' Sprawdź duplikat pary (Imię+Nazwisko)
    ' Uwaga: używam nazw pól TAKICH JAK W TABELI
    If DCount("*", "ludzie", "[txtImie] = '" & strImie & "' AND [txtNazwisko] = '" & strNazwisko & "' AND [ID] <> " & Nz(Me.ID, 0)) > 0 Then
        MsgBox "Uwaga! Osoba '" & strImie & " " & strNazwisko & "' już istnieje w bazie.", vbExclamation, "Zduplikowany wpis"
        Cancel = True
        Me.txtImie.SetFocus
        Exit Sub
    End If
 
    ' Sprawdź unikalność nrEwid
    If DCount("*", "ludzie", "[txtNrEwid] = '" & strNrEwid & "' AND [ID] <> " & Nz(Me.ID, 0)) > 0 Then
        MsgBox "Uwaga! Numer ewidencyjny '" & strNrEwid & "' już istnieje w bazie.", vbExclamation, "Zduplikowany numer"
        Cancel = True
        Me.txtNrEwid.SetFocus
        Exit Sub
    End If
End Sub

• Nazwa tabeli: urzadzenia
• Pola w tabeli: ID, txtIndeks, txtNazwa, txtTyp, txtRysunek
• Warunki:
  • txtIndeks nie może się powtarzać
  • txtNazwa może się powtórzyć jeżeli txtTyp lub txtRysunek będzie inny
  • txtTyp lub txtRysunek mogą się powtarzać o ile jedno z nich będzie różne od poprzedniej pary

Private Sub Form_BeforeUpdate(Cancel As Integer)
    Dim strIndeks As String
    Dim strNazwa As String
    Dim strTyp As String
    Dim strRysunek As String
    Dim czysty As String
    Dim i As Integer
 
    ' ========== FORMATOWANIE txtIndeks (zamiast osobnego AfterUpdate) ==========
 
    If Not IsNull(Me.txtIndeks) Then
        ' Usuń wszystko co nie jest cyfrą
        czysty = ""
        For i = 1 To Len(Me.txtIndeks & "")
            If IsNumeric(Mid(Me.txtIndeks, i, 1)) Then
                czysty = czysty & Mid(Me.txtIndeks, i, 1)
            End If
        Next i
 
        ' Nałóż właściwy format
        If Len(czysty) = 12 Then
            Me.txtIndeks = Left(czysty, 4) & " " & Mid(czysty, 5, 3) & " " & Mid(czysty, 8, 3) & " " & Right(czysty, 2)
        ElseIf Len(czysty) > 0 Then
            ' Jeśli nie 12 cyfr, pokaż same cyfry (użytkownik zobaczy błąd za chwilę)
            Me.txtIndeks = czysty
        End If
    End If
 
    ' Pobierz sformatowaną wartość
    strIndeks = Trim(Me.txtIndeks & "")
 
    ' ========== WALIDACJA PUSTYCH PÓL ==========
 
    If IsNull(Me.txtIndeks) Or Trim(Me.txtIndeks & "") = "" Then
        MsgBox "Pole 'Indeks' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtIndeks.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    If IsNull(Me.txtNazwa) Or Trim(Me.txtNazwa & "") = "" Then
        MsgBox "Pole 'Nazwa' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtNazwa.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    If IsNull(Me.txtTyp) Or Trim(Me.txtTyp & "") = "" Then
        MsgBox "Pole 'Typ' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtTyp.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    If IsNull(Me.txtRysunek) Or Trim(Me.txtRysunek & "") = "" Then
        MsgBox "Pole 'Rysunek' nie może być puste.", vbExclamation, "Wymagane pole"
        Me.txtRysunek.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    ' ========== PRZYPISANIE WARTOŚCI ==========
 
    strNazwa = Trim(Me.txtNazwa & "")
    strTyp = Trim(Me.txtTyp & "")
    strRysunek = Trim(Me.txtRysunek & "")
 
    ' ========== WALIDACJA ILOŚCI CYFR ==========
 
    ' Oblicz czysty indeks (bez spacji)
    czysty = Replace(strIndeks, " ", "")
 
    If Len(czysty) <> 12 Then
        MsgBox "Indeks musi zawierać dokładnie 12 cyfr. Format: 0000 000 000 00", vbExclamation, "Nieprawidłowy format"
        Me.txtIndeks.SetFocus
        Cancel = True
        Exit Sub
    End If
 
    ' ========== SPRAWDZENIE UNIKALNOŚCI txtIndeks ==========
 
    If DCount("*", "urzadzenia", "[txtIndeks] = '" & strIndeks & "' AND [ID] <> " & Nz(Me.ID, 0)) > 0 Then
        MsgBox "Uwaga! Indeks '" & strIndeks & "' już istnieje w bazie.", vbExclamation, "Zduplikowany indeks"
        Cancel = True
        Me.txtIndeks.SetFocus
        Exit Sub
    End If
 
    ' ========== SPRAWDZENIE UNIKALNOŚCI PARY (txtTyp + txtRysunek) ==========
 
    If DCount("*", "urzadzenia", "[txtTyp] = '" & strTyp & "' AND [txtRysunek] = '" & strRysunek & "' AND [ID] <> " & Nz(Me.ID, 0)) > 0 Then
        MsgBox "Uwaga! Para Typ '" & strTyp & "' i Rysunek '" & strRysunek & "' już istnieje w bazie.", vbExclamation, "Zduplikowana para"
        Cancel = True
        Me.txtTyp.SetFocus
        Exit Sub
    End If
 
    ' ========== SPRAWDZENIE DLA txtNazwa ==========
 
    If DCount("*", "urzadzenia", "[txtNazwa] = '" & strNazwa & "' AND [txtTyp] = '" & strTyp & "' AND [txtRysunek] = '" & strRysunek & "' AND [ID] <> " & Nz(Me.ID, 0)) > 0 Then
        MsgBox "Uwaga! Urządzenie o nazwie '" & strNazwa & "' z Typem '" & strTyp & "' i Rysunkiem '" & strRysunek & "' już istnieje.", vbExclamation, "Zduplikowany wpis"
        Cancel = True
        Me.txtNazwa.SetFocus
        Exit Sub
    End If
 
    ' Wszystko OK – rekord zostanie zapisany
End Sub    

Obsługa błędów. Sprawdzić działanie i zastosować w każdym formularzu.

Private Sub Form_Error(DataErr As Integer, Response As Integer)
    Select Case DataErr
        Case 2113   ' Nieprawidłowy typ danych
            MsgBox "Wprowadzono nieprawidłowy typ danych. Sprawdź, czy w polu numerycznym nie ma liter.", vbExclamation, "Nieprawidłowa wartość"
            Response = acDataErrContinue
        Case 3022   ' Duplikat (indeks unikalny z tabeli)
            MsgBox "Ta wartość już istnieje w bazie. Wpisz inną.", vbExclamation, "Zduplikowany wpis"
            Response = acDataErrContinue
        Case 3201   ' Naruszenie relacji
            MsgBox "Nie można usunąć/zmienić tego rekordu, ponieważ istnieją powiązane dane w innych tabelach.", vbExclamation, "Naruszenie relacji"
            Response = acDataErrContinue
        Case 3314   ' Wymagane pole puste (gdy ominie walidację formularza)
            MsgBox "Wypełnij wszystkie wymagane pola.", vbExclamation, "Brak wymaganej wartości"
            Response = acDataErrContinue
        Case Else
            Response = acDataErrDisplay
    End Select
End Sub