[Outlook] appointments using [Excel]

T0m-c
NewLounger
Posts: 5
Joined: 23 May 2022, 14:59

[Outlook] appointments using [Excel]

Post by T0m-c »

I have a excel sheet wich include dates with an according appointment. The script makes appointments according to the name of the corresponding cell
Example:
A22 = 21/01/2022
B22 = GT
It will make an appointment called "GT" on that date
But it won't make an appointment if there is "0", "Za" or "Zo" (wich is good!).

The current scenario
Now i currently have 2 macro's
1 to delete all appointments with the names in column B
1 to add appointments with the names in column B
Why? Because when an appointment name has changed, it needs to delete the old appointment and make a new one, with the new name.
The ideal scenario is to lookup if there is an appointment in that day matching the corresponding cell, and if there isn't, VBA will delete the appointment (if it matches with a certain criteria) and make a new one with the name in the cell. (Why the criteria? Because it can't delete every appointment in that day. So if the appointment is called "GT" or "A" or, ... it can delete it. If there is an apointment in that day that matched with the cell, it does nothing)
All in one script, 2 scripts to run separately is not convinient
The Problem
Now it will delete every appointment, and make every appointment again, even if the appointment is allready correct.
can someone help me with this?
Code add appointment

Code: Select all

Sub Add_Appointments()
    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oApp     As Outlook.Application
    Dim oAppt    As Outlook.AppointmentItem
    Dim oNS      As Outlook.Namespace
    Dim oFolder  As Outlook.MAPIFolder
    Dim sSubj    As String
    Dim lCount   As Long
    Dim oRge     As Range
    Dim oCell    As Range
    Dim DeleteCount  As Long
                                                  
    
       
    lCount = 0
    Set oApp = Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderCalendar)

    Set oRge = ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion ' Grab whole range
    Set oRge = oRge.Resize(oRge.Rows.Count - 1, 1).Offset(1)    ' Skip first row and keep only first column to run through.
    For Each oCell In oRge
        sSubj = oCell.Offset(0, 1).Value
        If sSubj <> "" And sSubj <> "0" And sSubj <> "Za" And sSubj <> "Zo" Then
            Set oAppt = oFindAppointment(oFolder, sSubj, oCell.Value, , True)
            If oAppt Is Nothing Then
                ' Appointment did not already exist
                Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
                oAppt.BusyStatus = 3
                oAppt.Subject = sSubj
                oAppt.Start = oCell.Value
                oAppt.ReminderMinutesBeforeStart = 60
                oAppt.AllDayEvent = True
                oAppt.Save
                lCount = lCount + 1
            End If
         End If
        
    Next
    MsgBox CStr(lCount) & " Reminder(s) Added To Outlook Calendar"

    
End Sub

Function oFindAppointment(oFolder As Outlook.MAPIFolder, sSubj As String, dStarDateTime As Date, Optional sBodyText As String = "", Optional bAllDayEvent As Boolean = False) As Outlook.AppointmentItem
  
    Dim oCalItems As Outlook.Items
    Dim oCalItem  As Object
    Dim sFilter   As String

    Set oFindAppointment = Nothing
    ' Get calendar items with the specified subject and start time
    sFilter = "[Subject] = '" & sSubj & "' and [Start] = '" & Format(dStarDateTime, "ddddd Hh:Nn") & "'"
    Set oCalItems = oFolder.Items.Restrict(sFilter)

    ' See if any calendar items match the specified body text and/or AllDayEvent requirement
    For Each oCalItem In oCalItems
        If sBodyText = "" Then
            Set oFindAppointment = oCalItem
        ElseIf InStr(1, oCalItem.Body, sBodyText, vbTextCompare) > 0 Then
            Set oFindAppointment = oCalItem
        End If
        If Not oFindAppointment Is Nothing Then
            If bAllDayEvent = oFindAppointment.AllDayEvent Then
                Exit For
            End If
            Set oFindAppointment = Nothing 'No match, keep looking
        End If
    Next
End Function
Code Delete Appointment

Sub Delete_Appointments()

 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 iUserReply           As VbMsgBoxResult
 Dim sErrorMessage        As String
 Dim j                    As Integer
 Dim i                    As Integer
 

 Set oApp = Outlook.Application
 Set oNameSpace = oApp.GetNamespace("MAPI")
 Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
 
On Error Resume Next
 For Each oObject In oFolder.Items
   If oObject.Class = olAppointment Then
     Set oApptItem = oObject
     For j = 2 To Range("B1").End(xlDown).Row
     If InStr(oApptItem.Subject, Range("B" & j).Value) > 0 Then
     
            oApptItem.Delete
            
     End If
     Next j
     
   End If
 Next oObject


