PDA

View Full Version : Excel 2007 automate calendar appointment in Outlook shared calender



ChrisNW
07-03-2012, 10:28 AM
Hi
I am using Excel 2007 and am trying to use VBA in Excel to create calendar appointments in a shared Outlook calendar. I can get my code to work so that it creates appointments in my personal calendar but no matter what I do I can't get it to create in the shared calendar.

The code I have follows and there are a number of items that are rem'd out as I have tested various options; if anyone can wade through the mire and tell me where I've gone wrong I'd be eternally grateful

Thanks and all
Chris

Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
' Dim objNS As Outlook.Namespace
' Dim objApp As Outlook.Application
' Dim colFolders As Outlook.Folders
' Dim objOutlook As Object
Dim objFolder As Outlook.MAPIFolder
Dim NS As Outlook.Namespace
' Dim arrFolders() As String
' Dim I As Long
Dim objNamespace As Object
Dim colItems As Outlook.Items
Dim olApptSearch As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String
Dim dStartTime As Date, dStartDate As Date
Dim dEndTime As Date, dEndDate As Date
Dim sSearch As String, bOLOpen As Boolean
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 objApp = Application
' Set objFolder = colFolders.Item(arrFolders(I))
' Set objNS = objApp.GetNamesspace("MAPI")
' Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items
' Set colItems = NS.GetDefaultFolder("\\Mailbox - RS-Finsy Admin\Calendar").Items
' Set objFolder = NS.GetFolderFromID("\\Mailbox - RS-Finsy Admin\Calendar")
' Set objFolder = objNamespace.GetDefaultFolder(9).Folders("Mailbox - Jason - Bowling Green").folders("Calendar")
' Set objFolder = objNamespace.GetDefaultFolder(18).Folders("PCMA Calendar")
Set objFolder = objNamespace.GetDefaultFolder("\\Mailbox - RS-Finsy Admin").Folders("Calendar")

For r = 9 To 6250
If Len(Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow
sSubject = Sheet1.Cells(r, 3).Value
sBody = Sheet1.Cells(r, 3).Value
dStartDate = Sheet1.Cells(r, 4).Value
dStartTime = Sheet1.Cells(r, 5).Value
dEndDate = Sheet1.Cells(r, 6).Value
dEndTime = Sheet1.Cells(r, 7).Value
' dDuration = 30
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olAppointmentItem)
' olAppt.Body = "Service Tag= " & sBody
' olAppt.Subject = "Warranty Expires for Server " & sSubject
olAppt.Body = sBody
olAppt.Subject = sSubject
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Start = dStartDate
olAppt.End = dEndDate
' olAppt.Duration = dDuration
olAppt.Close olSave
End If
NextRow:
Next r
If bOLOpen = False Then OL.Quit
End Sub

todd_mcnoodl
01-15-2013, 02:21 PM
I am trying this from Access to Outlook similar results. Think workaround... Use excel to create an email to all your group. Then use outlook rules to run a script on the excel generated email that will have a completely unique subject that remains the same to adhere to the rule so when it is received the script adds it to the calendar. Deploy the rule for each end user.