Create an Appointment at the Contact's Address From Email

Not open for further replies.

George Z

New Member
Outlook version
Outlook 2013 64 bit
Email Account
Exchange Server
Utilizing the following macro written by Diane Poremsky. It has been a great little macro for use in our service department. I have modified the macro a bit to also pull additional information from the contact as well as utilize a couple input boxes to collect data specific to service call. Below is the modified version of the macro.

I am attempting to make a new revision I am stumbling with a bit. I have some contacts
which i receive emails from requesting a service call. I would like to modify the macro to run from my inbox when a mail message is selected, and the customer contact information is present in my contacts. I have seen several macros to create an appointment base on an email message though I would like the appointment data to be pulled from the contact ( as outlined below) versus the email itself. Any assistance would be greatly appreciated. Thanks in advance!

Sub CreateMeetingatContactLocation()

Dim oOL As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objContact As Outlook.ContactItem
Dim strPhone As String

Set oOL = Outlook.Application
Set objAppt = oOL.CreateItem(olAppointmentItem)
Set objContact = oOL.ActiveExplorer.Selection.Item(1)

inputdata = InputBox("Please Enter Service Technican and Van Number in the FollowinG Format 14 MM/TS")
inputdata1 = InputBox("Please Enter a Descpiption of the Problem")
inputdata2 = InputBox("If a Man Lift is Required to Complete Service please note if lift will be provided by Beaton or Customer. If no Manlift is Needed enter Not Required")
inputdata3 = InputBox("Please Enter Company Hours of Operation to Complete Service")
inputdata4 = InputBox("Please Enter Location and Status of Required Parts if Applicable. Enter N/A if Not Applicable.")
inputdata5 = InputBox("Please Enter the Priority Level of Equipment Failure and Date Customer is Expecting Service")
inputdata6 = InputBox("Please Enter any Other Additional Notes Relevant to Service Request, Customer Expectation, and or Technical Details")

' Use Company for Location
If objContact.CompanyName <> "" Then
objAppt.Subject = inputdata & " , " & objContact.CompanyName & ", - OR - " & objContact.FullName & " , Phone: " & objContact.BusinessTelephoneNumber & " , Cell: " & objContact.MobileTelephoneNumber

' Use Business address if available, else home address
If objContact.BusinessAddress <> "" Then
objAppt.Location = objContact.BusinessAddressStreet & "," & objContact.BusinessAddressCity & "," & objContact.BusinessAddressState & "," & objContact.BusinessAddressPostalCode
strPhone = objContact.BusinessTelephoneNumber

objAppt.Location = objContact.HomeAddressStreet & ", " & objContact.HomeAddressCity & " " & objContact.HomeAddressState & " " & objContact.HomeAddressPostalCode
strPhone = objContact.HomeTelephoneNumber

End If
' Add contact's name and phone number to the body
objAppt.Body = "DESCRIPTION OF PROBLEM: " & inputdata1 & vbNewLine & vbNewLine & "MANLIFT: " & inputdata2 & vbNewLine & vbNewLine & "HOURS OF OPERATION: " & inputdata3 & vbNewLine & vbNewLine & "REQUIRED PARTS AND STATUS: " & inputdata4 & vbNewLine & vbNewLine & "SERVICE PRIORITY: " & inputdata5 & vbNewLine & vbNewLine & "ADDITIONAL NOTES: " & inputdata6

Set objAppt = Nothing
Set objContact = Nothing
Set oOL = Nothing

End If
End Sub
Not open for further replies.