Good Morning All,
I'm trying to make a macro that links an excel list of meetings with an outlook calendar.
I have created a macro so far that is able to create the entries and check to see if the entry exists by a specific date (which doesn't allow for any flexibility).
I now need to make it so it checks by subject line and date/time (which vary on each row in the spreadsheet), and if the item exists, update all the values for the meeting (time/place/body etc.) and if that subject line doesn't exist, then create a new calendar item.
Please see my code below (the red part is where I need to update I think).
If you're able to assist with making this so it checks each calendar event by subject and updates all events accordingly, that'd be greatly appreciated.
Kind Regards,
S
I'm trying to make a macro that links an excel list of meetings with an outlook calendar.
I have created a macro so far that is able to create the entries and check to see if the entry exists by a specific date (which doesn't allow for any flexibility).
I now need to make it so it checks by subject line and date/time (which vary on each row in the spreadsheet), and if the item exists, update all the values for the meeting (time/place/body etc.) and if that subject line doesn't exist, then create a new calendar item.
Please see my code below (the red part is where I need to update I think).
Code:
[COLOR=#ff0000]Sub Button1_Click()[/COLOR]
[COLOR=#ff0000] MsgBox (CheckAppointment("1/02/2015, 09:00:00AM")))[/COLOR]
[COLOR=#ff0000]End Sub[/COLOR]
Public Function CheckAppointment(ByVal argCheckDate As Date) 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
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)
CheckAppointment = False
For Each oObject In oFolder.Items
If oObject.Class = olAppointment Then
Set oApptItem = oObject
If oApptItem.Start = argCheckDate 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 Function
Sub CreateAppointment()
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.AppointmentItem
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Set myOlApp = GetObject(, "Outlook.Application")
Set ws = Sheets("Sheet1") 'Edit to your worksheet name
With ws
lastRow = .Cells(1, "A").End(xlUp).Row + 1 'Last row of data
End With
For i = 2 To lastRow 'Starting at 2 assumes column headers on row 1
'The following line adds one appointment item for each loop
Set myItem = myOlApp.CreateItem(olAppointmentItem)
With myItem
.Subject = ws.Cells(i, "A")
.Location = ws.Cells(i, "B")
.Body = ws.Cells(i, "C")
.Start = ws.Cells(i, "D") + ws.Cells(i, "E")
.End = ws.Cells(i, "F") + ws.Cells(i, "G")
.Save
End With
Next i
End SubIf you're able to assist with making this so it checks each calendar event by subject and updates all events accordingly, that'd be greatly appreciated.
Kind Regards,
S
