Maiilng list application

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

From an Access database which stores lists of email addresses, I need to be
able to email groups of people certain emails. I know how to do this but I
need to do it without listing the addressees in the cc field. I need to
somehow dynamically set up an email group, add all the relevant email
addresses to it and then email the group so each recipient wont be aware of
the other recipients. Is this possible? Does anyone have a clue how to do it.
We use Outlook as our email application. Yes, I posted the question in an
Outlook forum as well.
 
Rupert, yes you can.
Here's the steps (briefly) I use :
Create a select query or table containing the email addresses to use.
Use VBA code within Access to create contacts in an Outlook contacts folder
for the above recipients.
Run Outlook and use Tools-Mail Merge to send email to all the recipeints
above. It will create a separate email for each contact, and if you use a
mail merge document, you can insert fields to personalize each email.

It's pretty slick, but requires almost 200 lines of VBA code to take care of
all the details.
My code is not strictly generic, so it would require modification on your
part. Average VBA
expertise is probably OK.
If you want to see it, let me know and I'll post it here.

UpRider
 
Yes, I'd like to review your code, please post it. I'm sure it will help. 200
lines is nothing!

-Dorian
 
OK, here you go.
This routine assumes you have a contacts folder in Outlook named CurrentNL.
UpRider

option explicit
dim intMsgBox as Integer
'---------------------------------------------------------------------------------------
' Procedure : subExportToOutlookCurrentNL
' DateTime : 2/8/2006 18:40
' Author : David
' Purpose : Use Office Automation to directly add contacts to Outlook
contact folder "CurrentNL"
'---------------------------------------------------------------------------------------
'
Sub subExportToOutlookCurrentNL(qQuery As String)
'empty CurrentNL first
Call subDeleteCurrentNLContacts
If intMsgBox = vbCancel Then Exit Sub
Dim intMemCount As Long
Dim intEmailCount As Long
Dim db As DAO.Database
Dim olNs As Outlook.NameSpace ' Outlook Namespace
Dim cf As Outlook.MAPIFolder ' Contact folder
Dim C As Object ' Contact Item
Dim ol As New Outlook.Application
Dim outNLContacts As Outlook.MAPIFolder
On Error GoTo Err_subExportToOutlookCurrentNL
Set db = CurrentDb()
Set olNs = ol.GetNamespace("MAPI")
Set cf = olNs.GetDefaultFolder(olFolderContacts)
Set outNLContacts = cf.Folders.Item(1)
Call subEmailExpand(qQuery)
intMemCount = DCount("*", qQuery) 'number of memberships getting email
intEmailCount = DCount("*", "tblworkEmail") 'number of email addresses
getting email
swcancel = False
intMsgBox = MsgBox("This selection will export " + str(intEmailCount) +
" email addresses " _
& "into Outlook contact folder CurrentNL " _
& "for " + str(intMemCount) + " memberships. " & vbCrLf _
& "Clicking OK will not send email now.", _
vbOKCancel, " M E M B E R S T O P R O C E S S ")
If intMemCount = 0 Or intMsgBox = vbCancel Then
Exit Sub
End If
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("tblworkEmail")
DoCmd.Hourglass True

With rst
.MoveFirst
Do While Not .EOF
Set C = outNLContacts.Items.Add
C.MessageClass = "IPM.Contact.frmContactNL"
If Len(![FIRST] & vbNullString) > 0 Then C.FirstName = ![FIRST]
If Len(![me_mail1] & vbNullString) > 0 Then C.Email1Address =
![me_mail1]
If Len(![LAST] & vbNullString) > 0 Then C.LastName = ![LAST]
If Len(![NLMO] & vbNullString) > 0 Then C.User1 = ![NLMO]
C.Save
.MoveNext
Loop
End With
DoCmd.Hourglass False
MsgBox "Export/Import to Outlook completed. You may switch to Outlook
now and mail merge the " _
& "contacts in folder CurrentNL an email. ", vbOKOnly, " T
R A N S F E R D O N E "
Dim strAppendDate As String
Dim strFolder As String
Dim strFileName As String
strFolder = fcnGetSetupData(29)
strAppendDate = "_" & Month(Date) & "_" & Day(Date) & "_" & Year(Date)
strFileName = strFolder & glbEmailExportName & "_Opt1Direct_on" &
strAppendDate & ".txt"

