'Outlook calendar events using vba and excel
I have this Excel sheet which contains dates with a appointment as shown in this example:
See text below or screenshot:
28/06/2022 0
29/06/2022 0
30/06/2022 AD
1/07/2022 4,5UA
2/07/2022 Za
3/07/2022 Zo
4/07/2022 V
5/07/2022 V
The current code has been written by someone, and it helped me a lot current code.
When there is an appointment in column 2 it will make an appointment in outlook with the according date in column 1.
When there is "0", "Za" or "Zo" it skips it.
When there is already an appointment with the same name on that day, it won't make another one.
This works great!
There are only two flaws that I can't get to program out.
- When there is a "0" in column 2 and an appointment for that day called "V" it won't delete that appointment.
- When there is a "V" (or something else) in column 2 and an appointment for that day called "AD" (or something other than what is in de excel sheet) it won't delete that appointment.
My code:
Sub Add_Appointments_To_Outlook_Calendar()
'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
But it won't work, if someone could help me that would really mean a lot to me.
I'm not experienced in VBA but I'm trying my very best to make it work
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|
