I have a bulk email process in access 2003 which goes through a list of selected contacts and sends an email with attachment. This has worked well for 2 of 3 users on access 2003/outlook 2003 for the last 2 years. However the 3rd user (on access 2007/outlook 2007) is recently seeing a 50% dropout on the attachment. 100% of emails go through but 50% list with no attachment on the sent emails. These are coincidentally the last 50% of the batch. I'm going to put a log on the email process to verify attachment process but I feel this is not the answer. Memory in outlook looks ok - less than 500 mb for pst file. I use click yes to automate outgoing emails. Below is code sample though I'm not sure if this is where I should be looking.
Private Sub SendEmail2(TypeEvent As String)
On Error GoTo Err_SendEmail2
Dim oOL As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oNS As Outlook.NameSpace 'new line
Dim varItem As Variant
Dim vAttachment As String
Dim vTo As String
Dim vFrom As String
Dim vSubject As String
Dim vBody As String
Dim vFromOrganization As String
Dim vSent As Date
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim stCriteria As String
Dim vCategoryID As Long
Dim vClientID As Long
Dim vcounter As Long
Dim vAttachment1 As Variant
Dim vAttachment2 As Variant
Dim vAttachment3 As Variant
Dim vAttachment4 As Variant
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("tblactiontaken", dbOpenDynaset)
vFromOrganization = Forms!frmbulkemail!FromOrganization
vSubject = Forms!frmbulkemail!Subject
vBody = Forms!frmbulkemail!Body & vbCrLf
vFrom = Forms!frmbulkemail!FromWhom
vAttachment1 = Forms!frmbulkemail!Attachment1
vAttachment2 = Forms!frmbulkemail!Attachment2
vAttachment3 = Forms!frmbulkemail!Attachment3
vAttachment4 = Forms!frmbulkemail!Attachment4
'Get an Outlook Application object
On Error Resume Next
Set oOL = GetObject(, "Outlook.Application")
If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
End If
Set oNS = oOL.GetNamespace("MAPI") 'new addition
oNS.Logon vFromOrganization, , True, True
With Me!Lst1
For Each varItem In .ItemsSelected
vClientID = .Column(0, varItem)
vTo = .Column(13, varItem)
If Not IsNull(vTo) Then
rs1.AddNew 'Add an email record to the action table for this contact
rs1!ClientID = .Column(0, varItem)
rs1!Subject = vSubject
rs1!FromOrganization = vFromOrganization
rs1!ToWhom = .Column(3, varItem) & " " & .Column(4, varItem)
rs1!FromWhom = vFrom
rs1!SentDate = Date
vcounter = vcounter + 1
Set oMail = oOL.CreateItem(olMailItem) 'Create the email
oMail.Subject = vSubject
oMail.Body = vBody
If Not IsNull(vAttachment1) Then
oMail.Attachments.Add vAttachment1
End If
If Not IsNull(vAttachment2) Then
oMail.Attachments.Add vAttachment2
End If
If Not IsNull(vAttachment3) Then
oMail.Attachments.Add vAttachment3
End If
If Not IsNull(vAttachment4) Then
oMail.Attachments.Add vAttachment4
End If
oMail.To = vTo
oMail.Send 'Send the email
rs1.Update
End If
Next varItem
End With
rs1.Close
db.Close
MsgBox "created " & vcounter & " email(s) "
Set oMail = Nothing
oNS.Logoff 'new addition
Exit_SendEmail2:
Exit Sub
Err_SendEmail2:
MsgBox Error$
Resume Exit_SendEmail2
End Sub
Private Sub SendEmail2(TypeEvent As String)
On Error GoTo Err_SendEmail2
Dim oOL As Outlook.Application
Dim oMail As Outlook.MailItem
Dim oNS As Outlook.NameSpace 'new line
Dim varItem As Variant
Dim vAttachment As String
Dim vTo As String
Dim vFrom As String
Dim vSubject As String
Dim vBody As String
Dim vFromOrganization As String
Dim vSent As Date
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim stCriteria As String
Dim vCategoryID As Long
Dim vClientID As Long
Dim vcounter As Long
Dim vAttachment1 As Variant
Dim vAttachment2 As Variant
Dim vAttachment3 As Variant
Dim vAttachment4 As Variant
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("tblactiontaken", dbOpenDynaset)
vFromOrganization = Forms!frmbulkemail!FromOrganization
vSubject = Forms!frmbulkemail!Subject
vBody = Forms!frmbulkemail!Body & vbCrLf
vFrom = Forms!frmbulkemail!FromWhom
vAttachment1 = Forms!frmbulkemail!Attachment1
vAttachment2 = Forms!frmbulkemail!Attachment2
vAttachment3 = Forms!frmbulkemail!Attachment3
vAttachment4 = Forms!frmbulkemail!Attachment4
'Get an Outlook Application object
On Error Resume Next
Set oOL = GetObject(, "Outlook.Application")
If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
End If
Set oNS = oOL.GetNamespace("MAPI") 'new addition
oNS.Logon vFromOrganization, , True, True
With Me!Lst1
For Each varItem In .ItemsSelected
vClientID = .Column(0, varItem)
vTo = .Column(13, varItem)
If Not IsNull(vTo) Then
rs1.AddNew 'Add an email record to the action table for this contact
rs1!ClientID = .Column(0, varItem)
rs1!Subject = vSubject
rs1!FromOrganization = vFromOrganization
rs1!ToWhom = .Column(3, varItem) & " " & .Column(4, varItem)
rs1!FromWhom = vFrom
rs1!SentDate = Date
vcounter = vcounter + 1
Set oMail = oOL.CreateItem(olMailItem) 'Create the email
oMail.Subject = vSubject
oMail.Body = vBody
If Not IsNull(vAttachment1) Then
oMail.Attachments.Add vAttachment1
End If
If Not IsNull(vAttachment2) Then
oMail.Attachments.Add vAttachment2
End If
If Not IsNull(vAttachment3) Then
oMail.Attachments.Add vAttachment3
End If
If Not IsNull(vAttachment4) Then
oMail.Attachments.Add vAttachment4
End If
oMail.To = vTo
oMail.Send 'Send the email
rs1.Update
End If
Next varItem
End With
rs1.Close
db.Close
MsgBox "created " & vcounter & " email(s) "
Set oMail = Nothing
oNS.Logoff 'new addition
Exit_SendEmail2:
Exit Sub
Err_SendEmail2:
MsgBox Error$
Resume Exit_SendEmail2
End Sub