DoCmd.TransferText acExportDelim, , "tblworkEmail", strFileName, True

subExportToOutlookCurrentNL_Exit:
DoCmd.Hourglass False
On Error Resume Next
rst.Close
Set rst = Nothing
'db.Close
Set db = Nothing
Set C = Nothing
Set outNLContacts = Nothing
Set olNs = Nothing
'ol.Quit
Set ol = Nothing
Exit Sub
Err_subExportToOutlookCurrentNL:
Call fcnLogError(Err.Number, Err.Description,
"subExportToOutlookCurrentNL of basDBTCModules", , True)
Resume subExportToOutlookCurrentNL_Exit
End Sub


Private Sub subDeleteCurrentNLContacts()
Dim appOutlook As Outlook.Application
'Dim appOutlook As Object
Dim myNS As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myTargetFolder As Outlook.MAPIFolder
Dim myItems As Items
Dim X As Integer

On Error GoTo subDeleteCurrentNLContacts_Error

Set appOutlook = CreateObject("Outlook.Application")
Set myNS = appOutlook.GetNamespace("MAPI")
Set myFolder = myNS.GetDefaultFolder(olFolderContacts)
Set myTargetFolder = myFolder.Folders("CurrentNL")
Set myItems = myTargetFolder.Items

intMsgBox = MsgBox("CurrentNL now contains " &
myTargetFolder.Items.Count & " items " _
& "(Probably last month's email list)." _
& vbCrLf & "Do you want to empty the CurrentNL folder before the
export? ", vbYesNoCancel, _
" D E L E T E T H E C O N T A C T S ")
If intMsgBox = vbYes Then
For X = myItems.Count To 1 Step -1
myItems(X).Delete
Next X
End If

subDeleteCurrentNLContacts_Exit:
On Error Resume Next
Set myNS = Nothing
Set myFolder = Nothing
Set myItems = Nothing
Set myTargetFolder = Nothing
Set appOutlook = Nothing
Exit Sub
subDeleteCurrentNLContacts_Error:
Call fcnLogError(Err.Number, Err.Description, "Procedure
subDeleteCurrentNLContacts" & " of basMailProcessing", , True)
Resume subDeleteCurrentNLContacts_Exit
End Sub

'---------------------------------------------------------------------------------------
' Procedure : subEmailExpand
' DateTime : 7/9/2004 16:45
' Author : David
' Purpose : Populate tblworkEmail with all email addresses in the query.
If more than one email address
' : is in a member's record, it will be expanded to 2 (or more)
records in tblworkEmail
'---------------------------------------------------------------------------------------
'
Sub subEmailExpand(qQuery)
On Error GoTo subEmailExpand_Error
Call fcnEmptyTable("tblworkEmail")
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim Qrst As DAO.Recordset
Set qdf = CurrentDb.QueryDefs(qQuery)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name) 'different for prompts
Next prm
Dim reccnt As Long
Set Qrst = qdf.OpenRecordset()
Dim Trst As DAO.Recordset
Set Trst = CurrentDb.OpenRecordset("tblworkEmail")
reccnt = 0
'Qrst is input, Trst is output
With Qrst
.MoveFirst
Do While Not .EOF
Trst.AddNew


Trst![LAST] = strconv(Qrst![LAST], vbProperCase)
Trst!FIRST = fcnCleanFirst(Nz(Qrst!FIRST, " "))
Trst!NLMO = Qrst!NLMO
Trst.Update
If Len(Qrst![memail2] & vbNullString) > 0 Then
Trst.AddNew

Trst![LAST] = strconv(Qrst![LAST], vbProperCase)
Trst!FIRST = fcnCleanFirst(Qrst!FIRST)
Trst!NLMO = Qrst!NLMO
Trst.Update
End If
Qrst.MoveNext
Loop
End With

subEmailExpand_Exit:
On Error Resume Next
Trst.Close
qdf.Close
Set qdf = Nothing
Set Trst = Nothing
Exit Sub
subEmailExpand_Error:
Call fcnLogError(Err.Number, Err.Description, "Procedure subEmailExpand"
& " of basMailProcessing", , True)
Resume subEmailExpand_Exit
End Sub
 
Back
Top