Need to direct my appointment a non default calendar

[Dan011]

Need to direct my appointment to another calendar under "my calendars" in outlook. The calendar is named "Labs". can't figure out how to make the modification short of starting over. Thanks for your help!


Sub AddToCalendar()
' 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
Worksheets("DateCalc").Activate

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 = 4 ' first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd, myCatagory
While Len(Cells(r, 2).Text) <> 0
mysub = Cells(r, 2) & ", " & Cells(r, 3)
If Cells(r, 6).Value = "" Then

Else
myStart = DateValue(Cells(r, 6).Value) + Cells(r, 5).Value
myEnd = DateAdd("h", 1, myStart) 'DateValue(Cells(r, 6).Value) + (Cells(r, 5).Value + (1 / 24))
End If

myCatagory = Cells(r, 7).Value & " , Labs"

If myStart = "1/1/1900 12:00:00 AM" Then
Else
'DeleteTestAppointments mysub, myStart, myEnd
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
'.Location = Cells(r, 3)
.Body = ""
.ReminderSet = False
'.BusyStatus = olfree
'.RequiredAttendees = ""
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 2) & " - Labs"
'.Attachments.Add ("c:\temp\somefile.msg")
'.Location = Cells(r, 3).Value
'.Body = .Subject & ", " & Cells(r, 4).Value
.ReminderSet = False
.BusyStatus = olbusy
.Categories = myCatagory '"Orange Category" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
End If

r = r + 1

mysub = ""
myStart = "1/1/1900 12:00:00 AM"
myEnd = ""
myCatagory = ""


Wend
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub

[Dan011]

Not Pretty, but it does what I want it to. Maybe someone can help me clean it up a little?


Sub AddToCalendar()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim olFldr As Outlook.MAPIFolder
Dim r As Long

On Error Resume Next
Worksheets("DateCalc").Activate

Set olApp = New Outlook.Application 'GetObject("", "Outlook.Application")
Set olFldr = olApp.GetNamespace("MAPI").GetDefaultFolder(9).Folders("Labs")
' Set olAppItem = olFldr.Items.Add

'************* Is Outlook Open ******************
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 = 4 ' first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd, myCatagory
While Len(Cells(r, 2).Text) <> 0
mysub = Cells(r, 2) & ", " & Cells(r, 3)
If Cells(r, 6).Value = "" Then

Else
myStart = DateValue(Cells(r, 6).Value) + Cells(r, 5).Value
myEnd = DateAdd("h", 1, myStart) 'DateValue(Cells(r, 6).Value) + (Cells(r, 5).Value + (1 / 24))
End If

myCatagory = Cells(r, 7).Value & " , Labs"

If myStart = "1/1/1900 12:00:00 AM" Then
Else
'DeleteTestAppointments mysub, myStart, myEnd

'Set olFldr = olApp.GetNamespace("MAPI").GetDefaultFolder(9).Folders("Labs")
Set olAppItem = olFldr.Items.Add

'Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
'.Location = Cells(r, 3)
.Body = ""
.ReminderSet = False
'.BusyStatus = olfree
'.RequiredAttendees = ""
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 2) & " - Labs"
'.Attachments.Add ("c:\temp\somefile.msg")
'.Location = Cells(r, 3).Value
'.Body = .Subject & ", " & Cells(r, 4).Value
.ReminderSet = False
.BusyStatus = olbusy
.Categories = myCatagory '"Orange Category" ' add this to be able to delete the testappointments
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
End If

r = r + 1

mysub = ""
myStart = "1/1/1900 12:00:00 AM"
myEnd = ""
myCatagory = ""


Wend
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub