msg文件导入到outlook中 ，outlook中运行

Sub ImportMessagesInFolder()
Dim xSourceFldPath As String
Dim xMSG As Object
Dim xMailItem As MailItem
Dim xSaveFld As Outlook.Folder
' copy to outlook vba, to import msg file into outlook
'need to add microsoft scripting runtime into the Tools references
On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xSelFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Select a folder：", 0, 0)
If Not TypeName(xSelFolder) = "Nothing" Then
    xSourceFldPath = xSelFolder.self.Path + ""
Else
    xSourceFldPath = ""
End If
Set xSourceFld = xFSO.GetFolder(xSourceFldPath)
Set xSaveFld = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
If TypeName(xSaveFld) = "Nothing" Then
    Exit Sub
End If
For Each xFileItem In xSourceFld.Files
    Set xMSG = Session.OpenSharedItem(xFileItem.Path)
    Set xMailItem = xMSG.Copy
    xMailItem.Move xSaveFld
    Set xMailItem = Nothing
    xMSG.Delete
    Set xMSG = Nothing
Next xFileItem
Set xFileItem = Nothing
Set xSourceFld = Nothing
Set xFSO = Nothing
End Sub