email from access

[Delindan]

I would like to email excel files using a distribution list in a table in access. I'm trying to use code I found here but getting "user defined type not found" when I try to run on the DIM myo As outlook.application. Does anyone know how to address?

Thanks!!

Option Compare Database

Private Sub Command0___Click()

Dim aSubject As String
Dim aBody As String
Dim aAttach As String
Dim RSSpecialist As Recordset
Dim arootpath As String
Dim aAttachments As String
Dim arecipients As String
Dim strSpecialistName As String


arootpath = Trim(Me!txtfolder)
If Right(arootpath, 1) <> "\" Then
arootpath = arootpath & "\"
End If

txtCurrProfile = Null
DoEvents

Set DB = CurrentDb
Set RSSpecialist = DB.OpenRecordset("FS Specialists", dbOpenSnapshot)

RSSpecialist.MoveFirst
Do Until RSSpecialist.EOF
strSpecialistName = RSSpecialist("FS Specialist")
arecipients = RSSpecialist("Email")
aSubject = "Data for Update"
aBody = "Please review the attached file and update past numbers as well as adding current."
aAttach = arootpath & "FS Specialist " & strSpecialistName & ".xlsx"
Call SendEMail(aSubject, arecipients, aBody, aAttachments, arootpath)
RSSpecialist.MoveNext
If RSSpecialist.EOF Then Exit Do
Loop

Me!txtCurrProfile = "Email Complete..."
DoEvents

RSSpecialist.Close
DB.Close

Set xlApp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
End Sub


Private Sub SendEMail(ByVal aSubject As String, ByVal arecipients As String, Optional ByVal aBody As String = "", Optional ByVal aAttachments As String = "", Optional ByVal arootpath As String = "")

Dim myO As Outlook.Application
Dim mobjNewMessage As Outlook.MailItem
Dim sRecipient, sAttachment, sDisplayName As String
Dim iMarker, iMarker2 As Integer

On Error GoTo Error_SendEMail
Set myO = CreateObject("Outlook.Application")
Set mobjNewMessage = myO.CreateItem(olMailItem)
mobjNewMessage.Subject = aSubject
mobjNewMessage.Body = aBody
' Loop through ; separated recipients
Do
iMarker = InStr(1, arecipients, ";", vbTextCompare)
If iMarker = 0 Then
sRecipient = arecipients
Else
sRecipient = Mid(arecipients, 1, iMarker - 1)
arecipients = Mid(arecipients, iMarker + 1)
End If
If Len(sRecipient) <> 0 Then mobjNewMessage.Recipients.Add sRecipient
Loop While iMarker <> 0

' Loop through ; separated attachments - also look for ***DisplayName
Do
iMarker = InStr(1, aAttachments, ";", vbTextCompare)
If iMarker = 0 Then
sAttachment = aAttachments
Else
sAttachment = Mid(aAttachments, 1, iMarker - 1)
aAttachments = Mid(aAttachments, iMarker + 1)
End If
If Len(sAttachment) <> 0 Then
' Is there an embedded display name?
iMarker2 = InStr(1, sAttachment, "***", vbTextCompare)
If iMarker2 <> 0 Then
sDisplayName = Mid(sAttachment, iMarker2 + 3)
sAttachment = arootpath + Mid(sAttachment, 1, iMarker2 - 1)
If StrComp(Dir(sAttachment), "", vbTextCompare) <> 0 Then mobjNewMessage.Attachments.Add sAttachment, , , sDisplayName
Else
If StrComp(Dir(arootpath + sAttachment), "", vbTextCompare) <> 0 Then mobjNewMessage.Attachments.Add arootpath + sAttachment
End If
End If
Loop While iMarker <> 0

' Send the message
mobjNewMessage.Send

Exit_SendEMail:

Set mobjNewMessage = Nothing
Set myO = Nothing
Exit Sub

Error_SendEMail:
MsgBox Err.Description, , "Send Mail Error"
Resume Exit_SendEMail
End Sub

 

[dhookom]

Do you have Outlook installed? Do you have a reference to the Outlook library set?

Duane
Hook'D on Access
MS Access MVP

 

[PHV]

Anyway, have a look here:
thread705-1369407

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Delindan]

I browsed through the link and found something to try and this is what I came up with:

Private Sub Command0___Click()

Dim aSubject As String
Dim abody As String
Dim aAttach As String
Dim RSSpecialist As Recordset
Dim arootpath As String
Dim aattachments As String
Dim arecipients As String
Dim strSpecialistName As String


arootpath = Trim(Me!txtfolder)
If Right(arootpath, 1) <> "\" Then
arootpath = arootpath & "\"
End If

txtCurrProfile = Null
DoEvents

Set DB = CurrentDb
Set RSSpecialist = DB.OpenRecordset("FS Specialists", dbOpenSnapshot)

RSSpecialist.MoveFirst
Do Until RSSpecialist.EOF
strSpecialistName = RSSpecialist("FS Specialist")
arootpath = arootpath & "FS Specialist " & strSpecialistName & ".xlsx"
arecipients = RSSpecialist("Email")
aSubject = "Data for Update"
abody = "Please review the attached file and update past numbers as well as adding current."
aAttach = arootpath & "FS Specialist " & strSpecialistName & ".xlsx"
Call SendEmail(aSubject, arecipients, abody, aattachments, arootpath)
RSSpecialist.MoveNext
If RSSpecialist.EOF Then Exit Do
Loop

Me!txtCurrProfile = "Email Complete..."
DoEvents

RSSpecialist.Close
DB.Close

Set xlApp = Nothing
Set RSSpecialist = Nothing
Set DB = Nothing
End Sub


Sub SendEmail(aSubject As String, arecipients As String, abody As String, aattachments As String, arootpath As String)

Set objmessage = CreateObject("CDO.Message")
objmessage.Subject = aSubject
objmessage.Sender = "dnicole@monsanto.com"
objmessage.To = arecipients
objmessage.TextBody = abody
'objmessage.AddAttachment = arootpath

With objmessage.Configuration.Fields
.Item("

http://schemas.microsoft.com/cdo/configuration/sendusing")

= 2
.Item("

http://schemas.microsoft.com/cdo/configuration/smtpserver")

= "smtp.someserver.com"
.Item("

http://schemas.microsoft.com/cdo/configuration/smtpserverport")

= 25
.Update
End With

objmessage.Send
End Sub

It erred out...transport failed to connect to the server. Is there some reference I need to load?

Thanks