Access 2016. Controle op invoer ongeldige leestekens in formulier.

Status
Niet open voor verdere reacties.
K

KPTPTT

Gebruiker
Lid geworden
2 mrt 2018
Berichten
321
Hallo. Ik heb een formulier (Access 2016) en wil bij een bepaald veld de invoer controleren dat bepaalde leestekens niet kunnen worden gebruikt. Er mogen alleen hoofd-, kleine letters, cijfers en de leestekens _ - ( ) . en spatie worden gebruikt, de overige tekens zijn niet toegestaan. De lengte van het aantal in te voeren karakters is willekeurig.

Het betreffende veld in de tabel biedt de mogelijkheden voor een invoermasker, maar dat begrenst het in te voeren aantal karakters, en een validatieregel. Ik heb al wat geprobeerd met de validatieregel maar dat lukt niet. Hoe zou ik het kunnen doen?
 
Je vraagt ‘hoe’ en dat is simpel. Ik gebruik in dit soort gevallen een functie die de ingevoerde tekst (gebeurtenis: Bij wijzigen) controleert tijdens het typen. Letters en cijfers vallen in een aaneengesloten range, dus die kun je makkelijk definiëren; de overige tekens kun je apart checken. Dus voor het hele verhaal maak je een Select Case die de laatste ingevoerde letter controleert op de toegestane reeksen (ASCII waarden). Voldoet het teken niet, dan haal je hem weg uit het tekstveld.
 
Dank voor je antwoord. Ik heb het eea geprobeerd maar het resultaat blijft uit.
Er is sprake van een formulier met het veld "og_Naam tenaamstelling". De invoer van dit tekstveld moet op bepaalde karakters worden gecontroleerd.Er mogen alleen hoofd-, kleine letters, cijfers en de leestekens _ - ( ) . en spatie worden gebruikt, de overige tekens zijn niet toegestaan.
Ik heb de code getest:
PHP: 
Private Sub og_Naam_tenaamstelling_Change()
Dim KeyAscii As String
KeyAscii = "og_Naam tenaamstelling"             'input van het formulierveld.

Select Case KeyAscii
    Case Asc("0") To Asc("9")
    If KeyAscii = [Asc("0") To Asc("9")] Then
        End If
    Case Asc("a") To Asc("z")
        If KeyAscii = [("a") To Asc("z")] Then
        End If
    Case Asc("A") To Asc("Z")
        If KeyAscii = [Asc("A") To Asc("Z")] Then
        End If
    Case Asc(".")
        If KeyAscii = [Asc(".")] Then
        End If
    Case Asc("_")
        If KeyAscii = [Asc("_")] Then
        End If
    Case Asc("_")
        If KeyAscii = [Asc("_")] Then
        End If
    Case Asc(" ")
        If KeyAscii = [Asc(" ")] Then
        End If
    Case Asc("(")
        If KeyAscii = [Asc("(")] Then
        End If
    Case Asc(")")
            If KeyAscii = [Asc(")")] Then
        End If
    Case Else
        KeyAscii = 0
End Select
End Sub

Deze code zal onvolledig en niet juist zijn. Hoe kan ik het verbeteren? Alvast bedankt.
 
Er mankeert inderdaad nogal wat aan je code. Ik zal hem herschrijven naar wat bruikbaars.
 
Hallo OctaFish. Als je gelegenheid hebt, wil je dan svp. naar mijn vraag kijken. Bedankt.
 
Hallo OctaFish. Ik wil niet opdringen maar staat mijn vraag nog op je "To-do-list"? Ik hoop van wel, omdat ik je antwoorden waardeer. Bedankt.
 
Ah, de todo list :). Ik schuif 'm weer wat naar boven :).
 
Michel heeft het druk blijkbaar dus post ik even hoe ik het doe, misschien ben je er wat mee; een functie die opgeroepen wordt voordat je een veld "TxtEmail" verlaat
Code: 
Private Sub TxtEmail_BeforeUpdate(Cancel As Integer)
On Error GoTo Err_TxtEmail_BeforeUpdate
Dim Reason As String
 
'Dit voert een controle uit bij wijzigen en verlaten van het veld
If Nz(TxtEmail) <> "" Then
     If IsEMailAddress(TxtEmail, Reason) = False Then
        MsgBox "Ongeldig mail adres, reden: " & Reason
           Cancel = True
           Exit Sub
     End If
 End If
Exit_TxtEmail_BeforeUpdate:
    Exit Sub

Err_TxtEmail_BeforeUpdate:
    MsgBox Err.Description
    Resume Exit_TxtEmail_BeforeUpdate
    
End Sub

De functie zelf, veel te uitgebreid zullen er misschien velen zeggen, maar het werkt wel en zet je misschien aan in de goede richting :)
Code: 
Public Function IsEMailAddress(ByVal sEmail As String, _
 Optional ByRef sReason As String) As Boolean
 
