mark hansen
Well-known Member
- Joined
- Mar 6, 2006
- Messages
- 534
- Office Version
- 2016
- Platform
- Windows
I've been searching on and off for about a week (when I have had the time) and found the following code that takes a list of information and create a meeting request for each of the people in the list. It works (sort of). I get the meeting request on my calendar, but the request isn't sent to the other person. When I open the meeting on my calendar it says it hasn't been sent yet. The invitation goes when I click send, but it doesn't send automatically. I look at other code on this site that does this, and I can't get it to work. The problem is when I try to insert the .SEND line to send it. It says error 287 Application-defined or object-defined error.
I have all of the Outlook References loaded (14.0 Object Library and others)
How can I get this to automatically send the meeting request?
I have all of the Outlook References loaded (14.0 Object Library and others)
How can I get this to automatically send the meeting request?
Code:
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.appointmentItem
Dim r As Long
Dim myPath As String
Application.ScreenUpdating = False
myPath = ActiveWorkbook.Path
DeleteTestAppointments ' deletes previous test appointments
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 10 ' first row with appointment data in the active worksheet
While Len(Cells(r, 1).Formula) > 0
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Start = Now
.End = Now
.Subject = "No subject"
.Location = ""
.Body = ""
.ReminderSet = True
.MeetingStatus = olMeeting
' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(r, 1).Value + Cells(r, 2).Value
.End = Cells(r, 1).Value + Cells(r, 3).Value
.Subject = Cells(r, 4).Value
.Location = Cells(r, 5).Value
.ReminderSet = Cells(r, 8).Value
.Importance = Right(Cells(r, 9).Value, 1)
.RequiredAttendees = Cells(r, 10).Value
.Categories = "TestAppointment" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
With olApp
Dim Xl As Excel.Application
Dim Ws As Excel.Worksheet
Dim xlRn As Excel.Range
Set Xl = GetObject(, "Excel.Application")
Set Ws = Xl.Workbooks.Parent.Worksheets(Cells(r, 1).Offset(0, 5).Value)
Set xlRn = Ws.Range("MailBodyText")
Dim varBody As String
Dim objdata As DataObject
Dim DataObject As Object
Set objdata = New DataObject
Application.GoTo Reference:=xlRn
Selection.Copy
objdata.GetFromClipboard
varBody = objdata.GetText
With olAppItem
.Body = "test body" 'varBody '& vbCrLf & vbCrLf
End With
End With
olAppItem.Close olSave
r = r + 1
Sheets("scheduleapp").Activate
Wend
Set olAppItem = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
End Sub