Question

带有.ics的自动电子邮件附件正在发送到Outlook共享日历。我正在尝试使用可以打开该附件的VBA代码，并将该会议/约会保存到日历中。

我已经尝试了很多方法来实现这一点，但是对于我最新的迭代（下面），我希望直接在共享日历的邮箱上添加这个宏。但请告诉我，如果将自动电子邮件发送到我的个人Outlook收件箱更有意义，然后我从“运行脚本”Outlook规则调用宏，并将其路由到共享日历。

 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

当我运行此宏时，我收到以下错误：“Outlook无法对此类附件执行此操作。”

任何帮助都会受到赞赏，因为我是VBA新手！

Answer 1

以下是更正的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

将约会附件添加到Outlook日历

1 个答案: