scotwithadevil
New member
- Local time
- Today, 21:11
- Joined
- Jul 13, 2013
- Messages
- 9
Hi
Someone please take pity on me and help me with this code which I have now spent over hours and hours and hours on.
I am using Access VBA to open Outlook 2010 and send an email followed by a calendar appointment (my coding allows user to choose which calendar to put appointment in).
The email bit is working and I actually got the calendar appointment bit to work ONCE but since then I keep getting a 462 error. I think it is something to do with whether I have an open or closed instance of Outlook but I don't know how to solve it.
This is my coding:
Sub EmailRequiredDelegatesOther()
'------------------------------------
'Declare Variables
'------------------------------------
On Error GoTo Error_trap
Dim WDOtype As String
Dim EmailTo As String
Dim EmailCC As String
Dim EmailBCC As String
Dim EmailBody As String
Dim EmailDates As String
Dim EmailTitle As String
Dim EmailSalutation As String
Dim SessionDetails As String
Dim db As DAO.Database
Dim qry As QueryDef
Dim qry2 As QueryDef
Dim qry3 As QueryDef
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim ouApp As Outlook.Application
Dim ouMsg As Outlook.MailItem
Dim ouAttachment As Outlook.Attachment
Dim EmailFrom As Outlook.Account
Dim olfolder As Outlook.MAPIFolder
Dim CalendarFrom As String
Dim fld As DAO.Field
Dim msg As String
Dim outInvite As Outlook.AppointmentItem
Dim InviteList As String
Dim InviteBody As String
Dim ConfirmMsg As String
Dim Session As Object
'Coding here sets up the email addresses and message, etc
'then my coding moves on to the following
'--------------------------------------------
' Open Outlook
'--------------------------------------------
rs.MoveFirst
Do Until rs.EOF
Set ouApp = CreateObject("Outlook.Application")
Set ouMsg = ouApp.CreateItem(olMailItem)
EmailTo = rs.Fields("EmailAddress").Value
If rs.Fields("LineManagersEmail").Value > 0 Then
EmailCC = rs.Fields("LineManagersEmail").Value
End If
EmailSalutation = "<html><FONT FACE='Arial'><body>"
EmailSalutation = EmailSalutation & "Dear " & rs.Fields("FirstName") & ",<br><br>"
EmailSalutation = EmailSalutation & EmailBody
With ouMsg
'------------------------------------------
'emal headers and body
'------------------------------------------
.To = EmailTo
If rs.Fields("LineManagersEmail").Value > 0 Then
.CC = EmailCC
End If
'.SendUsingAccount = EmailFrom
'.SentOnBehalfOfName = EmailFrom
'.ReplyRecipients = EmailFrom
.Subject = EmailTitle
.HTMLBody = EmailSalutation
'--------------------------------------------
'send or save to drafts
'--------------------------------------------
'.Send
.Save
End With
'-----------------------------------------------------
'Set booking confirmation sent date and contact method
'-----------------------------------------------------
rs.Edit
rs.Fields("EmailDate").Value = Date
rs.Update
InviteList = InviteList & rs.Fields("EmailAddress").Value & ";"
'---------------
'next delegate
'---------------
rs.MoveNext
Loop
'----------------
'Emails all done
'----------------
rs.Close
Set rs = Nothing
ConfirmMsg = "Emails have been created but not sent."
'-------------------------
'Send calendar invitation
'-------------------------
'GoTo Skip_CalendarInvite
InviteBody = "This is to remind you that you are booked to attend the above training course. " & vbCrLf
InviteBody = InviteBody & "If you are unable to attend this course, you MUST inform us by emailing "
InviteBody = InviteBody & CalendarFrom & " "
InviteBody = InviteBody & "to advise us you can no longer attend. " & vbCrLf & vbCrLf
InviteBody = InviteBody & "This calendar invite is for your information only and we DO NOT monitor Accept/Decline calendar invite responses. " & vbCrLf & vbCrLf
InviteBody = InviteBody & "You may wish to change the status of this calendar entry to busy."
Set ouApp = CreateObject("Outlook.Application")
Set outInvite = Outlook.CreateItem(olAppointmentItem)
'Select required folder in My Calendars
Set olfolder = ouApp.GetNamespace("MAPI").PickFolder
Set outInvite = olfolder.Items.Add
outInvite.MeetingStatus = olMeeting
outInvite.Subject = Me.CourseName
outInvite.Importance = 2 ' high
outInvite.BusyStatus = 0 ' free (you don't want your own calendar to show tentative or busy)
outInvite.Location = Me.Venue
outInvite.Start = Me.StartDate & " " & Me.StartTime
outInvite.End = Me.StartDate & " " & Me.EndTime
outInvite.RequiredAttendees = InviteList
outInvite.Body = InviteBody
outInvite.ResponseRequested = False
outInvite.ReminderMinutesBeforeStart = 1440
'outInvite.Send 'Uncomment if you want invitations sent immediately, rather than just setting up (but not sending)a new meeting request in your calendar
outInvite.Save 'Uncomment if you want message saved to your sent items folder
'Set outInvite = Nothing
'Set olfolder = Nothing
'ouApp.Quit
Set ouApp = Nothing
ConfirmMsg = "Emails and Calendar Invites have been created but not sent."
Skip_CalendarInvite:
'---------
'Reminder
'---------
MsgBox ConfirmMsg
'------------------
'Finished
'------------------
ExitHere:
Exit Sub
Someone please take pity on me and help me with this code which I have now spent over hours and hours and hours on.
I am using Access VBA to open Outlook 2010 and send an email followed by a calendar appointment (my coding allows user to choose which calendar to put appointment in).
The email bit is working and I actually got the calendar appointment bit to work ONCE but since then I keep getting a 462 error. I think it is something to do with whether I have an open or closed instance of Outlook but I don't know how to solve it.
This is my coding:
Sub EmailRequiredDelegatesOther()
'------------------------------------
'Declare Variables
'------------------------------------
On Error GoTo Error_trap
Dim WDOtype As String
Dim EmailTo As String
Dim EmailCC As String
Dim EmailBCC As String
Dim EmailBody As String
Dim EmailDates As String
Dim EmailTitle As String
Dim EmailSalutation As String
Dim SessionDetails As String
Dim db As DAO.Database
Dim qry As QueryDef
Dim qry2 As QueryDef
Dim qry3 As QueryDef
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim ouApp As Outlook.Application
Dim ouMsg As Outlook.MailItem
Dim ouAttachment As Outlook.Attachment
Dim EmailFrom As Outlook.Account
Dim olfolder As Outlook.MAPIFolder
Dim CalendarFrom As String
Dim fld As DAO.Field
Dim msg As String
Dim outInvite As Outlook.AppointmentItem
Dim InviteList As String
Dim InviteBody As String
Dim ConfirmMsg As String
Dim Session As Object
'Coding here sets up the email addresses and message, etc
'then my coding moves on to the following
'--------------------------------------------
' Open Outlook
'--------------------------------------------
rs.MoveFirst
Do Until rs.EOF
Set ouApp = CreateObject("Outlook.Application")
Set ouMsg = ouApp.CreateItem(olMailItem)
EmailTo = rs.Fields("EmailAddress").Value
If rs.Fields("LineManagersEmail").Value > 0 Then
EmailCC = rs.Fields("LineManagersEmail").Value
End If
EmailSalutation = "<html><FONT FACE='Arial'><body>"
EmailSalutation = EmailSalutation & "Dear " & rs.Fields("FirstName") & ",<br><br>"
EmailSalutation = EmailSalutation & EmailBody
With ouMsg
'------------------------------------------
'emal headers and body
'------------------------------------------
.To = EmailTo
If rs.Fields("LineManagersEmail").Value > 0 Then
.CC = EmailCC
End If
'.SendUsingAccount = EmailFrom
'.SentOnBehalfOfName = EmailFrom
'.ReplyRecipients = EmailFrom
.Subject = EmailTitle
.HTMLBody = EmailSalutation
'--------------------------------------------
'send or save to drafts
'--------------------------------------------
'.Send
.Save
End With
'-----------------------------------------------------
'Set booking confirmation sent date and contact method
'-----------------------------------------------------
rs.Edit
rs.Fields("EmailDate").Value = Date
rs.Update
InviteList = InviteList & rs.Fields("EmailAddress").Value & ";"
'---------------
'next delegate
'---------------
rs.MoveNext
Loop
'----------------
'Emails all done
'----------------
rs.Close
Set rs = Nothing
ConfirmMsg = "Emails have been created but not sent."
'-------------------------
'Send calendar invitation
'-------------------------
'GoTo Skip_CalendarInvite
InviteBody = "This is to remind you that you are booked to attend the above training course. " & vbCrLf
InviteBody = InviteBody & "If you are unable to attend this course, you MUST inform us by emailing "
InviteBody = InviteBody & CalendarFrom & " "
InviteBody = InviteBody & "to advise us you can no longer attend. " & vbCrLf & vbCrLf
InviteBody = InviteBody & "This calendar invite is for your information only and we DO NOT monitor Accept/Decline calendar invite responses. " & vbCrLf & vbCrLf
InviteBody = InviteBody & "You may wish to change the status of this calendar entry to busy."
Set ouApp = CreateObject("Outlook.Application")
Set outInvite = Outlook.CreateItem(olAppointmentItem)
'Select required folder in My Calendars
Set olfolder = ouApp.GetNamespace("MAPI").PickFolder
Set outInvite = olfolder.Items.Add
outInvite.MeetingStatus = olMeeting
outInvite.Subject = Me.CourseName
outInvite.Importance = 2 ' high
outInvite.BusyStatus = 0 ' free (you don't want your own calendar to show tentative or busy)
outInvite.Location = Me.Venue
outInvite.Start = Me.StartDate & " " & Me.StartTime
outInvite.End = Me.StartDate & " " & Me.EndTime
outInvite.RequiredAttendees = InviteList
outInvite.Body = InviteBody
outInvite.ResponseRequested = False
outInvite.ReminderMinutesBeforeStart = 1440
'outInvite.Send 'Uncomment if you want invitations sent immediately, rather than just setting up (but not sending)a new meeting request in your calendar
outInvite.Save 'Uncomment if you want message saved to your sent items folder
'Set outInvite = Nothing
'Set olfolder = Nothing
'ouApp.Quit
Set ouApp = Nothing
ConfirmMsg = "Emails and Calendar Invites have been created but not sent."
Skip_CalendarInvite:
'---------
'Reminder
'---------
MsgBox ConfirmMsg
'------------------
'Finished
'------------------
ExitHere:
Exit Sub
