Dears,
Kindly please i have a VBA code related to outlook appointment for more than one person, but when active VBA the appointments sent to me, but not for mentioned mails, so i want to sent each appointment to it's mail
Kindly please i have a VBA code related to outlook appointment for more than one person, but when active VBA the appointments sent to me, but not for mentioned mails, so i want to sent each appointment to it's mail
Code:
Option Explicit
' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
DeleteTestAppointments ' deletes previous test appointments
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 3 ' first row with appointment data in the active worksheet
While Len(Cells(r, 1).Formula) > 0
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Start = Now
.End = Now
.Subject = ""
.Location = ""
.Body = Cells(r, 6).Value
.ReminderSet = True
' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(r, 1).Value + Cells(r, 7).Value
.Start = Cells(r, 3).Value + Cells(r, 7).Value
.Start = Cells(r, 5).Value + Cells(r, 7).Value
.End = Cells(r, 2).Value + Cells(r, 7).Value
.End = Cells(r, 4).Value + Cells(r, 7).Value
.End = Cells(r, 6).Value + Cells(r, 7).Value
.To = Cells(r, 8).Value
.Subject = Sheets("Brief").Range("A1")
.Location = Sheets("Brief").Range("A1")
.Body = Sheets("Brief").Range("A1")
.ReminderSet = Cells(r, 9).Value
' .Categories = "TestAppointment" ' add this to be able to delete the testappointments
.ReminderSet = True
.ReminderMinutesBeforeStart = 0
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub
Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
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)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
OLF.Items(r).Delete
dCount = dCount + 1
End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub
Last edited by a moderator:
