Adding an Appointment sent as an Attachment to a Calendar - vba

Question

Automated emails with .ics attachments are being received in an Outlook Shared mailbox.
I am trying to open that attachment, and save that Meeting/Appointment to the Calendar.
I tried a number of ways. For my latest iteration I am hoping to add this macro directly on the Shared Calendar's mailbox. Let me know if it makes more sense for the emails to be sent to my personal Outlook mailbox, where I then call the macro from a "run a script" Outlook Rule, and route it to the Shared Calendar.
Sub SaveAttatchments()
' This Outlook macro checks at the Outlook Inbox for messages
' with attached files (of *.ics type) and put a entry in the calendar.
On Error GoTo SaveAttachments_err
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim mynamespace As Outlook.NameSpace
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set mynamespace = Application.GetNamespace("MAPI")
Set InboxFolder = mynamespace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = mynamespace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "ics" Then
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myMtgReq = mynamespace.OpenSharedFolder(FileName)
myMtgReq.GetAssociatedAppointment (True)
i = i + 1
End If
Next Atmt
Next Item
SaveAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub
I get the following:
"Outlook cannot perform this action on this type of attachment."

Answer 1

Below is the corrected vba. The Attachment saves as a AppointmentItem, not a MeetingItem, which was causing the issues.
Sub SaveAttatchments()
On Error GoTo SaveAttachments_err
Dim myNameSpace As Outlook.NameSpace
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim myAppt As Outlook.AppointmentItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set myNameSpace = Application.GetNamespace("MAPI")
Set InboxFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
If Item.Subject = "Conf Calendar" Then
For Each Atmt In Item.Attachments
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myAppt = myNameSpace.OpenSharedItem(FileName)
myAppt.Save
i = i + 1
Next Atmt
End If
Next Item
' Clear memory
SaveAttachments_exit:
Set Atmt = Nothing
Set Item= Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub