?
Solved

Send Email Appointment from Access using vba

Posted on 2012-09-09
6
Medium Priority
?
1,478 Views
Last Modified: 2012-09-15
Hi,

I currently send emails from Access 2007 using Outlook 2007 Automation that include text outlining client appointment dates and times.

I would like to add a calendar attachment to the email but am not able to get my vba code to work.

Does anyone have a working code snippet they can provide to get me on track.

Thanks.
0
Comment
Question by:isurgyn
  • 4
  • 2
6 Comments
 
LVL 85

Assisted Solution

by:Scott McDaniel (Microsoft Access MVP - EE MVE )
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 2000 total points
ID: 38382444
but am not able to get my vba code to work.
Always a good idea to include your code when posting questions like this.

FWIW, I use vbMAPI when working with Outlook from Access (www.everythingaccess.com). It's an addin that takes the work out of working with Outlook, and is well worth the cost.
0
 

Author Comment

by:isurgyn
ID: 38383063
My code was too embarrasing to post.

I took a quick look at vbMAPI website.  I will definitely check it out.

Thanks.
0
 

Author Comment

by:isurgyn
ID: 38383566
I am posting my current code for sending email via Outlook that works just fine.  However, as stated I would like to add an Outlook Appointment attachment that I can send as well so that the person can choose to accept the appointment and add it to their calendar.  The vbMAPI solution will logically work but it appears that I will need to recode the entire email process using that plugin.  It seems that it can't be that much to simply add the Appointment attachment code to my current process.

    Dim strMsg As String
    Dim iResponse As Integer
   
    If IsNull([Email]) Or [Email] = "" Then GoTo ErrHandler

  ' Check if Outlook is already running
   
    Dim olApp As Object
    Dim OutlookWasNotRunning As Boolean
    Dim strAppName As String

    On Error Resume Next
   
      Set olApp = GetObject(, "Outlook.Application")
      If Err.Number <> 0 Then
         Err.Clear
         OutlookWasNotRunning = True
         strAppName = "C:\Program Files\Microsoft Office\Office12\Outlook.exe"
        Call Shell(strAppName, vbMinimizedFocus)
      Else
         Set olApp = GetObject("Outlook.Application")
      End If
     
    '  Now Outlook has been opened if it was not open
   
    '  Send HTML email next

    Dim myOlApp As Outlook.Application
    Dim MyItem As Outlook.MailItem
    Dim objDoc As Object
    Dim OutlookRecip As Object
    Dim myRecipient As Object
   
    Dim strTo As String
    Dim strTodaysDate As String
    Dim strApptDate As String
    Dim strApptTime As String
    Dim strApptMonth As String
    Dim strApptWeekDay As String
    Dim strApptDay As String
    Dim strApptYear As String
    Dim strApptType As String
    Dim strAppt As String
    Dim strName As String
    Dim strHTML As String
   
    strApptTime = TimeValue([DateApptScheduled])
    strApptDate = DateValue([DateApptScheduled])
    strApptDay = Day([DateApptScheduled])
    strApptWeekDay = WeekdayName(Weekday([DateApptScheduled]))
    strApptMonth = MonthName(Month([DateApptScheduled]))
    strApptYear = Year([DateApptScheduled])
    strTodaysDate = Format(Date, "dddd, mmmm dd, yyyy")
    strApptType = [VisitType]
    strAppt = strApptWeekDay & ", " & strApptMonth & " " & strApptDay & ", " & strApptYear
    strName = [First]
    strTo = [Email]
     
    If Me.ProviderID = 3 Then strApptType = "Post-operative Checkup in Office 1"
   
    If Me.ProviderID = 5 Then strApptType = "Post-operative Checkup in Office 2"
 
    If Me.ProviderID = 7 Then strApptType = "Post-operative Checkup in Office 3"

    If Me.ProviderID = 2 Then strApptType = "Comprehensive Eye Examination in Office 1"

    If Me.ProviderID = 4 Then strApptType = "Comprehensive Eye Examination in Office 2"

    If Me.ProviderID = 6 Then strApptType = "Comprehensive Eye Examination in Office 3"

    If Me.ProviderID = 8 Then strApptType = "Surgery in Office 1"
   
    If Me.ProviderID = 9 Then strApptType = "Surgery in Office 2"
   
    Set myOlApp = CreateObject("Outlook.Application")

    Set MyItem = myOlApp.CreateItemFromTemplate("C:\Template1.oft")
   
        With MyItem
   
            Set myRecipient = MyItem.Recipients.Add(strTo)
            .Subject = "Your appointment at Our Office"
            .Importance = 1
           
        End With
       
    MyItem.HTMLBody = Replace(MyItem.HTMLBody, "%text1%", strTodaysDate)
    MyItem.HTMLBody = Replace(MyItem.HTMLBody, "%text2%", strName)
    MyItem.HTMLBody = Replace(MyItem.HTMLBody, "%text3%", strAppt)
    MyItem.HTMLBody = Replace(MyItem.HTMLBody, "%text4%", strApptTime)
    MyItem.HTMLBody = Replace(MyItem.HTMLBody, "%text5%", strApptType)
    MyItem.Display
    Set objDoc = MyItem.GetInspector.WordEditor
    objDoc.Windows(1).Selection.Find.ClearFormatting
    objDoc.Windows(1).Selection.Find.Execute strSender
    Set myOlApp = Nothing
    Set objDoc = Nothing
   
    Exit Sub

