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_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
Next
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
Next
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] & ";"
..MoveNext
Loop
..Close
End With
StrBCC = Left(StrBCC, Len(StrBCC) - 1)
Set MyOutlook = New Outlook.Application
Set MyMail = MyOutlook.CreateItem(olMailItem)
MyMail.BCC = StrBCC
MyMail.Display
Set MyOutlook = Nothing
Set rst = Nothing
Exit_BCCMail_Click:
Exit Sub
Err_BCCMail_Click:
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 & " -- " &
strLastNameFirst
DoCmd.DoMenuItem acFormBar, stDocName, acNormal,
acRecordsMenu, acSaveRecord, , acMenuVer70
End With
rst.MoveNext
Loop
MsgBox "All Contacts exported!"
Exit_ExportToOutlook_Click:
Exit Sub
Err_ExportToOutlook_Click:
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!
