Dan011
02-24-2016, 12:38 PM
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
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