Email From Access to Multiple Addresses

[SmokeEater1]

I have a table (tblEmail) with one field [Email} that contains between 300-400 email addresses. I would like to use a command button, or module, to open Outlook, and autofill all of the email addresses into the BCC field. From there I will complete the rest of the email manually. My current practice of importing the email address into the Outlook Contants area is VERY time consuming, and with new addresses being added, others changing, others being deleted, it is not worth it to keep doing it that way.

I've looked at, and tried some coding examples, but am not having much luck. I figure with a one 'field" table it shouldn't be too hard to do, but am not experienced enough in coding to figure it out totally by myself.

Thanks in advance for any assistance provided.

 

[p27br]

do you mean you have one record in your table which contains a field with 300-400 addresses or your table has one field and 300-400 records ?

 

[SmokeEater1]

One field with 300-400 records.

 

[sxschech]

Here is an example of importing email addresses into outlook. You would need to modify it for your purpose. The first part of the code works off a command button on a form and the second part is placed in a module. The first code takes data from the form as well as from the table you set up containing the email addresses and then it calls the code module to generate the email. The main code creates one email per person and allows for attachments (some portions of the attachment code has been commented out, but can be used if needed or removed altogether) and predefined messages, I have left that as is in case others may be looking for that purpose.

From your post, it sounds as if you want to create one email with all the names. In that case, you would need to substitute the following into the "rs" loop in the main code and perhaps make other modifications:

---------------------------------
'Use to create one email with all the names
With rs
.MoveLast
.MoveFirst
While Not .EOF
stBCC = stBCC & rs!Email_id & "; "
.MoveNext
Wend
End With
----------------------------------

Remember to set a reference to DAO if using 2000 or above.

Put in OnClick event of your form's Button

Private Sub optEmail_Click()
    'Send PDF file to recipients as email attachment
    'email body text determined by option group selection
    Dim stSubject As String
    Dim stTo As String
    Dim stCc As String
    Dim stBcc as String
    Dim stBody As String
    Dim stDate As String
    Dim stECPNo As String
    Dim stPathFile As String
    Dim stSQL As String
    Dim intOptionNumber As Integer    'Used for adding an additional attachment.  May need to be fixed.
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    
    'Generate Email one at a time from table containing email addresses
    Set db = CurrentDb
    Set rs = db.OpenRecordset("Select * from qryAREmail;", dbOpenSnapshot)
    
    
    With rs
        If .RecordCount = 0 Then
            Exit Sub
        End If
        .MoveLast
        .MoveFirst
        While Not .EOF
            'Build one line entry and email body with predefined message with two alternatives
            If ARStatus Then
                stSubject = "AR Due in 3 Months"
                stBody = !FirstName & ", Your AR is due on " & !ARDate & "."
            Else
                stSubject = "AR Overdue"
                stBody = !FirstName & ", Your AR is overdue.  Please do it now."
            End If
            stTo = !Email
            stCc = Null
	    stBcc = !BCC
'            stPathFile = Null
            intOptionNumber = 0
            Call SendOutlookMessage(stTo, stSubject, stBody, True, stCc, stBcc, , stPathFile, intOptionNumber)
'           Used to track who has already received notice 
'           so won't receive notice in a future run
            stSQL = "UPDATE tblARStatus SET tblARStatus.SentDate = Now()" & _
                    "WHERE tblARStatus.EMPNO = '" & !Empno & "';"
            DoCmd.SetWarnings False
            DoCmd.RunSQL stSQL
            DoCmd.SetWarnings True
            .MoveNext
        Wend
    End With
        
        Set rs = Nothing
        Set db = Nothing
End Sub

----------------------------
This code actually does the outlook processing based on
the inputs from the command button. Put this code in a Code Module

Function SendOutlookMessage(Recipients As String, Subject As String, Body As String, DisplayMsg As Boolean, Optional CopyRecipients As String, Optional BlindCopyRecipients As String, Optional Importance As Integer = 2, Optional AttachmentPath, Optional AttachmentOptionNumber As Integer)
'Function to create and send an outlook message with more control than sendobject
'separate multiple recipients or CC, or BCC with comma
'importance - 1=low, 2=normal, 3=high

