I have used calendar VBA code on this forum to add appointments to outlook, the problem is that I need to be able to update them. I know updating them is going to very hard, so instead of doing that, I thought I could delete all the appointments in the calendar and then add them all again?
I need to know the VBA code to delete all the appointments? Is there such a code? Could I run a macro in outlook to do it?
you can certainly delete appointments in Outlook from Access. i have been working with these lately. my code will find appointments based on a string and delete it. This can even be done if outlook is closed.
only thing is, i dont have with me at the minute but i will certainly post it when i get home. the routine checks the appointments.
if a matching appointment exists, a new one is not entered.
if nothing exists, a new one is entered.
if it exists, it can be deleted.
if it doesnt exist, it wont be deleted.
i also set mine for reccuring but its really down to what you need.
here is what i use for deleting appointments. in my code, i have a routine that adds the appointment. i use a variable named strAppSubject which i set in the public declarations. from there, the appointments are added, checked & deleted based on the subject so effectively if you have reccuring appointments, it will remove them all. Here is the code in sections -
This is the declarations part.
Code:
Option Compare Database
Option Explicit
'------------------------------------------------------
' This Access module needs references to:
'
' Microsoft Outlook [VersionNo] Object Library
' Microsoft CDO 1.21 Library
'
' To set references, in the VBA Editor, open the
' Tools menu and select References.
'------------------------------------------------------
Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.Namespace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem
'##CDO (COLLABORATION DATA OBJECTS) VARIABLES##
Public mobjCDOSession As MAPI.Session
Public mobjMAPIAppt As MAPI.Message
Public BolOutlookIS As Boolean
'##PUBLIC VARIABLES FOR SETTING & DELETING APPOINTMENTS##
Public intDateNote As Integer
Public strAppSubject As String
Public dteReccDate As Date
Public tmeSetTime As Date
Public strAppRecr As String
Public strAppLoc As String
Public strAppBody As String
Public intMinutes As Integer
Public strImportance As String
Public bolAllDay As Boolean
Public strBusyStats As String
Public dteStrt As Date
Public dteEnd As Date
Public strAppSubject As String
This is where the details are stored
Code:
Public Sub GetAppDetails()
'--------------------------------------------------------------
'####SET THESE DETAILS TO BE YOUR APPOINTMENT REQUIREMENTS####
'#############################################################
'--------------------------------------------------------------
'##SET THE MEETING LOCATION HERE##
strAppLoc = "Office"
'--------------------------------------------------------------
'##SET THE RECCURING PERIOD HERE##
'strAppRecr = olRecursDaily
'strAppRecr = olRecursWeekly
strAppRecr = olRecursMonthly
'strAppRecr = olRecursYearly
'--------------------------------------------------------------
'##SET IF YOU WANT AN ALL DAY APPOINTMENT##
bolAllDay = True
'bolAllDay = False
'--------------------------------------------------------------
'##SET THE START & FINISH DATES##
dteStrt = #19/05/2009#
dteEnd = #19/05/2009#
'--------------------------------------------------------------
'##SET THE AMOUNT OF MINUTES TO ALERT ON THIS APPOINTMENT##
intMinutes = "30"
'--------------------------------------------------------------
'##SET THE IMPORTANCE HERE##
'strImportance = olImportanceLow
'strImportance = olImportanceNormal
strImportance = olImportanceHigh
'--------------------------------------------------------------
'##SET THE BUSY STATUS HERE##
strBusyStats = olBusy
'strBusyStats = olFree
'strBusyStats = olOutOfOffice
'strBusyStats = olTentative
'--------------------------------------------------------------
'##SET THE APPOINTMENT SUBJECT##
strAppSubject = "Your Message Here!!!"
'--------------------------------------------------------------
'##SET THE BODY TEXT HERE## ( YOU CAN USE & VbCrlf & _ TO ADD NEW LINES
strAppBody = "Your first line of the message" & vbCrLf & _
"Your secong line" & vbCrLf & _
vbCrLf & _
"your third Line" & vbCrLf & _
"Your 4th Line" & vbCrLf & _
"Your 5th Line" & vbCrLf & _
"Your 6th Line" & vbCrLf & _
vbCrLf & _
"Your eighth Line" & vbCrLf & _
vbCrLf & _
"Your ninth Line"
'--------------------------------------------------------------
'####################################################
'--------------------------------------------------------------
End Sub
This code is called when you want to delete the subject
Code:
Public Sub ExampleCall_DeleteBySubject()
'Collect the details to find
GetAppDetails
'Call the Appointment details to find
Call DeleteAppointmentItemBySubject(strAppSubject)
End Sub
This finds and deletes the appointment based on the subject
Code:
Private Sub DeleteAppointmentItemBySubject(strAppSubject As String)
' Use this method ONLY if the subject of the
' Appointment Item is known and is UNIQUE.
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strAppSubject)
If Err.Number <> 0 Then GoTo CannotFindObject
mobjAPPT.Delete
MsgBox ("Success!! Your appointment has been deleted")
Bye:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
CannotFindObject:
MsgBox "Cannot find Appointment Item to delete.", _
vbOKOnly, "Information"
GoTo Bye
End Sub
This code adds the appointment
Code:
Public Sub AddAppClosedOutlk()
Dim outMail As Outlook.AppointmentItem
Dim strAppStrt As String
Dim strAppEnd As String
'get the user preferences
GetAppDetails
'set the outlook connection
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strAppSubject)
'check for appointment set. if it is, bail and go to bottom
If Err.Number = 0 Then GoTo FoundObject
'add the start & end time to the set date
strAppStrt = dteStrt
strAppEnd = dteEnd
'collect the user preferences and add to the appointment
Set outMail = Outlook.CreateItem(olAppointmentItem)
With outMail
.Subject = strAppSubject
.Location = strAppLoc
.Start = strAppStrt
.End = strAppEnd
.GetRecurrencePattern = strAppRecr
.Body = strAppBody
.Importance = strImportance
.AllDayEvent = bolAllDay
.ReminderMinutesBeforeStart = intMinutes
.Save
End With
'show message if appointment is created
MsgBox ("Success!! Your appointment has been placed")
Bye:
'close the connection
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
'arrive here if the appointment is already set
FoundObject:
MsgBox "Halt!! Appointment Already Placed!", _
vbOKOnly, "Information"
GoTo Bye
End Sub
im not entirely sure where i picked most of this from. if i remember, i will add the credits. This could be used in such a way that the variables are changed for either form objects or table data. then i guess you could set the data for the appointment change, run the delete code to remove the existing appointment then automatically collect the new data from the table and insert the new appointment in one go.
Thanks that's great? You don't know how to set a category do you? So we have 3 cottages and each category could be a cottage name, so they show up in different colours.
I will give the code I try tomorrow. Thanks a lot!
Ok, so I don't really need to find a appointment, for me, it would be easier to just delete them all and insert them again.
So could you covert your code to delete all the appoints?
Also, I asked this before, but do you have the code .Category or something like that for settings the category. Thanks
Here is my current code:
Code:
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Set db = CurrentDb
Set rs = db.OpenRecordset("tblcalendar")
Do Until rs.EOF
If rs("AddedToOutlook") = False Then
Set OutObj = CreateObject("outlook.application")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Start = rs("ApptDate")
.Duration = rs("ApptLength")
.subject = rs("Appt")
.Body = Nz(rs("ApptNotes"), "")
.Location = Nz(rs("ApptLocation"), "")
.Save
rs.Edit
rs("AddedToOutlook") = True
rs.Update
End With
Set OutObj = Nothing
Set OutAppt = Nothing
End If
rs.MoveNext
Loop
rs.close
Set db = Nothing
Set rs = Nothing
Ok, basicly its putting in the subject line as '[name] [start_date]' for the holiday. So if I change was made, I could set the 'addedtooutlook; to false and it would search for the subject line and replace it. But if the name or date is changed it wouldn't. Could I set the booking_ID in the subject line, say at the end, and it would search for that? As that will never change?
Can it search of it in the notes? As the booking_ID is every long and isn't needed in the subject line.
Thanks for responding so fast, and thanks for sending us the code. Have a nice day shopping.
Ok, so looking at the code, I need to change this:
Set mobjAPPT = mobjFLDR.Items (strAppSubject)
So mobjAPPT is the Appointment title (Or subect), so could i change this to 'APPTNotes' or something for it to search the notes? Then put the booking_ID in the start of the notes and use * wild card after so it doesn't search all the notes?
You set your category quite easily however, you cannot create one within the olAppointmentItem module. to set a category, simply place
Code:
.Category = "Your Category Here"
in the section of the code where everything is list in the "with" part of the appointment creation.
As far as your suggestion of the APPTNotes, i cant see a problem though i do prefer to keep things separate however, you could add the ID in the subject at the beginning and only search say the first 4 characters.
This is based on the user not altering the subject or notes.
you could have a look at the .GlobalAppointmentID and see if you can either set this to your desired ID as it is unavailable to the user or save it somewhere.
I'm sorry to say your too late the the category one, worked it out after and bit of trying.
The reason for putting the ID in the notes is that this is to be viewed on my dad blackberry, and its easier to see with less information in the subject, and my ID are random.
I will take a look at the code for deleting them, I will probs change all that I can and post it if it doesn't work, as some of the stuff it a bit complex to understand what the hell it does.
Thanks, I might just do that. I may look at it in morning but more likely on Thursday as its my day off from college (Although there will be some form of homework, usually is)
Ok, I firstly need to collect the information from the tables.
I currently have this code:
Code:
'Create DAO
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Set db = CurrentDb
Set rs = db.OpenRecordset("tblcalendar")
Do Until rs.EOF
If rs("AddedToOutlook") = "False" Then
Set OutObj = CreateObject("outlook.application")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Start = rs("ApptDate")
.End = rs("ApptEnd")
.AllDayEvent = False
.subject = rs("Appt")
.Body = Nz(rs("ApptNotes"), "")
.Location = Nz(rs("ApptLocation"), "")
.Categories = rs("ApptCat")
.BusyStatus = Free
.Save
rs.Edit
rs("AddedToOutlook") = "True"
rs.Update
End With
Set OutObj = Nothing
Set OutAppt = Nothing
End If
rs.MoveNext
Loop
rs.close
Set db = Nothing
Set rs = Nothing
I am currently gathering information from a table that was made by a 'make table query'. I need to get information from both 'tblcustomer' and 'tblbooking'
tblcustomer 1 = Many tblbooking
The appointment is for the bookings, so the 'AddedToOutlook' will be in that table. Can you open another rs within the other? As you need the first rs for the If and then to repeat it for every record.
Then I somehow need to get it to check if the appiontment is allready in, your code is for that, it will search start of the ApptNotes for the bookingid, you can then just use and wild cart right to not search all the notes.
Can you at all put a sample table in that has the same fields as the one you are using? Saves me having to create one and it ensures everything is right. You can save the table as new and exclude the data. Import it into a new db, zip it and post it.
I'm a newbie in VBA. I needed a code that search the Outlook Appointment based on the Mileage field (We used the Mileage field to store a unique appointment ID) and then do a delete. The code that you posted is almost what I needed except that instead of searching by Subject field, I need to search by the Mileage field. I tried modifying your code without any luck. Could you possibly help me please? Thank you in Advance.
here is what i use for deleting appointments. in my code, i have a routine that adds the appointment. i use a variable named strAppSubject which i set in the public declarations. from there, the appointments are added, checked & deleted based on the subject so effectively if you have reccuring appointments, it will remove them all. Here is the code in sections -
This is the declarations part.
Code:
Option Compare Database
Option Explicit
'------------------------------------------------------
' This Access module needs references to:
'
' Microsoft Outlook [VersionNo] Object Library
' Microsoft CDO 1.21 Library
'
' To set references, in the VBA Editor, open the
' Tools menu and select References.
'------------------------------------------------------
Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.Namespace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem
'##CDO (COLLABORATION DATA OBJECTS) VARIABLES##
Public mobjCDOSession As MAPI.Session
Public mobjMAPIAppt As MAPI.Message
Public BolOutlookIS As Boolean
'##PUBLIC VARIABLES FOR SETTING & DELETING APPOINTMENTS##
Public intDateNote As Integer
Public strAppSubject As String
Public dteReccDate As Date
Public tmeSetTime As Date
Public strAppRecr As String
Public strAppLoc As String
Public strAppBody As String
Public intMinutes As Integer
Public strImportance As String
Public bolAllDay As Boolean
Public strBusyStats As String
Public dteStrt As Date
Public dteEnd As Date
Public strAppSubject As String
This is where the details are stored
Code:
Public Sub GetAppDetails()
'--------------------------------------------------------------
'####SET THESE DETAILS TO BE YOUR APPOINTMENT REQUIREMENTS####
'#############################################################
'--------------------------------------------------------------
'##SET THE MEETING LOCATION HERE##
strAppLoc = "Office"
'--------------------------------------------------------------
'##SET THE RECCURING PERIOD HERE##
'strAppRecr = olRecursDaily
'strAppRecr = olRecursWeekly
strAppRecr = olRecursMonthly
'strAppRecr = olRecursYearly
'--------------------------------------------------------------
'##SET IF YOU WANT AN ALL DAY APPOINTMENT##
bolAllDay = True
'bolAllDay = False
'--------------------------------------------------------------
'##SET THE START & FINISH DATES##
dteStrt = #19/05/2009#
dteEnd = #19/05/2009#
'--------------------------------------------------------------
'##SET THE AMOUNT OF MINUTES TO ALERT ON THIS APPOINTMENT##
intMinutes = "30"
'--------------------------------------------------------------
'##SET THE IMPORTANCE HERE##
'strImportance = olImportanceLow
'strImportance = olImportanceNormal
strImportance = olImportanceHigh
'--------------------------------------------------------------
'##SET THE BUSY STATUS HERE##
strBusyStats = olBusy
'strBusyStats = olFree
'strBusyStats = olOutOfOffice
'strBusyStats = olTentative
'--------------------------------------------------------------
'##SET THE APPOINTMENT SUBJECT##
strAppSubject = "Your Message Here!!!"
'--------------------------------------------------------------
'##SET THE BODY TEXT HERE## ( YOU CAN USE & VbCrlf & _ TO ADD NEW LINES
strAppBody = "Your first line of the message" & vbCrLf & _
"Your secong line" & vbCrLf & _
vbCrLf & _
"your third Line" & vbCrLf & _
"Your 4th Line" & vbCrLf & _
"Your 5th Line" & vbCrLf & _
"Your 6th Line" & vbCrLf & _
vbCrLf & _
"Your eighth Line" & vbCrLf & _
vbCrLf & _
"Your ninth Line"
'--------------------------------------------------------------
'####################################################
'--------------------------------------------------------------
End Sub
This code is called when you want to delete the subject
Code:
Public Sub ExampleCall_DeleteBySubject()
'Collect the details to find
GetAppDetails
'Call the Appointment details to find
Call DeleteAppointmentItemBySubject(strAppSubject)
End Sub
This finds and deletes the appointment based on the subject
Code:
Private Sub DeleteAppointmentItemBySubject(strAppSubject As String)
' Use this method ONLY if the subject of the
' Appointment Item is known and is UNIQUE.
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strAppSubject)
If Err.Number <> 0 Then GoTo CannotFindObject
mobjAPPT.Delete
MsgBox ("Success!! Your appointment has been deleted")
Bye:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
CannotFindObject:
MsgBox "Cannot find Appointment Item to delete.", _
vbOKOnly, "Information"
GoTo Bye
End Sub
This code adds the appointment
Code:
Public Sub AddAppClosedOutlk()
Dim outMail As Outlook.AppointmentItem
Dim strAppStrt As String
Dim strAppEnd As String
'get the user preferences
GetAppDetails
'set the outlook connection
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strAppSubject)
'check for appointment set. if it is, bail and go to bottom
If Err.Number = 0 Then GoTo FoundObject
'add the start & end time to the set date
strAppStrt = dteStrt
strAppEnd = dteEnd
'collect the user preferences and add to the appointment
Set outMail = Outlook.CreateItem(olAppointmentItem)
With outMail
.Subject = strAppSubject
.Location = strAppLoc
.Start = strAppStrt
.End = strAppEnd
.GetRecurrencePattern = strAppRecr
.Body = strAppBody
.Importance = strImportance
.AllDayEvent = bolAllDay
.ReminderMinutesBeforeStart = intMinutes
.Save
End With
'show message if appointment is created
MsgBox ("Success!! Your appointment has been placed")
Bye:
'close the connection
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
'arrive here if the appointment is already set
FoundObject:
MsgBox "Halt!! Appointment Already Placed!", _
vbOKOnly, "Information"
GoTo Bye
End Sub
im not entirely sure where i picked most of this from. if i remember, i will add the credits. This could be used in such a way that the variables are changed for either form objects or table data. then i guess you could set the data for the appointment change, run the delete code to remove the existing appointment then automatically collect the new data from the table and insert the new appointment in one go.
'collect the user preferences and add to the appointment
Set outMail = Outlook.CreateItem(olAppointmentItem)
With outMail
.Subject = strAppSubject
.Location = strAppLoc
.Start = strAppStrt
.End = strAppEnd
.GetRecurrencePattern = strAppRecr
.Body = strAppBody
.Importance = strImportance
.AllDayEvent = bolAllDay
.ReminderMinutesBeforeStart = intMinutes
.Save
End With
make a variable public
Code:
Public strMileage As String
add a setting in "GetAppDetails()"
Code:
'##SET THE MILEAGE HERE##
strMileage = "100"
'strMileage = your data collection result
make a new routine based on mileage
Code:
Private Sub DeleteAppointmentItemByMileage(strMileage As String)
' Use this method ONLY if the subject of the
' Appointment Item is known and is UNIQUE.
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strMileage)
If Err.Number <> 0 Then GoTo CannotFindObject
mobjAPPT.Delete
MsgBox ("Success!! Your appointment has been deleted")
Bye:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
CannotFindObject:
MsgBox "Cannot find Appointment Item to delete.", _
vbOKOnly, "Information"
GoTo Bye
End Sub
'------------------------------------------------------
' This Access module needs references to:
'
' Microsoft Outlook [VersionNo] Object Library
' Microsoft CDO 1.21 Library
'
' To set references, in the VBA Editor, open the
' Tools menu and select References.
'------------------------------------------------------
Public mobjOLA As Outlook.Application
Public mobjNS As Outlook.namespace
Public mobjFLDR As Outlook.MAPIFolder
Public mobjAPPT As Outlook.AppointmentItem
'##CDO (COLLABORATION DATA OBJECTS) VARIABLES##
Public mobjCDOSession As MAPI.Session
Public mobjMAPIAppt As MAPI.Message
Public BolOutlookIS As Boolean
'##PUBLIC VARIABLES FOR SETTING & DELETING APPOINTMENTS##
Public intDateNote As Integer
Public strAppSubject As String
Public dteReccDate As Date
Public tmeSetTime As Date
Public strAppRecr As String
Public strAppLoc As String
Public strAppBody As String
Public intMinutes As Integer
Public strImportance As String
Public bolAllDay As Boolean
Public strBusyStats As String
Public dteStrt As Date
Public dteEnd As Date
Public strMileage As String
Public Sub GetAppDetails()
'--------------------------------------------------------------
'####SET THESE DETAILS TO BE YOUR APPOINTMENT REQUIREMENTS####
'#############################################################
'--------------------------------------------------------------
'##SET THE MEETING LOCATION HERE##
strAppLoc = "Office"
'--------------------------------------------------------------
'##SET THE RECCURING PERIOD HERE##
'strAppRecr = olRecursDaily
'strAppRecr = olRecursWeekly
strAppRecr = olRecursMonthly
'strAppRecr = olRecursYearly
'--------------------------------------------------------------
'##SET IF YOU WANT AN ALL DAY APPOINTMENT##
bolAllDay = True
'bolAllDay = False
'--------------------------------------------------------------
'##SET THE START & FINISH DATES##
dteStrt = #5/19/2009#
dteEnd = #5/19/2009#
'--------------------------------------------------------------
'##SET THE AMOUNT OF MINUTES TO ALERT ON THIS APPOINTMENT##
intMinutes = "30"
'--------------------------------------------------------------
'##SET THE IMPORTANCE HERE##
'strImportance = olImportanceLow
'strImportance = olImportanceNormal
strImportance = olImportanceHigh
'--------------------------------------------------------------
'##SET THE BUSY STATUS HERE##
strBusyStats = olBusy
'strBusyStats = olFree
'strBusyStats = olOutOfOffice
'strBusyStats = olTentative
'--------------------------------------------------------------
'##SET THE APPOINTMENT SUBJECT##
strAppSubject = "Your Message Here!!!"
'--------------------------------------------------------------
'##SET THE BODY TEXT HERE## ( YOU CAN USE & VbCrlf & _ TO ADD NEW LINES
strAppBody = "Your first line of the message" & vbCrLf & _
"Your secong line" & vbCrLf & _
vbCrLf & _
"your third Line" & vbCrLf & _
"Your 4th Line" & vbCrLf & _
"Your 5th Line" & vbCrLf & _
"Your 6th Line" & vbCrLf & _
vbCrLf & _
"Your eighth Line" & vbCrLf & _
vbCrLf & _
"Your ninth Line"
'##SET THE MILEAGE HERE##
strMileage = "14061990"
'strMileage = your data collection result
'--------------------------------------------------------------
'####################################################
'--------------------------------------------------------------
End Sub
Private Sub DeleteAppointmentItemByMileage(strMileage As String)
' Use this method ONLY if the subject of the
' Appointment Item is known and is UNIQUE.
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strMileage)
If Err.Number <> 0 Then GoTo CannotFindObject
mobjAPPT.Delete
MsgBox ("Success!! Your appointment has been deleted")
Bye:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
CannotFindObject:
MsgBox "Cannot find Appointment Item to delete.", _
vbOKOnly, "Information"
GoTo Bye
End Sub
Public Sub ExampleCall_DeleteByMileage()
Dim outMail As Outlook.AppointmentItem
'collect the user preferences and add to the appointment
Set outMail = Outlook.CreateItem(olAppointmentItem)
With outMail
.Subject = strAppSubject
.Location = strAppLoc
.Start = strAppStrt
.End = strAppEnd
' .GetRecurrencePattern = strAppRecr
.Body = strAppBody
.Importance = strImportance
.AllDayEvent = bolAllDay
.ReminderMinutesBeforeStart = intMinutes
.Mileage = strMileage
.Save
End With
'Collect the details to find
GetAppDetails
'Call the Appointment details to find
Call DeleteAppointmentItemByMileage(strMileage)
End Sub
'collect the user preferences and add to the appointment
Set outMail = Outlook.CreateItem(olAppointmentItem)
With outMail
.Subject = strAppSubject
.Location = strAppLoc
.Start = strAppStrt
.End = strAppEnd
.GetRecurrencePattern = strAppRecr
.Body = strAppBody
.Importance = strImportance
.AllDayEvent = bolAllDay
.ReminderMinutesBeforeStart = intMinutes
.Save
End With
make a variable public
Code:
Public strMileage As String
add a setting in "GetAppDetails()"
Code:
'##SET THE MILEAGE HERE##
strMileage = "100"
'strMileage = your data collection result
make a new routine based on mileage
Code:
Private Sub DeleteAppointmentItemByMileage(strMileage As String)
' Use this method ONLY if the subject of the
' Appointment Item is known and is UNIQUE.
Set mobjOLA = CreateObject("Outlook.Application")
Set mobjNS = mobjOLA.GetNamespace("MAPI")
mobjNS.Logon , , False, False
Set mobjFLDR = mobjNS.GetDefaultFolder(olFolderCalendar)
On Error Resume Next
Set mobjAPPT = mobjFLDR.Items(strMileage)
If Err.Number <> 0 Then GoTo CannotFindObject
mobjAPPT.Delete
MsgBox ("Success!! Your appointment has been deleted")
Bye:
Set mobjAPPT = Nothing
Set mobjFLDR = Nothing
Set mobjNS = Nothing
Set mobjOLA = Nothing
Exit Sub
CannotFindObject:
MsgBox "Cannot find Appointment Item to delete.", _
vbOKOnly, "Information"
GoTo Bye
End Sub
i'll take a look at this tomorrow in depth but i think the problem might be the mileage field not being available in an appointment. i cant find it and you need something physical to store data
