Collect email addresses from a query to

[Kathy Webster]

I want to email to a group of people. How can I collect the selected records
from a query's [EmailAddress] field, put commas between each address, and
drop the result into a microsoft outlook TO field?

TIA,
Kathy

 

[Gary Walter]

I want to email to a group of people. How can I collect the selected
records from a query's [EmailAddress] field, put commas between each
address, and drop the result into a microsoft outlook TO field?

Hi Kathy,

Here be some "starting skeleton code"
(usually one wants to put the "list"
in the BCC)

'***** start of code ******************
Public Function SendMsg()
On Error GoTo Err_SendMsg
Dim appOutlook As New Outlook.Application
Dim itm As Outlook.MailItem

'Create new mail msg
Set itm = appOutlook.CreateItem(olMailItem)

With itm
'.To = "<youremailadressifyouwish>"
.BCC = GetEMailAddresses("qryEMail", "EmailAddress")
'.Subject = "A subject if you wish"
'.Body = "Something in the body if you wish."
'display msg before hitting Send
.Display
End With

Exit_SendMsg:
Exit Function
Err_SendMsg:
MsgBox Err.Description
Resume Exit_SendMsg

End Function

Public Function GetEMailAddresses(pQueryName As String, _
pFieldName As String) As String
On Error GoTo Err_GetEMailAddress
Dim rs As DAO.Recordset
Dim varTemp As Variant

varTemp = ""

Set rs = CurrentDb.OpenRecordset(pQueryName)
rs.MoveFirst
Do While Not rs.EOF
varTemp = varTemp & "<" & rs.Fields(pFieldName) & ">, "
rs.MoveNext
Loop
'remove ending comma and space
GetEMailAddresses = Left(varTemp, Len(varTemp) - 2)
'Debug.Print varTemp
rs.Close

Exit_GetEMailAddress:
Set rs = Nothing
Exit Function

Err_GetEMailAddress:
MsgBox Err.Description
Resume Exit_GetEMailAddress

End Function
..*** end of code ***************

There are several things *wrong* with above code...

It uses early binding, plus, it won't work if there
are several users on the same machine.

Ignoring binding for now, you will have to get
a namespace if multiple users (untested code):

Public Function SendMsg ()
On Error GoTo Err_SendMsg

Dim appOutlook As Outlook.Application
Dim NS As Outlook.NameSpace
Dim itm As Outlook.MailItem

Set appOutlook = CreateObject("Outlook.Application")
'********************************
Set NS = appOutlook.GetNamespace("MAPI")
NS.GetDefaultFolder olFolderOutbox
'**********************************
Set itm = appOutlook.CreateItem(olMailItem)


'itm.To = "<youremailadressifyouwish>"
itm.BCC = GetEMailAddresses("qryEMail", "EmailAddress")
'itm.Subject = "A subject if you wish"
'itm.Body = "Something in the body if you wish."
'display msg before hitting Send
itm.Display

Exit_SendMsg:
Set itm = Nothing
Set NS = Nothing
Set appOutlook = Nothing

Exit Function
Err_SendMsg:
MsgBox Err.Description
Resume Exit_SendMsg
End Function

With this early binding, that means that every
computer you place this app on must have same
version of Outlook that you use in References
when you compile this code.

If that meets your situation, then I believe you
are mostly there (except maybe you want to add
some function parameters to SendMsg for main
"To" address, a "Subject" string, and a "Body"
string that you can feed to your function).

(again, untested code, w/o code to check
for valid parameter strings):

Public Function SendMsg (pTo As Variant, _
pSubject As Variant, _
pBody As Variant, _
pQueryName As String, _
pFieldName As String) As Boolean
On Error GoTo Err_SendMsg

Dim appOutlook As Outlook.Application
Dim NS As Outlook.NameSpace
Dim itm As Outlook.MailItem

Set appOutlook = CreateObject("Outlook.Application")
'********************************
Set NS = appOutlook.GetNamespace("MAPI")
NS.GetDefaultFolder olFolderOutbox
'**********************************
Set itm = appOutlook.CreateItem(olMailItem)


itm.To = "<" & pTo & ">"
itm.BCC = GetEMailAddresses(pQueryName, pFieldName)
itm.Subject = pSubject & ""
itm.Body = pBody & ""
'display msg before hitting Send
itm.Display

'return that successful
SendMsg = True

Exit_SendMsg:
Set itm = Nothing
Set NS = Nothing
Set appOutlook = Nothing

Exit Function
Err_SendMsg:
MsgBox Err.Description
Resume Exit_SendMsg
End Function

So...save the 2 functions in a new code module
(say "modEMail"),
click on Debug/Compile to make sure copy/paste
didn't mangle with wrapping,

then in Immediate Window, try testing
(hit <ENTER> after typing each line)

strQ = "nameofyourquery"
strF = "nameof fieldinquery"
strTo = (e-mail address removed)
strS = "this is the subject line"
strB = "this is body of email"
SendMsg strTo, strS, strB, strQ, strF

good luck,

gary

 

[Gary Walter]

then in Immediate Window, try testing

(hit <ENTER> after typing each line)

strQ = "nameofyourquery"
strF = "nameof fieldinquery"
strTo = (e-mail address removed)
strS = "this is the subject line"
strB = "this is body of email"
SendMsg strTo, strS, strB, strQ, strF

Hi Kathy,

First...I notice strTo gets changed to
a hyperlink in newsgroup, so make sure
it has quotes around it.

Second...when we assign a string value
to a variable in Immediate Window, it
actually will be a *Variant* -- not a string.

So...if you try to execute the last line above,
you will get a "ByVal argument mismatch"
error, i.e, strQ and strF need to be converted
to strings to match up with function. So, last line
should be:

SendMsg strTo, strS, strB, CStr(strQ), Cstr(strF)

Finally, I forgot to give you a late-binding version
(so you do not need to have Outlook tagged in
References...but you do need to reference DAO)

Note: because we use late binding, the "ol" variables
had to be replaced with their actual values.

The below was tested in Access2002:

Public Function SendMsgLateBinding(pTo As Variant, _
pSubject As Variant, _
pBody As Variant, _
pQueryName As String, _
pFieldName As String) As Boolean
On Error GoTo Err_SendMsgLateBinding

Dim appOutlook As Object
Dim NS As Object
Dim itm As Object

Set appOutlook = CreateObject("Outlook.Application")
'********************************
Set NS = appOutlook.GetNamespace("MAPI")
'olFolderOutbox = 4
NS.GetDefaultFolder 4
'**********************************
'olMailItem = 0
Set itm = appOutlook.CreateItem(0)


itm.To = "<" & pTo & ">"
itm.BCC = GetEMailAddresses(pQueryName, pFieldName)
itm.Subject = pSubject & ""
itm.Body = pBody & ""
'display msg before hitting Send
itm.Display

'return that successful
SendMsgLateBinding = True

Exit_SendMsgLateBinding:
Set itm = Nothing
Set NS = Nothing
Set appOutlook = Nothing

Exit Function
Err_SendMsgLateBinding:
MsgBox Err.Description
Resume Exit_SendMsgLateBinding
End Function

good luck,

gary

 

[Kathy Webster]

Thank you, Gary. I'm breaking into a cold sweat since this is over my head,
but I am going to attempt it. 2 questions:
1. Where do I insert the query name in this code? My query name is qEmails.
2. Where do I insert the email field name into this code? My email field
name is em_add
Kathy