'AttachmentOptionNumber allows additional Attachment based on which Option
'was clicked in order to send the email. 05-Aug-2003

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.recipient
Dim objOutlookAttach As Outlook.Attachment
Dim txtRecipient As String
Dim stAttachment As String 'Use to store original attachment so that order of attachments for ecp notice will be correct
Dim stattach As String
          ' Create the Outlook session.
          Set objOutlook = CreateObject("Outlook.Application")

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

          With objOutlookMsg
                ' Add the To recipient(s) to the message.
                Do While InStr(1, Recipients, ",", vbTextCompare) <> 0 'checks for multiple recipients and adds each
                    txtRecipient = Left(Recipients, InStr(1, Recipients, ",", vbTextCompare) - 1)
                    Recipients = Trim(Mid(Recipients, Len(txtRecipient) + 2, Len(Recipients)))
                    Set objOutlookRecip = .Recipients.Add(txtRecipient)
                    objOutlookRecip.Type = olTo
                Loop
                
                Set objOutlookRecip = .Recipients.Add(Trim(Recipients))
                objOutlookRecip.Type = olTo

              ' Add the CC recipient(s) to the message if existing
            If CopyRecipients <> "" Then
                Set objOutlookRecip = .Recipients.Add(CopyRecipients)
                objOutlookRecip.Type = olCC
            End If
            
            ' Add the BCC recipient(s) to the message.
            If BlindCopyRecipients <> "" Then
                Set objOutlookRecip = .Recipients.Add(BlindCopyRecipients)
                objOutlookRecip.Type = olBCC
            End If
            
             ' Set the Subject, Body, and Importance of the message.
             .Subject = Subject
             .Body = Body & vbCrLf & vbCrLf
             Select Case Importance
                Case 1
                   .Importance = olImportanceLow
                Case 2
                    .Importance = olImportanceNormal
                Case 3
                    .Importance = olImportanceHigh
                Case Else
                    .Importance = olImportanceNormal
             End Select

             ' Add attachments to the message.
             On Error GoTo SendOutlookMessage_err
             If AttachmentPath <> "" Then
                 If Not IsMissing(AttachmentPath) Then
                    stAttachment = AttachmentPath
                    'If AttachmentOptionNumber = 1 Then
                    '    stAttachment = AttachmentPath
                    '    'change extension to .zip to attach zip rather than pdf
                    '    On Error GoTo ChangeToPDF_err
                    '    AttachmentPath = Replace(AttachmentPath, ".pdf", ".zip")
                    '    On Error GoTo SendOutlookMessage_err
                    '    Set objOutlookAttach = .Attachments.Add(AttachmentPath)
                    'End If
                    
                    If AttachmentOptionNumber = 1 Then
                        'change extension to .zip to attach zip rather than pdf
                        AttachmentPath = Replace(AttachmentPath, ".pdf", ".zip")
                        'In order for fIsFileDir to work so that it can check if the file
                        'exists, needed to store AttachmentPath in a local variable
                        stattach = AttachmentPath
                        If fIsFileDIR(stattach) Then
                            Set objOutlookAttach = .Attachments.Add(AttachmentPath)
                        Else
                            'change extension back to .pdf if .zip not found
                            AttachmentPath = Replace(AttachmentPath, ".zip", ".pdf")
                            Set objOutlookAttach = .Attachments.Add(AttachmentPath)
                        End If
                        On Error GoTo SendOutlookMessage_err
                        AttachmentPath = stAttachment
                    End If
                    
  
    '                AttachmentPath = stAttachmentpath
                    Set objOutlookAttach = .Attachments.Add(AttachmentPath)
                 End If
             End If

             ' Resolve each Recipient's name.
             For Each objOutlookRecip In .Recipients
                 objOutlookRecip.Resolve
             Next

             ' Should we display the message before sending?
             If DisplayMsg Then
                 .Display
             Else
                 .Save
                 .Send
             End If
          End With
          Set objOutlook = Nothing
          Exit Function
SendOutlookMessage_err:
      'If the file isn't found, attach the not found pdf file to
      'allow code to continue and user to manually attach file to
      'the email
      AttachmentPath = "M:\Files\NotFound.pdf"
      'MsgBox "Old Path " & AttachmentPath
      Debug.Print AttachmentPath
      'AttachmentPath = "M:\Files\NotFound.pdf"
      
      'MsgBox "New Path " & AttachmentPath
      Debug.Print AttachmentPath
      Resume
ChangeToPDF_err:
    'Change Extension from ZIP to PDF If Attachment isn't found
    AttachmentPath = Replace(AttachmentPath, ".zip", ".pdf")
    Resume
End Function

 

[SmokeEater1]

Thanks. Looking at the code is very daunting. It mentions references to PDF attachments, levels of message importance. I'm trying to the most basic of functions - move the email addresses to the BCC field in outlook. Everything else will be done manually. The message will being sent our in Rich Text Format, with no attachments. So to try and figure out this complex code may take me a while. As I mentioned in the first thread, my coding knowledge is very limited.

Thanks for the reply.

 

[sxschech]

The portions relating to PDF/attachments in the button code have already been commented out, you shouldn't need to alter the module code or worry about the PDF stuff. The main thing is to adjust the button code to suit your needs (Single Email per person or One email with Multiple Entries). The module code really only needs the inputs and shouldn't be altered...don't need to worry about levels of importance, etc. For now use the module code in its default setup. Hope this helps clarify.

 

[p27br]

Option Compare Database
Option Explicit

'Set a reference to Outlook Automation and ADO
Sub test()


Dim cnx As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strBCC As String
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem

Set cnx = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "tblemail", cnx

With rst
.MoveFirst
Do While Not .EOF
strBCC = strBCC & rst!Emailaddress & ";"
.MoveNext
Loop
.Close
End With
Set rst = Nothing
Set cnx = Nothing

Set myOlApp = CreateObject("Outlook.Application&quot
Set myItem = myOlApp.CreateItem(olMailItem)
myItem.BCC = strBCC
myItem.Display


End Sub

 

[LittleSmudge]

If you really are happy doing all the text editing by hand then this job can be simplified even further by using the SendObjects command

Dim strBCC As String
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
rst.Activeconnect = CurrentProject.Connection

rst.Open "tblemail"

While Not rst.EOF
   strBCC = strBCC & rst!Emailaddress & ";"
   rst.MoveNext
Wend
rst.Close
Set rst = Nothing

DoCmd.SendObject , , , , , strBCC, , , True

End Sub

'ope-that-'elps.



G LS
spsinkNOJUNK@yahoo.co.uk
Remove the NOJUNK to use.