' Als de functie een false retourneert wordt de reden daarvoor meegegeven in de optionele reason string
'IsValid = IsEMailAddress("johan@johan.be", InvalidReason)
'MsgBox "Invalid mail address, de reden is: " & InvalidReason
 
Dim IsValid As Boolean
 Dim InvalidReason, OK As String
 Dim sPreffix As String
 Dim sSuffix As String
 Dim sMiddle As String
 Dim nCharacter As Integer
 Dim sBuffer As String
 
sEmail = Trim(sEmail)
 
If Len(sEmail) < 8 Then
 sReason = "Te kort mailadres"
 Exit Function
 End If
 
If LCase(Right(sEmail, 1)) Like "[a-z]" Then
 GoTo CheckAt
 End If
 sReason = "Niet toegelaten karakter op einde" ' Check voor '.' etc op het einde
 Exit Function
 
CheckAt:
 If InStr(sEmail, "@") = 0 Then
 sReason = "Missend @ in het mailadres"
 Exit Function
 End If
 
If InStr(InStr(sEmail, "@") + 1, sEmail, "@") < 0 Then
 sReason = "Te veel @ in het mailadres"
 Exit Function
 End If
 
If InStr(sEmail, ".") = 0 Then
 sReason = "Missend . in het mailadres"
 Exit Function
 End If
 
If InStr(sEmail, "@.") >= 1 Then
 sReason = "Missend achtervoegsel in het mailadres"
 Exit Function
 End If
If InStr(sEmail, ".@") >= 1 Then
 sReason = "Zeker dat er een .@ staat in het mailadres?"
 Exit Function
 End If
If InStr(sEmail, "..") = 1 Then
 sReason = "Twee .. na elkaar is niet gebruikelijk in een mailadres!"
 Exit Function
 End If
If InStr(sEmail, "@") = 1 Or InStr(sEmail, "@") = Len(sEmail) Or _
 InStr(sEmail, ".") = 1 Or InStr(sEmail, ".") = Len(sEmail) Then
 sReason = "Niet toegelaten formaat van het mailadres"
 Exit Function
 End If
 
For nCharacter = 1 To Len(sEmail)
 sBuffer = Mid$(sEmail, nCharacter, 1)
 If Not (LCase(sBuffer) Like "[a-z]" Or sBuffer = "@" Or _
 sBuffer = "." Or sBuffer = "-" Or sBuffer = "_" Or IsNumeric(sBuffer)) Then
 sReason = "Niet toegelaten karakter in het mailadres"
 Exit Function
 End If
 Next nCharacter
 
nCharacter = 0
 
On Error Resume Next
 
sBuffer = Right(sEmail, 4)
 If InStr(sBuffer, ".") = 0 Then GoTo TooLong:
 If Left(sBuffer, 1) = "." Then sBuffer = Right(sBuffer, 3)
 If Left(Right(sBuffer, 3), 1) = "." Then sBuffer = Right(sBuffer, 2)
 If Left(Right(sBuffer, 2), 1) = "." Then sBuffer = Right(sBuffer, 1)
 
If Len(sBuffer) < 2 Then
 sReason = "Topleveldomein is te kort (landextensie aan de mail bv . be), minimum 2 kakrakters "
 Exit Function
 End If
 
TooLong:
 If Len(sBuffer) > 3 Then
 sReason = "Topleveldomein is te lang (landextensie aan de mail bv . be), maximum 3 kakrakters"
 Exit Function
 End If
 
sReason = Empty ' We raakten tot hier dus zal 't adress wel OK zijn.
 IsEMailAddress = True
 
End Function
 
Bedankt en fijn je code hebt bijgevoegd. Ik ga het bestuderen, bedankt.
 
Het is gelukt, top voor de input. Ik heb het volgende er van gemaakt. Het betreft geen controle op invoer e-mails maar op namen etc. Wat niet lukt is de controle op de aanhalingsteken " ( Or sBuffer = """ ) Hoe kan ik dit nog goed krijgen?
Er wordt een foutmelding gegeven. Ik word steeds enthousiaster met de mogelijkheden van VBA. Bedankt voor de hulp.
Code: 
Private Sub m_Naam_Exit(Cancel As Integer)
'Kontrole op ongeldige invoer van leestekens in het veld <Naam Verplicht>
 
 Dim sReason As String
 Dim nCharacter As Integer
 Dim sBuffer As String
 Dim sName As String
 
 sName = [m_Naam]
 sName = Trim(sName)
 sReason = "Niet toegelaten karakter in  [Naam uitvoerder]"

