Need Help Big Time
I am running Excel 2002 and i have a Macro that is giving me trouble. Or precisely one line of the Macro. Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
Below i have the whole entire code. But the line above keeps giving me a and Error stating " Runtime error 287 application-defined or object-defined error".
I have also attached a copy of the file i am using. Can someone please assist?
Option Explicit
' requires a reference to the Microsoft Outlook x.0 Object Library
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
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
' 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
.Body = Cells(r, 6).Value
.ReminderSet = Cells(r, 7).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
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub
| Attachment | Size |
|---|---|
| Automatically Schedule Multiple Outlook Appointments.xls | 68.5 KB |
It runs absolutely fine on my
It runs absolutely fine on my system. Was the same code running fine previously ? Is there anything you have changed ?
No i didn't change anything.
No i didn't change anything. It works just fine on my home pc also. But when i come to work to use it. It does not fuction. Maybe it is just a excel 2002 problem.
Yes, may be. What Excel
Yes, may be. What Excel version you are using at work, and at home ?
Try one more thing I am not sure though...put 1 in place of olAppointmentItem.
And yes, check or reselect the correct reference library for Outlook as well.
Thank YOu. I finally got it
Thank YOu. I finally got it working. But now I am wondering if you could help me out with another problem i having. I want the appointments to go to a separte calendar i have in Oultook, instead of my main Calendar. Is this possible?
Appointment to separate calendar
Hi,
Here's some solution. Adjust it to your specific need:
' ************************* ' ************************* '
Sub AppointmentInToSeparateCalendar()
Const SEPARATE_CALENDAR As String = "MySeparateCalendar"
Dim oApplication As Outlook.Application
Dim oNameSpace As Outlook.Namespace
Dim oFolder As Outlook.Folder
Dim oAppointmentItem As Outlook.AppointmentItem
On Error GoTo ERROR_HANDLER
Set oApplication = CreateObject("Outlook.Application")
Set oNameSpace = oApplication.GetNamespace("MAPI")
Set oFolder = oNameSpace.Folders.Item("Personal Folders") _
.Folders.Item("Calendar").Folders.Item(SEPARATE_CALENDAR)
Set oAppointmentItem = oFolder.Items.Add(olAppointmentItem)
With oAppointmentItem
.Start = Now
.End = Now
.Subject = "Test Appointment Subject"
.Location = "Test Appointment Location"
.Body = "Test Appointment Body"
.ReminderSet = True
.Save
End With
EXIT_SUB:
Set oAppointmentItem = Nothing
Set oFolder = Nothing
Set oNameSpace = Nothing
Set oApplication = Nothing
Exit Sub
ERROR_HANDLER:
' Some code for error handling
Err.Clear
GoTo EXIT_SUB
End Sub
' ************************* ' ************************* '
Note: 1) Change SEPARATE_CALENDAR constant to your separate calendar name.
2) If the appointment is already in your default calendar and you want to move it to another calendar:
' ************************* ' ************************* '
' Some code
Set oFolder = oNameSpace.Folders.Item("Personal Folders") _
.Folders.Item("Calendar").Folders.Item(SEPARATE_CALENDAR)
Set oAppointmentItem = Some_Appointment
oAppointmentItem.Move DestFldr:=oFolder
' Some code
' ************************* ' ************************* '
Best regards.
Edit: I forget to note that you probably have to replace "Personal Folders" with "Mailbox - Your Name".
I am using Excel 2007 at
I am using Excel 2007 at home. And i tried replacing olappointmentItem with a 1, and i still came up with the same error message.