Vba 将作为附件发送的约会添加到日历

Outlook共享邮箱正在接收带有.ics附件的自动电子邮件

我正在尝试打开该附件，并将该会议/约会保存到日历中

我尝试了很多方法。对于我的最新迭代，我希望将此宏直接添加到共享日历的邮箱中。让我知道将电子邮件发送到我的个人Outlook邮箱是否更有意义，然后在那里我从“运行脚本”Outlook规则调用宏，并将其路由到共享日历

Sub-saveAttachments（）
'此Outlook宏在Outlook收件箱中检查邮件
'并在日历中添加一个条目。
错误时转到保存附件\u错误
将收件箱文件夹设置为Outlook.Folder
将myCalendarFolder设置为Outlook.Folder
将myMtgReq暗显为Outlook.MeetingItem
将mynamespace设置为Outlook.NameSpace
作为附件的Dim Atmt
将文件名设置为字符串
作为整数的Dim i
设置mynamespace=Application.GetNamespace（“MAPI”）
设置InboxFolder=mynamespace.GetDefaultFolder（olFolderInbox）
设置myCalendarFolder=mynamespace.GetDefaultFolder（olFolderCalendar）
FilePath=“C:\temp\”
'检查每封邮件的附件
对于InboxFolder.Items中的每个项目
对于项目附件中的每个Atmt
如果正确（Atmt.FileName，3）=“ics”，则
'将附件保存在文件夹中
FileName=FilePath&Atmt.FileName
Atmt.SaveAsFile文件名
'从文件夹导入ics并在日历中放置一个条目
设置myMtgReq=mynamespace.OpenSharedFolder（文件名）
myMtgReq.GetAssociatedAppointment（True）
i=i+1
如果结束
下一个Atmt
下一项
保存附件\u退出：
设置为Atmt=无
设置项=无
设置myMtgReq=Nothing
出口接头
保存附件\u错误：
MsgBox“发生意外错误。”_
&vbCrLf&“请注意并报告以下信息。”_
&vbCrLf&“宏名称：保存附件”_
&vbCrLf&“错误编号：”&错误编号_
&vbCrLf&“错误描述：”&错误描述_
，vbCritical，“错误！”
继续保存附件并退出
端接头

我得到以下信息：

“Outlook无法对此类型的附件执行此操作。”

---

下面是更正的vba。附件另存为导致问题的AppointmentItem，而不是MeetingItem

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

---

下面是更正的vba。附件另存为导致问题的AppointmentItem，而不是MeetingItem

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

---

也许这可以解释？仅供参考，在将来，请注意抛出错误的代码行……这使任何试图提供帮助的人都更加容易。Atmt.Type属性的值是什么？也许这可以解释？仅供参考，在将来，请注意抛出错误的代码行……这使任何试图提供帮助的人都更加容易。Atmt.Type属性的值是多少？