For nCharacter = 1 To Len(sName)
 sBuffer = Mid$(sName, nCharacter, 1)
 If (sBuffer = "#" Or sBuffer = "$" Or sBuffer = "!" Or sBuffer = "@" Or sBuffer = "%" Or sBuffer = "^" Or sBuffer = "&" Or sBuffer = "*" Or sBuffer = "|" Or sBuffer = "+" _
 Or sBuffer = "=" Or sBuffer = "[" Or sBuffer = "]" Or sBuffer = "\" Or sBuffer = "/" _
 Or sBuffer = "<" Or sBuffer = ">" Or sBuffer = "," Or sBuffer = "?" Or sBuffer = "'" Or sBuffer = ";" Or sBuffer = ":" Or sBuffer = "'" Or sBuffer = ";" Or sBuffer = ";") Then
 MsgBox sReason
 Exit For
End If
 
 Next nCharacter
 
 nCharacter = 0
 
On Error Resume Next
End Sub
 
Ik zou deze oplossing zo niet gebouwd hebben, maar waarschijnlijk verwacht je dat van mij ook niet :). Dit is mijn oplossing:
Code: 
Private Sub Tekst0_Change()
    With Me.ActiveControl
        If Len(.Text) > 0 Then
            If CheckTekst(Right(.Text, 1)) = False Then
                .Text = Left(.Text, Len(.Text) - 1)
                .SelStart = Len(.Text)
            End If
        End If
    End With
End Sub

Code: 
Function CheckTekst(lttr As String) As Boolean
    Select Case Asc(lttr)
        Case 48 To 57, 65 To 90, 97 To 122
            CheckTekst = True
        Case 32, 40, 41, 45, 46, 95
            CheckTekst = True
        Case Else
            CheckTekst = False
    End Select
End Function

Uiteraard heet jouw tekstveld anders, dus die naam moet je in de eerste regel aanpassen. Al kun je ook alles tussen de Private Sub en End Sub kopiëren, want de code is niet afhankelijk van een veldnaam.
 
Dank OctaFish. Je oplossing ziet er qua code goed uit en heeft mijn voorkeur echter heb ik mijn code, op basis van de code van JohanOVT, toegepast. Het werkt goed en heb het op verschillende plaatsen in de db met succes toegepast. Ik ga je code testen en mogelijk toepassen, het is wat compacter. Het lost ook mijn probleem met karakter 34 (") op. Nogmaals dank.
 
Er zijn nog wat uitbreidingen denkbaar voor accenttekens, daar heb ik nog geen rekening mee gehouden. Vermoedelijk vallen die in een ASCII range die je makkelijk kan toevoegen.
Omgekeerd werken kan natuurlijk ook: alle niet-gewenste tekens eruit halen door de cases te baseren op die tekens en dan TRUE en FALSE omdraaien.
 
IK heb de ASCII tabel erbij gehaald en eea. aangepast maar als ik de sub uitvoer, dan wordt een foutmelding gegeven in regel If CheckTekst(Right(.Text, 1)) = False Then "Compileerfout in CheckTekst - Er wordt een matrix verwacht". Bij Verlaten of Wijzigen maakt niets uit.
Code: 
Private Sub og_Naam_tenaamstelling_Exit(Cancel As Integer)
 Dim CheckTekst As String
     With Me.ActiveControl
        If Len(.Text) > 0 Then
            If CheckTekst(Right(.Text, 1)) = False Then
                .Text = Left(.Text, Len(.Text) - 1)
                .SelStart = Len(.Text)
            End If
        End If
    End With
    
Function CheckTest(lttr As String) As Boolean
    Select Case Asc(lttr)
        Case 48 To 57, 65 To 90, 97 To 122
            CheckTekst = True
        Case 32
            CheckTekst = True
        Case Else
            CheckTekst = False
    End Select
End Function
End Sub
 
Ik had ‘m niet voor niets bij de Change gezet; de eigenschap .Text kun je alleen gebruiken bij objecten die de focus hebben. Bij Change is dat het geval, bij Exit uiteraard niet, want daarmee verplaats je juist de focus. Als je de code bij <Bij Wijzigen> gebruikt, moet hij dus werken.
 
Dan wil ik wel eens een voorbeeldje zien, want ik heb de code letterlijk uit een werkend voorbeeld getrokken. Dus ik weet dat hij perfect werkt.
 
Hierbij het voorbeeld.
Code: 
Private Sub og_Naam_tenaamstelling_Change()
Dim CheckTekst As String
     With Me.ActiveControl
        If Len(.Text) > 0 Then
            If CheckTekst(Right(.Text, 1)) = False Then
                .Text = Left(.Text, Len(.Text) - 1)
                .SelStart = Len(.Text)
            End If
        End If
    End With
    
Function CheckTest(lttr As String) As Boolean
    Select Case Asc(lttr)
        Case 48 To 57, 65 To 90, 97 To 122
            CheckTekst = True
        Case 32
            CheckTekst = True
        Case Else
            CheckTekst = False

    End Select
End Function
 
End Sub
 
Dit is geen voorbeeldje, maar code. En die had je al gepost :).
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan