I am trying to upload a list of due dates to my outlook calendar without any duplicates being uploaded from the file.
This is the function i'm using to check if the event is in the Calendar
This is my macro to upload my excel file to my calendar. The problem is it will still upload two duplicate entries in my test file.
I'm not sure why.
Can someone assist me?
Code:
Public Function CheckAppointment(ByVal argCheckDate As Date, ByVal argSubject As Stringb, ByVal argbody As String) As Boolean Dim oApp As Outlook.Application
Dim oNameSpace As Outlook.Namespace
Dim oApptItem As Outlook.AppointmentItem
Dim oFolder As Outlook.MAPIFolder
Dim oMeetingoApptItem As Outlook.MeetingItem
Dim oObject As Object
Dim dtCheck As Date
Dim sbCheck As String
Dim bdcheck As String
On Error Resume Next
' check if Outlook is running
Set oApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
Set oApp = CreateObject("Outlook.Application")
End If
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
'check "test calendar for event
CheckAppointment = False
For Each oObject In oFolder.Items
If oObject.Class = olAppointment Then
Set oApptItem = oObject
If oApptItem.Start = argCheckDate And oApptItem.Subject = argSubject And oApptItem.Body = argbody Then
CheckAppointment = True
End If
End If
Next oObject
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End FunctionThis is the function i'm using to check if the event is in the Calendar
Code:
Public Sub Uploadduedates()
ActiveSheet.Select
On Error GoTo Err_Execute
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim arrCal As String
Dim X As Long
On Error Resume Next
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
X = 2
dtCheck = Cells(X, 4).Value
sbCheck = Cells(X, 2).Value
bdcheck = Cells(X, 3).Value
Do Until Trim(Cells(X, 1).Value) = ""
If CheckAppointment(dtCheck, sbCheck) = False Then
arrCal = Cells(X, 1).Value
Set subFolder = CalFolder.Folders(arrCal)
Set olAppt = subFolder.Items.Add(olAppointmentItem)
With olAppt
.Start = Cells(X, 4) + Cells(X, 5)
.End = Cells(X, 6) + Cells(X, 7)
.Subject = Cells(X, 2)
.Body = Cells(X, 3)
.ReminderMinutesBeforeStart = Cells(X, 8) 'set reminder in mins 60 x 24 * [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=of]#of[/URL] days
.ReminderSet = True
.Save
End With
End If
X = X + 1
Loop
MsgBox ("Your Calender(s) have been updated")
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox ("An error occurred - Exporting items to Calendar.")
End SubThis is my macro to upload my excel file to my calendar. The problem is it will still upload two duplicate entries in my test file.
I'm not sure why.
Can someone assist me?
