在 EML 文件上运行"Application.CreateItemFromTemplate"方法的权限错误

Question

我正在尝试运行一个宏，将EML文件复制到我的收件箱中。

当我到达Application.CreateItemFromTemplate行将其应用于EML文件时，我得到一个运行时错误:

我们无法打开[filename.path]。可能文件已经打开，或者您没有权限打开它。

我尝试以ADMIN身份运行Outlook。也尝试了Session.OpenSharedItem法。我使用Outlook for Microsoft 365 MSO。

完整代码:

Sub ImportMessagesToOutlookFolder()
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SourceFolderName As String
Dim FileItem As Scripting.File
Dim strFile, strFileType As String
Dim oMsg As Object
Dim objNS As NameSpace
Dim copiedMsg As MailItem
Dim Savefolder As Outlook.Folder

Set fso = New Scripting.FileSystemObject 'Source folder
'Ask for folder with items to import
SourceFolderName = BrowseForFolder("My Computer")
Set SourceFolder = fso.GetFolder(SourceFolderName)

'Set the Outlook folder name
Set objNS = Application.GetNamespace("MAPI")
Set Savefolder = objNS.PickFolder
For Each FileItem In SourceFolder.Files

'Set oMsg = FileItem
Set oMsg = Outlook.Application.CreateItemFromTemplate(FileItem.Path)

'On Error Resume Next

Set copiedMsg = oMsg.Copy

copiedMsg.Move Savefolder

Set copiedMsg = Nothing
Debug.Print FileItem.Name & " " & FileItem.DateCreated

oMsg.Delete
Set oMsg = Nothing
'FileItem.Delete

Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing

End Sub 

Answer 1

应用。CreateItemFromTemplate方法从Outlook模板(.oft)创建一个新的Microsoft Outlook项目并返回新项目。默认情况下，它不是为EML文件设计的。您可以尝试使用ShellExecute方法在默认应用程序中打开EML(您可以设置Outlook，参见在Outlook中打开.eml文件了解更多信息):

Dim objShell : Set objShell = CreateObject("Shell.Application")
Dim objFolder : Set objFolder = objShell.BrowseForFolder(0, "Select the folder containing eml-files", 0)
Dim Item
If (NOT objFolder is Nothing) Then
Set WShell = CreateObject("WScript.Shell")
Set objOutlook = CreateObject("Outlook.Application")
Set Folder = objOutlook.Session.PickFolder
If NOT Folder Is Nothing Then
For Each Item in objFolder.Items
If Right(Item.Name, 4) = ".eml" AND Item.IsFolder = False Then
objShell.ShellExecute Item.Path, "", "", "open", 1
WScript.Sleep 1000
Set MyInspector = objOutlook.ActiveInspector
Set MyItem = objOutlook.ActiveInspector.CurrentItem
MyItem.Move Folder
End If
Next
End If
End If
MsgBox "Import completed.", 64, "Import EML"
Set objFolder = Nothing
Set objShell = Nothing