Email from MS Access

Sub SendEmail()
    Dim appOutlook As New Outlook.Application
    Dim qdf1 As DAO.QueryDef
    Dim rs1 As DAO.Recordset
    Dim qdf2 As DAO.QueryDef
    Dim rs2 As DAO.Recordset
    Dim strSql As String
    Dim strEmailDistro As String
    Dim strSubject As String
    Dim strHeader As String
    Dim strContent As String
    Dim strFooter As String
    Dim strBody As String
    Dim blnSuccessful As Boolean
    Dim strHTML As String
    Dim objEmail As Outlook.MailItem
      
'simple query to grab the emails from the table. modify this as you need to. since you are linking to SP list, just point your query there.
strSqlEmail = "SELECT tblSubscribers.Email FROM tblSubscribers ;"
 
'run the query and set it as the recordset to cycle through
Set qdf1 = CurrentDb.CreateQueryDef("", strSqlEmail)
Set rs1 = qdf1.OpenRecordset
 
'create outlook session
Set objEmail = appOutlook.CreateItem(olMailItem)
'start building the email distro list
A = 1
Do Until rs1.EOF
    strEmail = rs1![Email] & "; "
    strEmailDistro = strEmail + strEmailDistro
    A = A + 1
    rs1.MoveNext
    Debug.Print strEmailDistro
Loop
 
'put whatever error trapping code you have here, this just looks to make sure that the email list is not null
If IsEmpty(strEmailDistro) Then
    Set rs1 = Nothing
    Set qdf1 = Nothing
    Exit Sub
End If

strSqlFact = "SELECT DatabaseName from tblFiles ORDER BY rnd(ID);"


'run the query and set it as the recordset to cycle through
Set qdf2 = CurrentDb.CreateQueryDef("", strSqlFact)
Set rs2 = qdf2.OpenRecordset



strFact = rs2![DatabaseName] & "; "
strLink = strFact
 
'put whatever error trapping code you have here, this just looks to make sure that the email list is not null
If IsEmpty(strLink) Then
    Set rs2 = Nothing
    Set qdf2 = Nothing
    Exit Sub
End If

 
'set what you want the subject of the email to be
strSubject = "Newsletter of the Month!"
           
    
    strEmailBody = "Greeting from your Newsletter team. Below you will find this months single slide safety fact."
    strEmailBody = strEmailBody & vbLf & "\\frz38\News\Data\Mnthly\Newsletter\Publish\" & strLink
    Debug.Print strHTML
    
    'send the email out!
    With objEmail
         .To = strEmailDistro
        .Subject = strSubject
        .Body = strEmailBody
        .Send
    End With
    
    
Set rs1 = Nothing
Set qdf1 = Nothing
If appOutlook Is Nothing Then Else Set appOutlook = Nothing
 
End Sub

Select allOpen in new window