Private Sub cmdSaveToOutlook_Click()
On Error GoTo Error_Handler
Const olContactItem = 2
Dim olapp As Object, olContact As Object
Dim Ctct As Object, BFax As String
Set olapp = CreateObject("Outlook.Application")
Set olContact = olapp.CreateItem(olContactItem)
'pre-fix fax number with "fax" so it doesn't pop up in the address book
If IsNull(Me.Business_Fax) Then
BFax = ""
Else: BFax = ("Fax " & Me.Business_Fax)
End If
With olContact
.FirstName = Nz(Me.First, "")
.LastName = Nz(Me.Last, "")
.JobTitle = Nz(Me.Job_Title, "")
.CompanyName = Nz(Me.CompanyName, "")
.BusinessAddressStreet = Nz(Me.MailingAddress, "")
.BusinessAddressCity = Nz(Me.City, "")
.BusinessAddressState = Nz(Me.State, "")
.BusinessAddressCountry = "USA"
.BusinessAddressPostalCode = Nz(Me.Zip_Postal_Code, "")
.BusinessTelephoneNumber = Nz(Me.Phone, "")
.BusinessFaxNumber = BFax
.Email1Address = Nz(Me.E_mail_address, "")
.Email1DisplayName = Nz(Me.DisplayAs, "")
.MobileTelephoneNumber = Nz(Me.Mobile_Phone, "")
.Display 'use .Display if you wish the user to see the contact pop-up .Save to save
End With
Error_Handler_Exit:
On Error Resume Next
Set olContact = Nothing
Set olapp = Nothing
End
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: AddOlContact" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub