Solved: Keeping a declined meeting in calendar

[mikke3141]

Hello,

I'm trying to keep a ghost meeting of my declined meetings in my calendar. When I decline a meeting in Outlook 2010 Calendar the meeting is automatically removed from my calendar. I would like the declined meeting to stay in the calendar (but the meeting status as free, not busy). This way I could attend the meeting later, if my other meeting is cancelled. How should I solve this issue with VBA? Thank you for your help.

[mikke3141]

Hello,

I solved it with some google surfing. To be added to the ThisOutlookSession

[vba]Public WithEvents myOlItems As Outlook.Items
Public Sub Application_Startup()
Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderDeletedItems).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' This macro regenerates the declined appointments and changes their status
If TypeName(Item) = "MeetingItem" Or TypeName(Item) = "AppointmentItem" Then

If Item.Subject > 0 And Not (InStr(1, Item.Subject, "DECLINED") > 0) And Item.Start > Now And Item.ResponseStatus = 4 Then

If MsgBox("Do you want to keep the declined meeting in your calendar?", vbYesNo) = vbNo Then Exit Sub

Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItem(olAppointmentItem)

If InStr(1, Item.Subject, "DECLINED:") > 0 Then
MyItem.Subject = Item.Subject
Else
MyItem.Subject = "DECLINED: " & Item.Subject
End If

MyItem.MeetingStatus = olMeeting
MyItem.Location = Item.Location
MyItem.Start = Item.Start
MyItem.Duration = Item.Duration
MyItem.AllDayEvent = Item.AllDayEvent
MyItem.BusyStatus = 0
MyItem.ReminderSet = False
MyItem.Body = Item.Body
MyItem.Sensitivity = olPrivate
MyItem.RequiredAttendees = Item.RequiredAttendees
MyItem.OptionalAttendees = Item.OptionalAttendees
Check_Category
MyItem.Categories = "Declined"
' Copy attachments to the created appointment
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2)

strPath = fldTemp.Path & "\"
For Each objAtt In Item.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
MyItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next

Set fldTemp = Nothing
Set fso = Nothing
MyItem.Save
End If
End If
End Sub

Sub Check_Category()
' Check if category 'declined' exists. If not, create it and add a suitable color
Dim objNameSpace
Dim objCategory
itexists = False
Set objNameSpace = Application.GetNamespace("MAPI")
again:
For Each objCategory In objNameSpace.Categories
If objCategory.Name = "Declined" Then
objCategory.Color = 6
itexists = True
End If
Next
If itexists = False Then
objNameSpace.Categories.Add ("Declined")
GoTo again
End If
Set objCategory = Nothing
Set objNameSpace = Nothing
End Sub[/vba]

Regards,

Mike

[tinkynan]

I came across this thread while looking for a solution but went ahead and came up with what I think is a more elegant way. Unlike mikke3141's code, my code will also preserve the attachements in the meeting notice.

Sub DeclineAndSave()
' Decline Meetings and Save a Copy
' Create a Category called Decline and customize the color
'
Dim cAppt, oAppt, oResponse As AppointmentItem

Check_Category

Set oAppt = GetCurrentItem
Set cAppt = oAppt.Copy
cAppt.Subject = "DECLINED: " & oAppt.Subject
cAppt.BusyStatus = olFree
cAppt.Categories = "Declined"
cAppt.Save

Set oResponse = oAppt.Respond(olMeetingDeclined, False, True)

Set cAppt = Nothing
Set oAppt = Nothing

End Sub

The usage is different from mikke3141's code. Assign this code to a button on ribbon or QAT and click it to decline the meeting. You will be prompted on how to send your response (Edit, Send, or Do Not Send) as usual.

Check_Category from mikke3141 is called here too. You can delete it if you already created the "Declined" category.

[jalitemp]

Hi tinkynan, I was trying to use your macro , but it stops at line "Set oAppt = GetCurrentItem"
Message box says "Run-time error 13. Type mismatch."

What am I doing wrong ? I copied the exact lines from your code.
Using Outlook 2010

[skatonni]

Hi tinkynan, I was trying to use your macro , but it stops at line "Set oAppt = GetCurrentItem"
Message box says "Run-time error 13. Type mismatch."

What am I doing wrong ? I copied the exact lines from your code.
Using Outlook 2010

Some people prefer, unless you are answering the original poster, you start a new topic with the relevant details. Link to this one if necessary.

[Muppet1856]

I appreciate this, but I optimized this a little.

[vba]
Sub Check_Category()
' Check if category 'declined' exists. If not, create it and add a suitable color
Dim objNameSpace
Dim objCategory
Dim itexists As Boolean = False
objNameSpace = Application.GetNamespace("MAPI")

objCategory = objNameSpace.Categories.Item("Declined")
If IsNothing(objCategory) Then
objNameSpace.Categories.Add("Declined", OlCategoryColor.olCategoryColorTeal)
End If
objCategory = Nothing
objNameSpace = Nothing
End Sub
[/vba]

[vba]
Sub Check_Category()
' Check if category 'declined' exists. If not, create it and add a suitable color
Dim objNameSpace
Dim objCategory
itexists = False
Set objNameSpace = Application.GetNamespace("MAPI")
again:
For Each objCategory In objNameSpace.Categories
If objCategory.Name = "Declined" Then
objCategory.Color = 6
itexists = True
End If
Next
If itexists = False Then
objNameSpace.Categories.Add ("Declined")
GoTo again
End If
Set objCategory = Nothing
Set objNameSpace = Nothing
End Sub[/vba]