Hello,
I need help! I have a small Access 2007 DB containing a table with Email addresses and attachment to each record.
The Email data type is "Text" and the Attachment data type is "Attachment" (which happens to be a new feature in 2007).
The code for my module is below. I need to send out a bulk email for each record with the file attachment.
I am returning an error, which I have attached to this post. "Item not found in this collection". The error occurs at the "setolAttachment" command line.
If I comment out the Attachment commands, the module runs as expected. I'm obviously not understanding what I need to do to attach these files.
Any help is greatly appreciated here!
Public Function SendEmail()
On Error GoTo Err_SendEmail
Dim objOutlook As New Outlook.Application
Dim objMail As Outlook.MailItem
Dim olAttachment As Outlook.Attachment
Dim rsAttachments As DAO.Recordset
Dim sSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sTitle As String
Dim sFile As String
Dim sErr As String
Dim sMessage As String
'Prelims
DoCmd.SetWarnings False
DoCmd.Hourglass True
Set db = CurrentDb
'Prepare email message
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
'Build recordset on recipients
sSQL = "SELECT Email as [Recipient], Message As [BodyText], BType As [olAttachment] FROM Myqry;"
Set rs = db.OpenRecordset(sSQL)
sMessage = rs![BodyText]
While Not rs.EOF
' Instantiate the child recordset.
Set rsAttachments = rs.Fields("olAttachment").Value
' Save current attachment to disk in the "My Documents" folder.
rsAttachments.Fields("FileData").SaveToFile _
"C:\Temp"
--This is where the error occurs--
Set olAttachment = .Attachments.Add("C:\Temp" & rsAttachments.Fields("FileName"))
'Delete this temp file:
Kill "C:\Temp" & rsAttachments.Fields("FileName")
rsAttachments.MoveNext
rs.MoveNext
'Add Recipient
With .Recipients.Add(rs![Recipient])
.Type = olBCC
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
'Add the subject
.Subject = "My subject"
'Add standard message text to body
.Body = sMessage
'Send the mail message
.Send
End With
Set objMail = Nothing
Set objOutlook = Nothing
Exit_SendEmail:
DoCmd.SetWarnings True
DoCmd.Hourglass False
Exit Function
Err_SendEmail:
sErr = "Error " & Error & " / " & Err
MsgBox sErr, vbInformation + vbOKOnly, "Error on Email function"
Resume Exit_SendEmail
End Function
I need help! I have a small Access 2007 DB containing a table with Email addresses and attachment to each record.
The Email data type is "Text" and the Attachment data type is "Attachment" (which happens to be a new feature in 2007).
The code for my module is below. I need to send out a bulk email for each record with the file attachment.
I am returning an error, which I have attached to this post. "Item not found in this collection". The error occurs at the "setolAttachment" command line.
If I comment out the Attachment commands, the module runs as expected. I'm obviously not understanding what I need to do to attach these files.
Any help is greatly appreciated here!
Public Function SendEmail()
On Error GoTo Err_SendEmail
Dim objOutlook As New Outlook.Application
Dim objMail As Outlook.MailItem
Dim olAttachment As Outlook.Attachment
Dim rsAttachments As DAO.Recordset
Dim sSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sTitle As String
Dim sFile As String
Dim sErr As String
Dim sMessage As String
'Prelims
DoCmd.SetWarnings False
DoCmd.Hourglass True
Set db = CurrentDb
'Prepare email message
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
'Build recordset on recipients
sSQL = "SELECT Email as [Recipient], Message As [BodyText], BType As [olAttachment] FROM Myqry;"
Set rs = db.OpenRecordset(sSQL)
sMessage = rs![BodyText]
While Not rs.EOF
' Instantiate the child recordset.
Set rsAttachments = rs.Fields("olAttachment").Value
' Save current attachment to disk in the "My Documents" folder.
rsAttachments.Fields("FileData").SaveToFile _
"C:\Temp"
--This is where the error occurs--
Set olAttachment = .Attachments.Add("C:\Temp" & rsAttachments.Fields("FileName"))
'Delete this temp file:
Kill "C:\Temp" & rsAttachments.Fields("FileName")
rsAttachments.MoveNext
rs.MoveNext
'Add Recipient
With .Recipients.Add(rs![Recipient])
.Type = olBCC
End With
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
'Add the subject
.Subject = "My subject"
'Add standard message text to body
.Body = sMessage
'Send the mail message
.Send
End With
Set objMail = Nothing
Set objOutlook = Nothing
Exit_SendEmail:
DoCmd.SetWarnings True
DoCmd.Hourglass False
Exit Function
Err_SendEmail:
sErr = "Error " & Error & " / " & Err
MsgBox sErr, vbInformation + vbOKOnly, "Error on Email function"
Resume Exit_SendEmail
End Function