moliverio
08-05-2014, 06:58 AM
**I am a newb when it comes to VBA** I'm just a hack borrowing code and such. Please be gentle. :-)
I modified this code that I found on "The Google" for my purposes. Current it adds appointments from excel into my calendar in outlook. I need help modifying the code to create appointments on a shared calendar. I did a lot of digging, but as I have no formal coding training/experience, I'm not sure how to proceed. Below is a screenshot of the spreadsheet. Any help or direction is greatly appreciated!
Here is the code I am using:
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As String, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean
Const cal_path = ""
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Folders("Mailbox - Jones, Marita Y - Payroll Operations Training Programs").Folders("Calendar")
For r = 5 To 20
If Len(Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 3).Value
sBody = Sheet1.Cells(r, 6).Value
dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
dEndTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value
sLocation = Sheet1.Cells(r, 7).Value
dReminder = Sheet1.Cells(r, 4).Value
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
Private Sub CommandButton1_Click()
Sheet1.AddToOutlook
End Sub
12057
I modified this code that I found on "The Google" for my purposes. Current it adds appointments from excel into my calendar in outlook. I need help modifying the code to create appointments on a shared calendar. I did a lot of digging, but as I have no formal coding training/experience, I'm not sure how to proceed. Below is a screenshot of the spreadsheet. Any help or direction is greatly appreciated!
Here is the code I am using:
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String, sLocation As String
Dim dStartTime As Date, dEndTime As Date, dReminder As String, dCatagory As Double
Dim sSearch As String, bOLOpen As Boolean
Const cal_path = ""
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Folders("Mailbox - Jones, Marita Y - Payroll Operations Training Programs").Folders("Calendar")
For r = 5 To 20
If Len(Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 3).Value
sBody = Sheet1.Cells(r, 6).Value
dStartTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 2).Value
dEndTime = Sheet1.Cells(r, 1).Value + Sheet1.Cells(r, 5).Value
sLocation = Sheet1.Cells(r, 7).Value
dReminder = Sheet1.Cells(r, 4).Value
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Location = sLocation
olAppt.Catagory = dCatagory
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function
Private Sub CommandButton1_Click()
Sheet1.AddToOutlook
End Sub
12057