emailcontrole doet niet wat ik wil

[Fredemel]

Public Function blnEmailValid(ByVal strEmailAdd As String) As Boolean
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        .Pattern = "^([a-zA-Z0-9_\-\.]+)@[mindef]+(\.[a-z0-9-]+)*(\.[nl]{2,3})$"
        blnEmailValid = .Test(strEmailAdd)
    End With
End Function

Sub checkMail()
        mailwaarde = Range("email")
        
        Application.Goto Reference:="email"
        Selection.Hyperlinks.Delete
        'ActiveCell.Range("A1:L1").Select
        
    If blnEmailValid(mailwaarde) = True Then
        Application.Goto Range("reeds")
    Else
        MsgBox "U heeft GEEN geldig emailadres ingevoerd" & vbNewLine _
        & "============================================" & vbNewLine & vbNewLine _
        & "Dit mailadres MOET het einde hebben van:  @bedrijf.nl   !!!   En mag geen spaties bevatten."
        Application.Goto Range("email")
        Range("reeds").Select
        Range("email").Select
    End If
End Sub

Als de extensie NN is en ".nl" wordt getyped, ziet de macro 'm toch als een correct mailadres..
Wat zie ik over het hoofd.....?

 

[spaarie]

Misschien is het opgelost door een andere Function

Function IsEmailValid(strEmail)
    Dim strArray As Variant
    Dim strItem As Variant
    Dim i As Long, c As String, blnIsItValid As Boolean
    blnIsItValid = True
     
    i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))
    If i <> 1 Then IsEmailValid = False: Exit Function
    ReDim strArray(1 To 2)
    strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)
    strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")
    For Each strItem In strArray
        If Len(strItem) <= 0 Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
        For i = 1 To Len(strItem)
            c = LCase(Mid(strItem, i, 1))
            If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
                blnIsItValid = False
                IsEmailValid = blnIsItValid
                Exit Function
            End If
        Next i
        If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then
            blnIsItValid = False
            IsEmailValid = blnIsItValid
            Exit Function
        End If
    Next strItem
    If InStr(strArray(2), ".") <= 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    i = Len(strArray(2)) - InStrRev(strArray(2), ".")
    If i <> 2 And i <> 3 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    If InStr(strEmail, "..") > 0 Then
        blnIsItValid = False
        IsEmailValid = blnIsItValid
        Exit Function
    End If
    IsEmailValid = blnIsItValid
End Function

 

[alphamax]

eindigen niet alle adressen op @mindef.nl of is er ook @landmacht.mindef.nl, @marine.mindef.nl en @luchtmacht.mindef.nl