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
form.
Secondly i'd like to Export contact to Outlooks Contacts based on
selections.
The code i have so far for these is as follows:-
BCC Email:
Private Sub BCCEmail_Click( )
On Error GoTo Err_BCCMail_Cli ck
Dim stDocName As String
Dim MyOutlook As New Outlook.Applica tion
Dim MyMail As Outlook.MailIte m
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 strCategorySele ct As String
Dim strCountrySelec t As String
Dim strWhere As String
stDocName = "Q_Email"
With Me.CategorySele ct
For Each varItem In .ItemsSelected
If Not IsNull(varItem) Then
strCategorySele ct = strCategorySele ct &
strCategorySele ct & strDelim & .ItemData(varIt em) & strDelim & ","
strDescrip = strDescrip & """" & .Column(1, varItem)
& """, "
End If
Next
End With
lngLen = Len(strCategory Select) - 1
If lngLen 0 Then
strCategorySele ct = "[CategoryID] IN (" & Left$
(strCategorySel ect, lngLen) & ")"
lngLen = Len(strDescrip) - 2
If lngLen 0 Then
strDescrip = "Categories : " & Left$(strDescri p, lngLen)
End If
End If
With Me.CountrySelec t
For Each varItem In .ItemsSelected
If Not IsNull(varItem) Then
strCountrySelec t = strCountrySelec t & strCountrySelec t
& strDelim & .ItemData(varIt em) & strDelim & ","
strDescrip = strDescrip & """" & .Column(1, varItem)
& """, "
End If
Next
End With
lngLen = Len(strCountryS elect) - 1
If lngLen 0 Then
strCountrySelec t = "[CountryID] IN (" & Left$
(strCountrySele ct, lngLen) & ")"
lngLen = Len(strDescrip) - 2
If lngLen 0 Then
strDescrip = "Categories : " & Left$(strDescri p, lngLen)
End If
End If
If strCategorySele ct "" Then strWhere = strWhere &
strCategorySele ct & " And "
If strCountrySelec t "" Then strWhere = strWhere &
strCountrySelec t & " And "
If strWhere "" Then strWhere = Left(strWhere, Len(strWhere)
- 5)
Set rst = CurrentDb.OpenR ecordset(stDocN ame, dbOpenForwardOn ly)
With rst
Do Until .EOF
StrBCC = StrBCC & ![EmailAddress] & ";"
..MoveNext
Loop
..Close
End With
StrBCC = Left(StrBCC, Len(StrBCC) - 1)
Set MyOutlook = New Outlook.Applica tion
Set MyMail = MyOutlook.Creat eItem(olMailIte m)
MyMail.BCC = StrBCC
MyMail.Display
Set MyOutlook = Nothing
Set rst = Nothing
Exit_BCCMail_Cl ick:
Exit Sub
Err_BCCMail_Cli ck:
MsgBox Err.Description
Resume Exit_BCCMail_Cl ick
End Sub
Export Contacts:
Private Sub ExportToOutlook _Click()
On Error GoTo Err_ExportToOut look_Click
Dim stDocName As String
Dim dbs As Database
Dim rst As Recordset
Dim objOutlook As Outlook.Applica tion
Dim nms As Outlook.NameSpa ce
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 strLastNameFirs t As String
Dim strBusinessStre et As String
Dim strBusinessStre et2 As String
Dim strBusinessCity As String
Dim strBusinessStat e As String
Dim strBusinessPost alCode As String
Dim strBusinessCoun try As String
Dim strBusinessPhon e As String
Dim strBusinessFax As String
Dim strHomePhone As String
Dim strOtherPhone As String
Dim strEMailAddress As String
Dim strEMailAddress 2 As String
Dim strWebPage As String
Dim strNotes As String
Dim strContactID As String
Dim strCRLF As String
Dim lngCount As Long
stDocName = "Q_ExportToOutl ook"
strCRLF = Chr$(13) & Chr$(10)
Set objOutlook = CreateObject("O utlook.Applicat ion")
Set nms = objOutlook.GetN amespace("MAPI" )
Set fldContacts = nms.GetDefaultF older(olFolderC ontacts)
Set itms = fldContacts.Ite ms
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])
strLastNameFirs t = Nz(![LastName]) & ", " & Nz(![FirstName])
strBusinessStre et = Nz(![BusinessStreet]) & IIf(Nz(!
[BusinessStreet2]) <"", strCRLF & Nz(![BusinessStreet2]), "")
strBusinessCity = Nz(![BusinessCity])
strBusinessStat e = Nz(![BusinessState])
strBusinessPost alCode = Nz(![BusinessPostalC ode])
strBusinessCoun try = Nz(![BusinessCountry])
strBusinessPhon e = Nz(![BusinessPhone])
strBusinessFax = Nz(![BusinessFax])
strHomePhone = Nz(![HomePhone])
strHomeFax = Nz(![HomeFax])
strOtherPhone = Nz(![BusinessPhone2])
strOtherFax = Nz(![OtherFax])
strEMailAddress = Nz(![EmailAddress])
strEMailAddress 2 = Nz(![Email2Address])
strWebPage = Nz(![WebPage])
strNotes = Nz(![Notes])
End With
Set itm = itms.Add("IPM.C ontact")
With itm
.Title = strTitle
.FirstName = strFirstName
.MiddleName = strMiddleName
.LastName = strLastName
.JobTitle = strJobTitle
.BusinessAddres sStreet = strBusinessStre et
.BusinessAddres sCity = strBusinessCity
.BusinessAddres sState = strBusinessStat e
.BusinessAddres sPostalCode = strBusinessPost alCode
.BusinessAddres sCountry = strBusinessCoun try
.BusinessTeleph oneNumber = strBusinessPhon e
.BusinessFaxNum ber = strBusinessFax
.HomeTelephoneN umber = strHomePhone
.HomeFaxNumber = strHomeFax
.OtherTelephone Number = strOtherPhone
.OtherFaxNumber = strOtherFax
.Email1Address = strEMailAddress
.Email2Address = strEMailAddress 2
.WebPage = strWebPage
.Notes = strNotes
.Categories = "From Access"
.Close (olSave)
Me![txtLastContact] = strContactID & " -- " &
strLastNameFirs t
DoCmd.DoMenuIte m acFormBar, stDocName, acNormal,
acRecordsMenu, acSaveRecord, , acMenuVer70
End With
rst.MoveNext
Loop
MsgBox "All Contacts exported!"
Exit_ExportToOu tlook_Click:
Exit Sub
Err_ExportToOut look_Click:
MsgBox Err.Description
Resume Exit_ExportToOu tlook_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!
