Check if appointment exists ( by subject ) in Outlook from Excel VBA

B

Bart

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
 
B

Bart

An example of what the excel looks like is available here :

http://members.home.nl/hoenb/

Many thanks in advance for any help !
Bart


Bart schreef:
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[/QUOTE]
Click to expand...
 
K

Ken Slovak - [MVP - Outlook]

You can get the Items collection for the default Calendar folder using
NameSpace.GetDefaultFolder(olFolderCalendar) and then getting the Items
collection for that folder. Once you have that you can filter or restrict
the Items collection based on Subject.

See the Help for Items.Restrict, it has some sample code showing how to
restrict the original Items collection to a filtered Items collection that
will only have items with that subject. Alternatively you can set the filter
string and use Find and FindNext to iterate the original Items collection
using the filter.




Bart said:
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
[/QUOTE]
Click to expand...
 
K

Keith

Bart-

I use Excel to pull all appointments to figure out which ones have the word
"Vacation" in the title to bring a vacation schedule into Excel. You can
adapt the following and just use a variable for the subject... just ignore
all the stuff related to my excel sheets and start paying attention at the
line that says 'for late binding. I left the rest in case there were any
critical array declarations or anything that you might need to see to
understand the rest of the code. I think the three key lines are:
For Each olApt In olFldr.Items
If TypeName(olApt) = "AppointmentItem" Then
If InStr(1, olApt.Subject, "Vacation", vbTextCompare) > 0 Then
etc....

Public Sub Synch_Vacation_Time()

Dim oWrkSht As Worksheet
Dim ApptArray(1 To 12, 1 To 3, 1 To 25) 'holds appt data
Dim LocArray(1 To 12) 'Counting array for how many appts per month
Dim UseRef As Variant '() As Worksheets 'holds worksheet names
Dim CheckArray As Variant '() As String 'holds all possible UserIDs
Dim MAdjArray As Variant '() 'offsets number of days to start of month

Dim okArray As Variant
Dim RefArray As Variant
Dim SetMonthlyOffsets As Variant
Dim sUsername As String

Dim i As Integer
Dim p As Integer
Dim UserRow As Integer

CheckArray = Array(<snip>)

UseRef = Array(Sheet1, Sheet2, Sheet3, Sheet4, _
Sheet5, Sheet6, Sheet7, Sheet8, _
Sheet9, Sheet10, Sheet11, Sheet12, _
Sheet13, Sheet14, Sheet15, Sheet16, _
Sheet17, Sheet18, Sheet19, Sheet20, _
Sheet21, Sheet22, Sheet23)

MAdjArray = Array(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6) '2007 calendar offset

i = 1
p = 1
UserRow = 1

'***** Set counting array so that each month starts with no entries *****

For MyReset = 1 To 12
LocArray(MyReset) = 1
Next

'***** Find the sheet assigned to the UserID *****

sUsername = Trim(GetThreadUserName())
FoundIt = False

For checkname = 1 To 22
If CheckArray(checkname) = sUsername Then
Set oWrkSht = UseRef(checkname)
FoundIt = True
Exit For
End If
Next

If FoundIt = True Then
If SocketsInitialize() Then
oWrkSht.Range("V1").Value = GetIPFromHostName(GetPcName)
End If
SocketsCleanup
End If

If FoundIt = False Then
MsgBox "Your UserID (" & sUsername & ") was not found in the names
list." & Chr(13) & _
"Please press the Print Screen (PrtSc) key in the
upper right part of your keyboard, then paste from the clipboard into an
email to Keith so he can update the list to include your UserID.", , "UserID
not found"
Exit Sub
End If

'***** Clear any existing records *****
<snip>



'for late binding:
Dim olApp As Object
Dim olNs As Object
Const olFldrCalendar As Long = 9
Dim olApt As Object

Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFldrCalendar)
'Set olApt = olFldr.Items

'***** Pull all outlook data into an array *****
For Each olApt In olFldr.Items
If TypeName(olApt) = "AppointmentItem" Then
If InStr(1, olApt.Subject, "Vacation", vbTextCompare) > 0 Then
If Year(olApt.Start) = 2007 Then
MyDur = olApt.Duration / 60
If MyDur > 24 Then MsgBox "A 'Vacation' entry of more than
one day was detected. This workbook can only detect non-repeating,
single-day vacation entries", , "Error: Source data problem"
If MyDur > 8 Then MyDur = 8

' UseRow = Format(olApt.Start, "mm")
eachmonth = Val(Format(olApt.Start, "mm"))
ThisDay = Val(Format(olApt.Start, "dd"))
'LastDay = Val(Format(olApt.End, "dd"))


'Gives starting row position
PasteMonthStartRow = 16 * ((eachmonth - 1) \ 3) + 17

'gives 1, 2, or 3 for the column grouping
PasteMonthStartColumn = (eachmonth Mod 3)
If PasteMonthStartColumn = 0 Then PasteMonthStartColumn = 3
'Gives the number of the actual start column
PasteMonthStartColumn = ((PasteMonthStartColumn - 1) * 7) +
1

OffsetX = (((MAdjArray(eachmonth)) + (ThisDay - 1)) \ 7) * 2
OffsetY = ((MAdjArray(eachmonth)) + (ThisDay - 1)) Mod 7

PasteMonthRow = PasteMonthStartRow + OffsetX
PasteMonthColumn = Trim(Chr((PasteMonthStartColumn +
OffsetY) + 64))

With oWrkSht
.Activate
.Range(PasteMonthColumn & PasteMonthRow).Select
Selection.Value = MyDur
Selection.AddComment (olApt.Subject)
End With

End If
End If
End If
Next olApt

Set olApt = Nothing
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Bart said:
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
[/QUOTE]
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Working outlook via vba code with xlsx - error 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0
VBA - exporting serial letters to single documents 0
Copy Outlook email body to Excel 1
Prompt For Replace in Selection And More... 0
type mismatch error in macro in excel 0
check if value exists in pivot table 0

Top