View Single Post
  #1  
Old January 18th 07, 12:55 PM posted to microsoft.public.outlook.program_vba
Bart
external usenet poster
 
Posts: 2
Default Check if appointment exists ( by subject ) in Outlook from Excel VBA

Hello there,

I am quite new to VBA and wrote a litte code to make an appointment in
outlook from excel, I added a CommandBarControl in excel so users only
have to right click a cell, choose the new 'Update Outlook' button and
it will then fetch all data from the row the cell is in to create the
appointment ( used with a container delivery status overview in excel
) with all delivery details etc. :

[code]

Private Sub Workbook_Open()
Dim NewControl As CommandBarControl
On Error Resume Next
Application.CommandBars("Cell").Controls("Update
Outlook").Delete
On Error GoTo 0
Set NewControl = Application.CommandBars("Cell").Controls.Add
With NewControl
.Caption = "Update Outlook"
.OnAction = "OutlookUpdate.Update"
.BeginGroup = True
End With
End Sub


Sub Update()
' Turn off screen updating
Application.ScreenUpdating = False

' Start Outlook
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

' Logon
Dim olNs As Outlook.NameSpace
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon

' Create a new appointment
Dim arrival As Date
arrival = ActiveWorkbook.Worksheets(1).Range("E" &
ActiveCell.Row).Value + ActiveWorkbook.Worksheets(1).Range("F" &
ActiveCell.Row).Value

Dim olAppt As Outlook.AppointmentItem
Set olAppt = olApp.CreateItem(olAppointmentItem)

' Check with user if selected row is correct
Msg = "Update GRN " & ActiveWorkbook.Worksheets(1).Range("A" &
ActiveCell.Row).Value & " ?"
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbNo Then Exit Sub

' Check if date is entered
If Trim(Range("E" & ActiveCell.Row).Value) = "" Then
MsgBox "Enter an arrival date !"
Exit Sub
End If

' Check if time is entered
If Trim(Range("F" & ActiveCell.Row).Value) = "" Then
MsgBox "Enter an arrival time !"
Exit Sub
End If

' Check if duration is entered
If Trim(Range("G" & ActiveCell.Row).Value) = "" Then
MsgBox "Enter a duration !"
Exit Sub
End If

' Setup appointment ...
With olAppt
.Start = arrival
.Duration = ActiveWorkbook.Worksheets(1).Range("G" &
ActiveCell.Row).Value
.Subject = ActiveWorkbook.Worksheets(1).Range("A" &
ActiveCell.Row).Value _
& " - " & ActiveWorkbook.Worksheets(1).Range("B" &
ActiveCell.Row).Value _
& " - " & ActiveWorkbook.Worksheets(1).Range("I" &
ActiveCell.Row).Value
.Body = "Container delivery from : " &
ActiveWorkbook.Worksheets(1).Range("B" & ActiveCell.Row).Value _
& vbCrLf & "GRN : " &
ActiveWorkbook.Worksheets(1).Range("A" & ActiveCell.Row).Value _
& vbCrLf & "Invoice : " &
ActiveWorkbook.Worksheets(1).Range("C" & ActiveCell.Row).Value _
& vbCrLf & "Date & Time of arrival : " &
ActiveWorkbook.Worksheets(1).Range("E" & ActiveCell.Row).Value +
ActiveWorkbook.Worksheets(1).Range("F" & ActiveCell.Row).Value _
& vbCrLf & "Cont. Nr. : " &
ActiveWorkbook.Worksheets(1).Range("I" & ActiveCell.Row).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 1480
End With

' Save Appointment...
olAppt.Save

' Turn screen updating back on
Application.ScreenUpdating = True

' Clean up...
' MsgBox "GRN " & ActiveWorkbook.Worksheets(1).Range("A" &
ActiveCell.Row).Value & " is synchronized with Outlook...",
vbMsgBoxSetForeground
olNs.Logoff
Set olNs = Nothing
Set olAppt = Nothing
Set olItem = Nothing
Set olApp = Nothing
End Sub

[ /code]

Now, this all works fine, but the problem is that dates are altered
when the status changes and that is why I want to build in a check if
the appointment is present, and if so, make sure it gets deleted and
then added again with the new data.

The subject of the appointment is a unique combination of different
fields, so I would like to use the subject to find a match and if
found, delete that match and then re-enter the new appointment.

I really don't know where or what to start with, so any help / tip is
welcome.

Many thanks in advance,
Bart

Ads