Hello all,
This is my first time posting on this forum but i've been spending days on end trying to finish up a program for my office. In it's current state it works fine except for teh fact that i can't get it to add new appointments onto a shared calendar. This is my code i have:
the calendar that i'm trying to attach this to is located on another person's mailbox. Here is the calendars location info: Mailbox - Sale Manager. and the calendar is called "Bid Schedule".
Please someone help me with this.
This is my first time posting on this forum but i've been spending days on end trying to finish up a program for my office. In it's current state it works fine except for teh fact that i can't get it to add new appointments onto a shared calendar. This is my code i have:
Code:
Option Explicit
Sub AddToOutlook()
Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim oFolder As Outlook.Folder
Dim oRecipient As Outlook.Recipient
Dim r As Long, i As Long, sSubject As String, sBody As String, sLocation As String
Dim BID As String
Dim dStartTime As Date, dEndTime As Date
Dim bOLOpen As Boolean
'Checks to see if Outlook is open and either open and closes it or leaves it open
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
'Updates Outlook Calendar
r = Range("B" & Rows.Count).End(xlUp).Row
For i = 16 To r
If Range("C" & i).Value = "" Then
Range("C" & i).Value = Range("D" & i).Value
End If
If Range("B" & i).Value <> " " Then
sSubject = Range("A" & i).Value & " " & ":" & " " & Range("G" & i).Value
sLocation = Range("H16").Value
If Range("E" & i).Value = "" Then
dStartTime = Range("D" & i).Value + #5:00:00 PM#
dEndTime = Range("D" & i).Value + #5:00:00 PM#
ElseIf Range("E" & i).Value = "EOD" Then
dStartTime = Range("D" & i).Value + #5:00:00 PM#
dEndTime = Range("D" & i).Value + #5:00:00 PM#
Else
dStartTime = Range("D" & i).Value + Range("E" & i).Value
dEndTime = Range("D" & i).Value + Range("E" & i).Value
End If
If Range("B" & i).Value = "U" Then
BID = Range("A" & i).Value
DeleteOldBidEntry (BID)
End If
Set olAppt = OL.CreateItem(olAppointmentItem)
olAppt.Subject = sSubject
olAppt.Location = sLocation
olAppt.Start = dStartTime
olAppt.End = dEndTime
olAppt.Categories = "BID"
olAppt.ReminderSet = True
olAppt.MeetingStatus = olMeeting
'olAppt.RequiredAttendees = "louis@kernsteel.com"
olAppt.Send
olAppt.Close olSave
If bOLOpen = False Then OL.Quit
Range("B" & i).Value = " "
End If
Next i
End Sub
Sub DeleteOldBidEntry(BID As String)
Dim olapp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim olItm As Outlook.AppointmentItem
On Error Resume Next
Set olapp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olapp Is Nothing Then
On Error Resume Next
Set olapp = GetObject("Outlook.Application")
On Error GoTo 0
If olapp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set OLF = olapp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
'Find calendar event by subject
Set olItm = OLF.Items.Find("[Subject] = '" & sSubject & "'")
If Not TypeName(olItm) = "Nothing" Then
olItm.Delete
MsgBox "Bid item: " & vbLf & vbLf & sSubject, , "Calendar Event Deleted"
Else
MsgBox "Cannot find calendar item: " & vbLf & vbLf & sSubject, , "Calendar Event Not Found"
End If
Set olapp = Nothing
Set OLF = Nothing
End SubPlease someone help me with this.