For i = 2 To Range("B1").End(xlDown).Row
    strFind = "[Subject] ='" & Range("B" & i).Value & "'"
    
    Set oApptItem = oFolder.Items.Find(strFind)
    
    If Not TypeName(oApptItem) = "Nothing" Then
        oApptItem.Delete
    End If
    
    
Next i



 
 Set oApp = Nothing
 Set oNameSpace = Nothing
 Set oApptItem = Nothing
 Set oFolder = Nothing
 Set oObject = Nothing
 
 Exit Sub
 

End Sub
Last edited by Leif on 23 May 2022, 15:34, edited 1 time in total.
Reason: To add [code] tags for readability

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: [Outlook] appointments using [Excel]

Post by HansV »

Welcome to Eileen's Lounge!

See if this works for you:

Code: Select all

Sub AddRemove_Appointments()
    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oApp     As Outlook.Application
    Dim oAppt    As Outlook.AppointmentItem
    Dim oNS      As Outlook.Namespace
    Dim oFolder  As Outlook.MAPIFolder
    Dim oObject  As Object
    Dim sSubj    As String
    Dim lCount   As Long
    Dim oRge     As Range
    Dim oCell    As Range
    Dim lDelCnt  As Long

    Set oApp = CreateObject(Class:="Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderCalendar)

    Set oRge = ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion ' Grab whole range
    Set oRge = oRge.Resize(oRge.Rows.Count - 1, 1).Offset(1)    ' Skip first row and keep only first column to run through.

    ' Step 1 - Delete all appointments that don't have a match in column B
    For Each oObject In oFolder.Items
        If oObject.Class = olAppointment Then
            Set oAppt = oObject
            sSubj = oAppt.Subject
            If oRge.Offset(0, 1).Find(What:=sSubj, LookAt:=xlWhole) Is Nothing Then
                oAppt.Delete
                lDelCnt = lDelCnt + 1
            End If
        End If
    Next oObject
    MsgBox lDelCnt & " Reminder(s) Removed From Outlook Calendar"

    ' Step 2 - Add new appointments
    For Each oCell In oRge
        sSubj = oCell.Offset(0, 1).Value
        If sSubj <> "" And sSubj <> "0" And sSubj <> "Za" And sSubj <> "Zo" Then
            Set oAppt = oFindAppointment(oFolder, sSubj, oCell.Value, , True)
            If oAppt Is Nothing Then
                ' Appointment did not already exist
                Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
                oAppt.BusyStatus = 3
                oAppt.Subject = sSubj
                oAppt.Start = oCell.Value
                oAppt.ReminderMinutesBeforeStart = 60
                oAppt.AllDayEvent = True
                oAppt.Save
                lCount = lCount + 1
            End If
         End If
    Next oCell
    MsgBox lCount & " Reminder(s) Added To Outlook Calendar"
End Sub

Function oFindAppointment(oFolder As Outlook.MAPIFolder, sSubj As String, dStarDateTime As Date, Optional sBodyText As String = "", Optional bAllDayEvent As Boolean = False) As Outlook.AppointmentItem
    Dim oCalItems As Outlook.Items
    Dim oCalItem  As Object
    Dim sFilter   As String

    Set oFindAppointment = Nothing
    ' Get calendar items with the specified subject and start time
    sFilter = "[Subject] = '" & sSubj & "' and [Start] = '" & Format(dStarDateTime, "ddddd Hh:Nn") & "'"
    Set oCalItems = oFolder.Items.Restrict(sFilter)

    ' See if any calendar items match the specified body text and/or AllDayEvent requirement
    For Each oCalItem In oCalItems
        If InStr(1, oCalItem.Body, sBodyText, vbTextCompare) > 0 And oCalItem.AllDayEvent = bAllDayEvent Then
            Set oFindAppointment = oCalItem
            Exit For
        End If
    Next
End Function
Best wishes,
Hans

T0m-c
NewLounger
Posts: 5
Joined: 23 May 2022, 14:59

Re: [Outlook] appointments using [Excel]

Post by T0m-c »

Hans, Thanks for the quick response!
If an appointment has changed and i run the script again it won't delete the old appointment and make a new one. Also it re-adds all the other appointments

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: [Outlook] appointments using [Excel]

Post by HansV »

Is thios better?

Code: Select all

Sub AddRemove_Appointments()
    'Include Microsoft Outlook nn.nn Object Library from Tools -> References
    Dim oApp     As Outlook.Application
    Dim oAppt    As Outlook.AppointmentItem
    Dim oNS      As Outlook.Namespace
    Dim oFolder  As Outlook.MAPIFolder
    Dim oObject  As Object
    Dim dDate    As Date
    Dim sSubj    As String
    Dim lCount   As Long
    Dim oRge     As Range
    Dim oCell    As Range
    Dim lDelCnt  As Long

    Set oApp = CreateObject(Class:="Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderCalendar)

    Set oRge = ThisWorkbook.Sheets(1).Cells(1, 1).CurrentRegion ' Grab whole range
    Set oRge = oRge.Resize(oRge.Rows.Count - 1, 1).Offset(1)    ' Skip first row and keep only first column to run through.

    ' Step 1 - Delete all appointments that don't have a match in column B
    For Each oObject In oFolder.Items
        If oObject.Class = olAppointment Then
            Set oAppt = oObject
            sSubj = oAppt.Subject
            If oRge.Offset(0, 1).Find(What:=sSubj, LookAt:=xlWhole) Is Nothing Then
                oAppt.Delete
                lDelCnt = lDelCnt + 1
            End If
        End If
    Next oObject
    MsgBox lDelCnt & " Reminder(s) Removed From Outlook Calendar"

    ' Step 2 - Add new appointments
    For Each oCell In oRge
        dDate = oCell.Value
        sSubj = oCell.Offset(0, 1).Value
        If sSubj <> "" And sSubj <> "0" And sSubj <> "Za" And sSubj <> "Zo" Then
            Set oAppt = oFindAppointment(oFolder, sSubj, dDate, , True)
            If oAppt Is Nothing Then
                ' Appointment did not already exist
                Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
                oAppt.BusyStatus = 3
                oAppt.Subject = sSubj
                oAppt.Start = oCell.Value
                oAppt.ReminderMinutesBeforeStart = 60
                oAppt.AllDayEvent = True
                oAppt.Save
                lCount = lCount + 1
            End If
         End If
    Next oCell
    MsgBox lCount & " Reminder(s) Added To Outlook Calendar"
End Sub

Function oFindAppointment(oFolder As Outlook.MAPIFolder, sSubj As String, dStarDateTime As Date, Optional sBodyText As String = "", Optional bAllDayEvent As Boolean = False) As Outlook.AppointmentItem
    Dim oCalItems As Outlook.Items
    Dim oCalItem  As Object
    Dim sFilter   As String

    Set oFindAppointment = Nothing
    ' Get calendar items with the specified subject and start time
    sFilter = "[Subject] = '" & sSubj & "' and [Start] = '" & Format(dStarDateTime, "ddddd Hh:Nn") & "'"
    Set oCalItems = oFolder.Items.Restrict(sFilter)

    ' See if any calendar items match the specified body text and/or AllDayEvent requirement
    For Each oCalItem In oCalItems
        If sBodyText = "" Then
            Set oFindAppointment = oCalItem
        ElseIf InStr(1, oCalItem.Body, sBodyText, vbTextCompare) > 0 Then
            Set oFindAppointment = oCalItem
        End If
        If Not oFindAppointment Is Nothing Then
            If bAllDayEvent = oFindAppointment.AllDayEvent Then
                Exit For
            End If
            Set oFindAppointment = Nothing 'No match, keep looking
        End If
    Next oCalItem
End Function
Best wishes,
Hans

T0m-c
NewLounger
Posts: 5
Joined: 23 May 2022, 14:59

Re: [Outlook] appointments using [Excel]

Post by T0m-c »

No still doesn't work.
If i change some appointments and delete some and then run the script again, it won't delete the old appointments in outlouk. When i change the name of some appointments it leaves the old appointment there and makes a new one

T0m-c
NewLounger
Posts: 5
Joined: 23 May 2022, 14:59

Re: [Outlook] appointments using [Excel]

Post by T0m-c »

This is what the script need to do (i've done it manually now)

Start situation
Situatie 1.jpg
And when i run the script again this needs to happen
04/07 and 05/07 has been deleted from excel, so it deletes it from outlook
11/07 and 12/07 has been renamed, so it needs to delete the old "V" and make a new one called "AD"
13/07 and 14/07 has been deleted from excel, so it deletes it from outlook
Situatie 2.jpg

If i do the same for the current script, it will do this
Situatie 3.jpg
I hope this makes the problem clear :thankyou:
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: [Outlook] appointments using [Excel]

Post by HansV »

I'm afraid you'll have to stick with your original code. I don't know how to correct my version, sorry.
Best wishes,
Hans

T0m-c
NewLounger
Posts: 5
Joined: 23 May 2022, 14:59

Re: [Outlook] appointments using [Excel]

Post by T0m-c »

Aww that's sad, my original code works, only it deletes everything, everytime wich is unnecessary and takes allot of time, i guess i'll this is the only way to keep it working

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: [Outlook] appointments using [Excel]

Post by HansV »

It worked correctly when I tried it, but I have no reason to doubt your experience... :sad:
Best wishes,
Hans