By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,455 Members | 2,161 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,455 IT Pros & Developers. It's quick & easy.

Record Set based on Query and Where Condition

P: n/a
I'm trying to two two things through Access to Outlook based on a
query and selections made on a form.

Firstly, i'd like to create an email based on the selections made on a

Secondly i'd like to Export contact to Outlooks Contacts based on

The code i have so far for these is as follows:-

BCC Email:
Private Sub BCCEmail_Click()
On Error GoTo Err_BCCMail_Click

Dim stDocName As String
Dim MyOutlook As New Outlook.Application
Dim MyMail As Outlook.MailItem
Dim StrBCC As String
Dim rst As DAO.Recordset
Dim varItem As Variant
Dim strDescrip As String
Dim lngLen As Long
Dim strDelim As String
Dim strCategorySelect As String
Dim strCountrySelect As String
Dim strWhere As String

stDocName = "Q_Email"
With Me.CategorySelect
For Each varItem In .ItemsSelected
If Not IsNull(varItem) Then
strCategorySelect = strCategorySelect &
strCategorySelect & strDelim & .ItemData(varItem) & strDelim & ","
strDescrip = strDescrip & """" & .Column(1, varItem)
& """, "
End If
End With

lngLen = Len(strCategorySelect) - 1
If lngLen 0 Then
strCategorySelect = "[CategoryID] IN (" & Left$
(strCategorySelect, lngLen) & ")"
lngLen = Len(strDescrip) - 2
If lngLen 0 Then
strDescrip = "Categories: " & Left$(strDescrip, lngLen)
End If
End If

With Me.CountrySelect
For Each varItem In .ItemsSelected
If Not IsNull(varItem) Then
strCountrySelect = strCountrySelect & strCountrySelect
& strDelim & .ItemData(varItem) & strDelim & ","
strDescrip = strDescrip & """" & .Column(1, varItem)
& """, "
End If
End With

lngLen = Len(strCountrySelect) - 1
If lngLen 0 Then
strCountrySelect = "[CountryID] IN (" & Left$
(strCountrySelect, lngLen) & ")"
lngLen = Len(strDescrip) - 2
If lngLen 0 Then
strDescrip = "Categories: " & Left$(strDescrip, lngLen)
End If
End If

If strCategorySelect "" Then strWhere = strWhere &
strCategorySelect & " And "
If strCountrySelect "" Then strWhere = strWhere &
strCountrySelect & " And "
If strWhere "" Then strWhere = Left(strWhere, Len(strWhere)
- 5)
Set rst = CurrentDb.OpenRecordset(stDocName, dbOpenForwardOnly)
With rst
Do Until .EOF
StrBCC = StrBCC & ![EmailAddress] & ";"
End With
StrBCC = Left(StrBCC, Len(StrBCC) - 1)

Set MyOutlook = New Outlook.Application
Set MyMail = MyOutlook.CreateItem(olMailItem)
MyMail.BCC = StrBCC

Set MyOutlook = Nothing
Set rst = Nothing

Exit Sub

MsgBox Err.Description
Resume Exit_BCCMail_Click

End Sub
Export Contacts:
Private Sub ExportToOutlook_Click()
On Error GoTo Err_ExportToOutlook_Click

Dim stDocName As String
Dim dbs As Database
Dim rst As Recordset
Dim objOutlook As Outlook.Application
Dim nms As Outlook.NameSpace
Dim flds As Outlook.Folders
Dim fldContacts As Object
Dim itms As Object
Dim itm As Object
Dim strTitle As String
Dim strFirstName As String
Dim strMiddleName As String
Dim strLastName As String
Dim strJobTitle As String
Dim strLastNameFirst As String
Dim strBusinessStreet As String
Dim strBusinessStreet2 As String
Dim strBusinessCity As String
Dim strBusinessState As String
Dim strBusinessPostalCode As String
Dim strBusinessCountry As String
Dim strBusinessPhone As String
Dim strBusinessFax As String
Dim strHomePhone As String
Dim strOtherPhone As String
Dim strEMailAddress As String
Dim strEMailAddress2 As String
Dim strWebPage As String
Dim strNotes As String
Dim strContactID As String
Dim strCRLF As String
Dim lngCount As Long
stDocName = "Q_ExportToOutlook"

strCRLF = Chr$(13) & Chr$(10)

Set objOutlook = CreateObject("Outlook.Application")
Set nms = objOutlook.GetNamespace("MAPI")
Set fldContacts = nms.GetDefaultFolder(olFolderContacts)
Set itms = fldContacts.Items

Set dbs = CurrentDb
Set rst = dbs![tblPerson].OpenRecordset(dbOpenTable, dbDenyRead)
lngCount = rst.RecordCount
MsgBox lngCount & " records to transfer to Outlook"

Do Until rst.EOF
With rst

strContactID = Nz(![PersonID])
strTitle = Nz(![Title])
strFirstName = Nz(![FirstName])
strLastName = Nz(![LastName])
strJobTitle = Nz(![JobTitle])
strLastNameFirst = Nz(![LastName]) & ", " & Nz(![FirstName])
strBusinessStreet = Nz(![BusinessStreet]) & IIf(Nz(!
[BusinessStreet2]) <"", strCRLF & Nz(![BusinessStreet2]), "")
strBusinessCity = Nz(![BusinessCity])
strBusinessState = Nz(![BusinessState])
strBusinessPostalCode = Nz(![BusinessPostalCode])
strBusinessCountry = Nz(![BusinessCountry])
strBusinessPhone = Nz(![BusinessPhone])
strBusinessFax = Nz(![BusinessFax])
strHomePhone = Nz(![HomePhone])
strHomeFax = Nz(![HomeFax])
strOtherPhone = Nz(![BusinessPhone2])
strOtherFax = Nz(![OtherFax])
strEMailAddress = Nz(![EmailAddress])
strEMailAddress2 = Nz(![Email2Address])
strWebPage = Nz(![WebPage])
strNotes = Nz(![Notes])
End With

Set itm = itms.Add("IPM.Contact")

With itm
.Title = strTitle
.FirstName = strFirstName
.MiddleName = strMiddleName
.LastName = strLastName
.JobTitle = strJobTitle
.BusinessAddressStreet = strBusinessStreet
.BusinessAddressCity = strBusinessCity
.BusinessAddressState = strBusinessState
.BusinessAddressPostalCode = strBusinessPostalCode
.BusinessAddressCountry = strBusinessCountry
.BusinessTelephoneNumber = strBusinessPhone
.BusinessFaxNumber = strBusinessFax
.HomeTelephoneNumber = strHomePhone
.HomeFaxNumber = strHomeFax
.OtherTelephoneNumber = strOtherPhone
.OtherFaxNumber = strOtherFax
.Email1Address = strEMailAddress
.Email2Address = strEMailAddress2
.WebPage = strWebPage
.Notes = strNotes
.Categories = "From Access"
.Close (olSave)
Me![txtLastContact] = strContactID & " -- " &

DoCmd.DoMenuItem acFormBar, stDocName, acNormal,
acRecordsMenu, acSaveRecord, , acMenuVer70

End With

MsgBox "All Contacts exported!"

Exit Sub

MsgBox Err.Description
Resume Exit_ExportToOutlook_Click

End Sub

At the moment i have the Query set up to filter this data from the
form, but it may be easiest to create a Where Condition so that i can
export the different selections to different folders?

Any help would be superb!

Nov 21 '08 #1
Share this question for a faster answer!
Share on Google+

This discussion thread is closed

Replies have been disabled for this discussion.