Email Validation (1 Viewer)

Private Sub Command1_Click()

Dim rs As DAO.Recordset
Dim sql As String
Dim strPath As String
Dim x As String
Dim stDocName As String

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment



DoCmd.SetWarnings False

strPath = "C:\Temp\"
sql = "SELECT DISTINCT StatementTable.Terms, StatementTable.StateFile, StatementTable.Email, StatementTable.CLI_USERIDSERV, StatementTable.CLI_USERIDINBR,  StatementTable.CLI_CLIENTNUMBER, StatementTable.Salutation, StatementTable.SHD_ENDDATE FROM StatementTable;"
Set rs = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
Do While Not rs.EOF
    StateFile = rs!StateFile
    Email = rs!Email
    Salutation = rs!Salutation
    StateMonth = rs!SHD_ENDDATE
    Terms = rs!Terms
    strCLICode = rs!CLI_CLIENTNUMBER
    Servicer = rs!CLI_USERIDSERV
    Broker = rs!CLI_USERIDINBR
 
 
 
 'make new mail message


    SigString = "C:\Temp\Sig\IrlAccounts.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

       
   
   ' Create the Outlook session.
   Set objOutlook = CreateObject("Outlook.Application")
    objOutlook.Session.Logon

   ' Create the message.
   Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

    Set OutApp = CreateObject("Outlook.Application")

   With objOutlookMsg
    If Not IsNull(Email) Then
        Set objOutlookRecip = .Recipients.Add(Email)
        objOutlookRecip.Type = olTo
    Else
        Set objOutlookRecip = .Recipients.Add("Blank@Blank.ie")
        objOutlookRecip.Type = olTo
    
    End If

      ' Set the Subject, Body, and Importance of the message.
      .Subject = "Client Statement Attached"
      .HTMLBody = "<SPAN STYLE='font: 8pt Verdana'>Dear " & Salutation & "<BR></BR><BR></BR>" & _
                 "</span>"

      .Importance = olImportanceHigh  'High importance
      .DeferredDeliveryTime = #9/21/2009 10:15:00 PM#
      
      ' Add attachments to the message.
      If Not IsMissing(AttachmentPath) Then
        AttachmentPath = "C:\Temp\" & StateFile & ".pdf"
        Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        AttachmentPath = "C:\Temp\Bank\" & Terms & ".pdf"
        Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        
      End If

      For Each objOutlookRecip In .Recipients
     
      Next
        .SendUsingAccount = OutApp.Session.Accounts.Item(2)
        .Send

   End With
   Set objOutlookMsg = Nothing
   Set objOutlook = Nothing
   
    rs.MoveNext

' Pause (1) 'for a three second pause
Loop

MsgBox x & " Statement Emailed"

Set rs = Nothing

DoCmd.SetWarnings True

End Sub

Option Compare Database
Option Explicit

Public Function ValidEmail(ByVal Email As String) As Boolean

    If Not HasNoSpace(Email) Then Exit Function
    If HasNoAt(Email) Then Exit Function
    If HasMultipleAts(Email) Then Exit Function
    If AtBookendsAddress(Email) Then Exit Function
    If Not IsDomain(Mid(Email, InStr(1, Email, "@") + 1)) Then Exit Function
    If DotBookends(Mid(Email, InStr(1, Email, "@") + 1)) Then Exit Function
    If DotBookends(Left(Email, InStr(1, Email, "@") - 1)) Then Exit Function
    If IllegalCharacters(Email) Then Exit Function
    
    ValidEmail = True

End Function

Private Function DotBookends(ByVal strMail As String) As Boolean
    If InStr(1, strMail, ".") = Len(strMail) Or _
        InStr(1, strMail, ".") = 1 Then DotBookends = True
End Function

Private Function IsDomain(ByVal strDomain As String) As Boolean
    If InStr(1, strDomain, ".") > 0 Then IsDomain = True
End Function

Private Function HasNoSpace(ByVal strMail As String) As Boolean
    If InStr(1, strMail, " ") = 0 Then HasNoSpace = True
End Function

Private Function HasNoAt(ByVal strMail As String) As Boolean
    If InStr(1, strMail, "@") = 0 Then HasNoAt = True
End Function

Private Function HasMultipleAts(ByVal strMail As String) As Boolean
    Dim intPosition As Integer
    intPosition = InStr(1, strMail, "@")
    intPosition = InStr(intPosition + 1, strMail, "@")
    If intPosition <> 0 Then HasMultipleAts = True
End Function

Private Function AtBookendsAddress(ByVal strMail As String) As Boolean
    If InStr(1, strMail, "@") = Len(strMail) Or _
        InStr(1, strMail, "@") = 1 Then AtBookendsAddress = True
End Function

Private Function IllegalCharacters(ByVal strMail As String) As Boolean
    Dim intCounter As Integer, intCode As Integer
    strMail = UCase(strMail)
    
    For intCounter = 1 To Len(strMail)
        Select Case Mid(strMail, intCounter, 1)
            Case Is = "!", """", "£", "$", "%", "^", "&", "*", "(", ")", "+", "=", "/", _
                "\", "<", ">", ",", ";", ":", "'", "~", "#", "[", "]", "{", "}", "`", "|"
                IllegalCharacters = True
                Exit Function
        End Select
    Next intCounter
End Function