MS Access - VBA: Sending Email Using Email Addresses in Tables

Question

Using MS Access VBA. Setup is as follows:

• tblUsers contains UserID, UserName, UserSecurityLevel, UserEmail

• tblStewards contains AreaID, AreaName, Stewards where Stewards is set to be a Combo Box from a Lookup Query "SELECT tblUsers.ID, tblUsers.UserName FROM tblUsers" and I allow multiple values (eg, each area has multiple stewards); the Stewards field has a data type of short text

• frmStewardRequest has Record Source tblStewards and is designed for a user to request that the area stewards add a new item; it contains cmbAreaName, txtStewards which autopopulates based on cmbAreaName with Control Source Stewards, some open text fields for supplying the requested item, and a btnSubmitRequest

• for btnSubmitRequest, I have an On Click event that generates an email to the area stewards using this VBA code:

Dim strEmailTo As String
Dim strTxtBody As String

strEmailTo = DLookup("[UserEmail]", "tblUsers", "ID = " & Me.txtSteward)

strTxtBody = "I need a new item in " & Me.cmbAreaName & "..."

DoCmd.SendObject , , acFormatTXT, strEmailTo, , , "New Item Request", strTxtBody, False

There is a problem with getting the email addresses for the area stewards: it doesn't seem this is a string. How can I get the email addresses so this will send properly? (Less important question, is there a way to prevent the pop-up box to Accept the risk of sending this email?)

Answer 1

This is how I do it.

Option Compare Database
Option Explicit
' This database and all the code therein is © 1999-2002 Arvin Meyer arvinm@datastrat.com
' You are free to use this code and this database  in an application
'   as long as you do not publish it without the author's permission.
' Additionally, you are required to include this copyright notice in the application.

Private Sub Form_Open(Cancel As Integer)
On Error GoTo Err_OF
    Dim db As Database
    Dim i As Integer
    Dim contr As Container
    Dim strRptList As String
    Dim strRptName As String
    Dim Length As Integer

   Set db = CurrentDb()
   Set contr = db.Containers("Reports")

    strRptList = ""
    For i = 0 To contr.Documents.Count - 1
       strRptName = contr.Documents(i).name
            If strRptList <> "" Then strRptList = strRptList & "; "
            Length = Len(strRptName)
            strRptList = strRptList & strRptName
    Next i

  Me!lstRpt.RowSource = strRptList

Exit_OF:
     Exit Sub
Err_OF:
    MsgBox Err & " " & Error, , "Report Open"
    Resume Exit_OF

End Sub


Private Sub cmdEmail_Click()
On Error GoTo Err_cmdEmail_Click

    Dim strDocName As String
    Dim strEmail As String
    Dim strMailSubject As String
    Dim strMsg As String

    strDocName = Me.lstRpt
    strEmail = Me.txtSelected & vbNullString
    strMailSubject = Me.txtMailSubject & vbNullString
    strMsg = Me.txtMsg & vbNullString & vbCrLf & vbCrLf & "Your Name" & _
        vbCrLf & "MailTo:youremail@nowhere.com"

    DoCmd.SendObject objecttype:=acSendReport, _
        ObjectName:=strDocName, outputformat:=acFormatHTML, _
        To:=strEmail, Subject:=strMailSubject, MessageText:=strMsg

Exit_cmdEmail_Click:
    Exit Sub

Err_cmdEmail_Click:
    MsgBox Err.Description
    Resume Exit_cmdEmail_Click

End Sub

Private Sub Label15_Click()
Dim hplMail As String
hplMail = "#MailTo:email_senate@datastrat.com#"
Application.FollowHyperlink HyperlinkPart(hplMail, acAddress)
End Sub

Private Sub lstRpt_Click()
    Me.cmdEmail.Enabled = True
End Sub

Private Sub lstMailTo_Click()
Dim varItem As Variant
Dim strList As String

With Me!lstMailTo
    If .MultiSelect = 0 Then
        Me!txtSelected = .Value
    Else
        For Each varItem In .ItemsSelected
            strList = strList & .Column(0, varItem) & ";"
        Next varItem
        strList = Left$(strList, Len(strList) - 1)
        Me!txtSelected = strList
    End If
End With
End Sub

Answer 2

• Table tblStewards Combo Box lookup query SELECT tblUsers.ID, tblUsers.UserName FROM tblUsers needs to be fixed since there is no ID but UserID

• Have used the Split function to check for multiple Steward values and then get their email id using Dlookup

• I prefer using MultiValued fields especially when lookup list is not huge (nothing wrong to use).

---

Dim strStewards As Variant
Dim i As Long

Dim strEmailTo As String
Dim strTxtBody As String


strStewards = Split(Me.txtSteward, ",")
For i = LBound(strStewards) To UBound(strStewards)
    strEmailTo = strEmailTo & ";" & Nz(DLookup("[UserEmail]", "tblUsers", "UserID=" & strStewards(i)), "")
Next

strTxtBody = "I need a new item in " & Me.cmbAreaName & "..."

DoCmd.SendObject , , acFormatTXT, strEmailTo, , , "New Item Request", strTxtBody, False