ErrHandler:

    strMsg = "There is no email entered for this patient" & Chr(10)
    strMsg = strMsg & "Add and email address then proceed again" & Chr(10)
   
    iResponse = MsgBox(strMsg, vbOKOnly, "No Email Address Exists")
   
        Cancel = True



This is some vba code that I found using Google but I have not been successful at integrating it with my email vba code.  Any thoughts before I try the vbMAPI solution?



Dim outMail As Outlook.AppointmentItem

Set outMail = Outlook.CreateItem(olAppointmentItem)

outMail.Subject = "A new appointment has been booked for me"

outMail.Location = "Nowhere"

outMail.MeetingStatus = olMeeting

outMail.Start = #2/8/2008# & " " & #9:15:00 AM#

outMail.End = #2/8/2008# & " " & #10:15:00 AM#

outMail.RequiredAttendees = "Email addresses for attendees"

outMail.Body = "No Reason"

outMail.Send

Set outMail=Nothing


Thanks.
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LVL 85
ID: 38384067
Have you tried your appointment code with your Outlook item:

Set myOlApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.AppointmentItem

Set outMail = OlApp.CreateItem(olAppointmentItem)

outMail.Subject = "A new appointment has been booked for me"

outMail.Location = "Nowhere"
0
 

Accepted Solution

by:
isurgyn earned 0 total points
ID: 38385537
OK I finally got the following code to work correctly.  It is a bit rough and perhaps is not the best Error Handling routines but it does work beautifully!

I have to admit I searched Google and Bing for hours and found no properly working code to do this.  Thanks for providing direction.  I am certain that the vbMAPI is a good solution as well.

Also one can add more options on the ics file.  Just consult the appropriate MSDN files.

  Dim strMsg As String
  Dim iResponse As Integer
 
    If IsNull(Me.Email) Or Me.Email = "" Then GoTo ErrHandler1
 
  ' Check if Outlook is already running
   
    Dim olApp As Object
    Dim OutlookWasNotRunning As Boolean
    Dim strAppName As String
    Dim myRecipient As Object
    Dim toStr As String
 
    On Error Resume Next  'Simplest way to check for Outlook instance
   
      Set olApp = GetObject(, "Outlook.Application")
      If Err.Number <> 0 Then
         Err.Clear
         OutlookWasNotRunning = True
         strAppName = "C:\Program Files\Microsoft Office\Office12\Outlook.exe"
        Call Shell(strAppName, vbMinimizedFocus)
      Else
         Set olApp = GetObject("Outlook.Application")
      End If
     
    '  Now Outlook has been opened if it was not open
   
    On Error GoTo ErrHandler2
 
    Dim myOlApp As Outlook.Application
    Dim outAppt As Outlook.AppointmentItem
 
    Set outAppt = olApp.CreateItem(olAppointmentItem)
    toStr = Me.Email
    Set myRecipient = outAppt.Recipients.Add(toStr)
           
        With outAppt
 
            .Subject = "A new appointment has been booked for you"
 
            .Location = "Office 1"
 
            .MeetingStatus = olMeeting
 
            .Start = #12/10/2012# & " " & #9:15:00 AM#
 
            .End = #12/10/2012# & " " & #10:15:00 AM#
 
            .RequiredAttendees = Me.Email  'Very important- this must be a valid email
 
            .Body = "Very Important Meeting"
 
            .Send
 
            Set outAppt = Nothing
            Set myOlApp = Nothing
            Set olApp = Nothing
           
            End With
           
        Exit Sub
 
ErrHandler1:
 
    strMsg = "There is no email entered for this patient" & Chr(10)
    strMsg = strMsg & "Add and email address then proceed again" & Chr(10)
   
    iResponse = MsgBox(strMsg, vbOKOnly, "No Email Address Exists")
   
        Cancel = True
       
    Exit Sub
   
ErrHandler2:
   
    strMsg = "Err = " & Err.Number & " Error Description = " & Err.Description
0
 

Author Closing Comment

by:isurgyn
ID: 38401373
The solution provided was the final outcome of the input from other Experts, however no input suggested a proper solution using vba code. As a result, I chose my own solution that solved the problem exactly as required.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Windows Explorer lets you open cabinet (cab) files like any other folder. In VBA you can easily handle normal files and folders, but opening and indeed creating cabinet files takes a lot more - and that's you'll find here.
This article will help to fix the below errors for MS Exchange Server 2016 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
Whether it be Exchange Server Crash Issues, Dirty Shutdown Errors or Failed to mount error, Stellar Phoenix Mailbox Exchange Recovery has always got your back. With the help of its easy to understand user interface and 3 simple steps recovery proced…
Suggested Courses

864 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question