Excel Vba Update, Create and Delete Appointments

[Biz]

Dear All,

I am trying to create a vba to add appointments to Outlook 2010, update appointments if it changes, and delete appointments.

Pls click on link below.

http://www.megaupload.com/?d=VU7NPM70

Your help would be gr8ly appreciated.

Biz

 

[Ruddles]

Sorry, in common with many organisations, filesharing sites are blocked by the corporate firewall.

However here's a simple skeleton of the coding you'd need to create a calendar entry. Paste into a new general code module and add a reference to the Microsoft Outlook Object Library (Tools > References... in the VBA editor). Change the bit in red so it points to an actual WAV file.

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Public Sub CreateAppointment()[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  Dim oApp As Outlook.Application
  Dim oNameSpace As Namespace
  Dim oItem As AppointmentItem
      
  On Error Resume Next
  [COLOR=green]' check if Outlook is running
[/COLOR]  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    [COLOR=green]'if not running, start it
[/COLOR]    Set oApp = CreateObject("Outlook.Application")
  End If
  
  Set oNameSpace = oApp.GetNamespace("MAPI")
  
  Set oItem = oApp.CreateItem(olAppointmentItem)
  
  With oItem
  
    .Subject = "This is the subject"
    .Start = "31/05/2011 11:45"
    .Duration = "01:00"
    
    .AllDayEvent = False
    .Importance = olImportanceNormal
    .Location = "Room 101"
    
    .ReminderSet = True
    .ReminderMinutesBeforeStart = "10"
    .ReminderPlaySound = True
    .ReminderSoundFile = "[COLOR=red]C:\Windows\Media\Ding.wav[/COLOR]"
    
    Select Case 1 [COLOR=green]' do you want to display the entry first or save it immediately?
[/COLOR]      Case 1
        .Display
      Case 2
        .Save
    End Select
  
  End With
    
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oItem = Nothing[/FONT]
[FONT=Fixedsys]     
End Sub[/FONT]

 

[Ruddles]

Hmm... on second thoughts I think:-

[FONT=Fixedsys]    .Duration = [COLOR=red]60[/COLOR][/FONT]

 

[Biz]

Hi Ruddles,

The code provided is only creating appointments. I wanted first to check if appointment exists if so then it amendment appointment. If not available then create appointment.

Delete appointments based visible cells.

Biz

 

[Ruddles]

As far as I'm aware, to find out whether an appointment exists you have to cycle through all of the appointments in the calendar checking whether each one 'looks like' the one you're looking for.

The following function take a date and time passed to it and returns True if an appointment exists for that date at that time, regardless of any other conditions:-

Option Explicit
 
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

To test it, the following code might be useful to you. Change the date and time to match an appointment you know you have in your calendar and Call Driver: it should confirm that the appointment exists. Now enter a date and time when you know you don't have an appointment and Call Driver again: it should say "not found".

Option Explicit
 
Public Sub Driver()
 
  Dim dtCheck As Date
  
  dtCheck = DateValue("[COLOR=red][B]23/05/2011[/B][/COLOR]") + TimeValue("[COLOR=red][B]09:00:00[/B][/COLOR]")
  If CheckAppointment(dtCheck) Then
    MsgBox "Appointment found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbInformation
  Else
    MsgBox "Appointment not found at " & Format(dtCheck, "dd/mm/yyyy hh:nn:ss"), vbOKOnly + vbExclamation
  End If
  
End Sub

 

[Ruddles]

Obviously you'll have to adapt this code to suit your purpose - for example, you may need to check the subject of the appointment or even the contents of its body as well as the date and time in order to be sure it's the one you're actually looking for.

If that's the case, you'd probably add some extra arguments to the function definition - for example, to pass some or all of the subject to it or one or more words to search the body for - and then instead of just checking If oApptItem.Start = argCheckDate, you'd check the subject, body, or whatever for the additional argument.

 

[Ruddles]

Delete appointments based visible cells.

Sorry, I don't know what this means.

 

[Biz]

Hi Ruddles,

Thanks for code I will try it let you know how it goes.
Delete appointments based visible cells would be helpful. For instance, if I a wanted to delete any appointments I can use autofilter to display appointments that I want to delete and then vba connects to Outlook and deletes these appointments.

Biz

 

[walice]

Hi Ruddles

Your code has been immensely helpful. I tried to adapt it to check for the subject of the appointment, as you suggested. I added an extra argument to the function, and then checked for the subject, but it doesn't work.

Code below. Oddly, it works fine when I create another Public Function as Boolean which checks only for the subject (CheckSubject), or when I modify the 2-argument CheckAppointment function by having an if Date OR Subject condition (as opposed to if Date AND Subject). This doesn't really help me check for existing Outlook appointments with unique start dates and subjects.

Any ideas would be warmly appreciated!

Public Function CheckAppointment(ByVal argCheckDate As Date[COLOR=#ff0000], ByVal argSubject As String[/COLOR]) 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 [COLOR=#ff0000]& oApptItem.Subject = argSubject[/COLOR] 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

When I call on Driver to check for the test appointment, it does not find it (but, as mentioned above, having an OR rather than IF condition in the function would find an appointment with the subject "hello", even if it was at a different time than specified by the Date argument, which is not what I'm after).

Public Sub Driver() 
  Dim dtCheck As Date
  Dim sbCheck As String
  
    dtCheck = DateValue("05/09/13") + TimeValue("09:00:00")
    sbCheck = "hello"


  If CheckAppointment(dtCheck, sbCheck) Then
    MsgBox "Appointment found", vbOKOnly + vbInformation
  Else
    MsgBox "Appointment not found", vbOKOnly + vbExclamation
  End If
  
End Sub

Many thanks in advance for any help you can provide!

Obviously you'll have to adapt this code to suit your purpose - for example, you may need to check the subject of the appointment or even the contents of its body as well as the date and time in order to be sure it's the one you're actually looking for.

If that's the case, you'd probably add some extra arguments to the function definition - for example, to pass some or all of the subject to it or one or more words to search the body for - and then instead of just checking If oApptItem.Start = argCheckDate, you'd check the subject, body, or whatever for the additional argument.

 

[Ruddles]

      If oApptItem.Start = argCheckDate AND oApptItem.Subject = argSubject Then