1

我需要编写一个函数，它将获取多个 eml 文件（可能来自单个文件系统文件夹）并将它们转换为单个 PST 文件。

可能吗？如果是，有人可以提供示例代码吗？

我认为这是可能的，因为那里有许多商业 eml 到 pst 转换器这样做

4

4 回答 4

3

尽管Outlook 可以打开 EML 文件，但无法仅使用 VBA以编程方式进行。所以我创建了这个 VBA 宏，它遍历某个文件夹并使用SHELL EXEC打开每个 EML 文件。Outlook 打开 EML 文件可能需要几毫秒，因此 VBA 会一直等待，直到在 ActiveInspector 中打开某些内容。最后，这封电子邮件被复制到某个选定的文件夹中，并且（在成功的情况下）原始 EML 文件被删除。

此宏有时会崩溃，但您可以随时重新启动宏，它会从之前崩溃的地方重新启动（请记住，所有成功导入的 EML 文件都会被删除）。如果重启后一直崩溃，那么可能是下一个即将导入的 EML 文件有问题。在这种情况下，您只需删除有问题的 EML。

PS：有时您可以自己打开 EML，而不会导致 Outlook 崩溃，但根据我的测试，每次 EML 文件导致 Outlook 崩溃时，它都是不重要的，例如已读回执。

下面是我的VBA 代码。如果您有任何疑问或问题，请告诉我。

'----------------------------------------------------
' Code by Ricardo Drizin (contact info at http://www.drizin.com.br)
'----------------------------------------------------
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Option Explicit

'---------------------------------------------------------------------
' This method closes ActiveInspectors if any.
' All inporting is based on the assumption that the EML
' is opened by shell and we can refer to it through the ActiveInspector
'---------------------------------------------------------------------
Function CloseOpenInspectors() As Boolean
    Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application")
    Dim insp As Outlook.Inspector
    Dim count As Integer
    count = 0
repeat:
    count = count + 1
    Set insp = app.ActiveInspector
    If TypeName(insp) = "Nothing" Then
        CloseOpenInspectors = True
        Exit Function
    End If
    If TypeName(insp.CurrentItem) = "Nothing" Then
        CloseOpenInspectors = True
        Exit Function
    End If
    If (count > 100) Then
        MsgBox "Error. Could not close ActiveInspector. "
        CloseOpenInspectors = False
    End If

    insp.Close (olDiscard)
    GoTo repeat
End Function


'---------------------------------------------------------------------
' This method allows user to choose a Root Folder in Outlook
' All EML files will be imported under this folder
'---------------------------------------------------------------------
Function GetRootFolder() As Outlook.folder
    Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application")
    Dim NS As Outlook.NameSpace: Set NS = app.GetNamespace("MAPI")
    Dim fold As Outlook.folder
    Set fold = NS.PickFolder
    'MsgBox fold.Name
    Set GetRootFolder = fold
End Function

'---------------------------------------------------------------------
' Creates a child folder in Outlook, under root folder.
'---------------------------------------------------------------------
Function GetChildFolder(parentFolder As Outlook.folder, name As String)
    On Error Resume Next
    Dim fold2 As Outlook.folder
    Set fold2 = parentFolder.folders.Item(name)
    If Err.Number Then
        On Error GoTo 0
        Set fold2 = parentFolder.folders.Add(name)
    End If
    On Error GoTo 0
    'MsgBox fold2.Name
    Set GetChildFolder = fold2
End Function

'---------------------------------------------------------------------
' Imports the EML open in the current ActiveInspector
' into the given folder
'---------------------------------------------------------------------
Sub ImportOpenItem(targetFolder As Outlook.folder)
    Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application")
    Dim insp As Outlook.Inspector: Set insp = app.ActiveInspector

    Dim retries As Integer
    retries = 0
    While TypeName(insp) = "Nothing" ' READING PANE should be visible, or else it will not work.
        'MsgWaitObj (1000)
        Sleep (50)
        DoEvents
        Sleep (50)
        Set insp = app.ActiveInspector
        retries = retries + 1
        'If retries > 100 Then
        '    Stop
        'End If
    Wend

    If TypeName(insp) = "Nothing" Then
        MsgBox "Error! Could not find open inspector for importing email."
        Exit Sub
    End If


    Dim m As MailItem, m2 As MailItem, m3 As MailItem
    Set m = insp.CurrentItem
    'MsgBox m.Subject
    Set m2 = m.Copy
    Set m3 = m2.Move(targetFolder)
    m3.Save
    Set m = Nothing
    Set m2 = Nothing
    Set m3 = Nothing
    insp.Close (olDiscard)
    Set insp = Nothing
End Sub


'---------------------------------------------------------------------
' Scans a given folder for *.EML files and import them
' into the given folder.
' Each EML file will be deleted after importing.
'---------------------------------------------------------------------
Sub ImportEMLFromFolder(targetFolder As Outlook.folder, emlFolder As String)
    If Right(emlFolder, 1) <> "\" Then emlFolder = emlFolder & "\"
    Dim firstImport As Boolean: firstImport = True

    Dim file As String
    Dim count As Integer: count = 0
    'MsgBox fold.Items.count
    'Exit Sub
    file = Dir(emlFolder & "*.eml")

repeat:
    If file = "" Then
        'MsgBox "Finished importing EML files. Total = " & count
        Debug.Print "Finished importing EML files. Total = " & count
        Exit Sub
    End If
    count = count + 1

    Debug.Print "Importing... " & file & " - " & emlFolder
    Shell ("explorer """ & emlFolder & file & """")
    'If firstImport Then Stop
    firstImport = False
    Sleep (50)
    On Error GoTo nextfile
    Call ImportOpenItem(targetFolder)
    Call Kill(emlFolder & file)
nextfile:
    On Error GoTo 0
    Sleep (50)

    file = Dir()
    GoTo repeat
End Sub

'---------------------------------------------------------------------
' Main method.
' User chooses an Outlook root Folder, and a Windows Explorer root folder.
' All EML files inside this folder and in immediate subfolders will be imported.
'---------------------------------------------------------------------
Sub ImportAllEMLSubfolders()
    Call CloseOpenInspectors

    MsgBox "Choose a root folder for importing "
    Dim rootOutlookFolder As Outlook.folder
    Set rootOutlookFolder = GetRootFolder()
    If rootOutlookFolder Is Nothing Then Exit Sub

    Dim rootWindowsFolder As String
    rootWindowsFolder = "D:\Outlook Express EMLs folder"
    rootWindowsFolder = InputBox("Choose a windows folder where you have your EML files", , rootWindowsFolder)
    If IsNull(rootWindowsFolder) Or IsEmpty(rootWindowsFolder) Or rootWindowsFolder = "" Then Exit Sub
    If Right(rootWindowsFolder, 1) <> "\" Then rootWindowsFolder = rootWindowsFolder & "\"

    Dim subFolders As New Collection

    Dim subFolder As String
    subFolder = Dir(rootWindowsFolder, vbDirectory)
repeat:
    If subFolder = "." Or subFolder = ".." Then GoTo nextdir
    If (GetAttr(rootWindowsFolder & subFolder) And vbDirectory) = 0 Then GoTo nextdir
    subFolders.Add (subFolder)
nextdir:
    subFolder = Dir()
    If subFolder <> "" Then GoTo repeat

Dim outlookFolder As Outlook.folder

' Importing main folder
Call ImportEMLFromFolder(rootOutlookFolder, rootWindowsFolder)

' Importing subfolders
While subFolders.count
    subFolder = subFolders.Item(1)
    subFolders.Remove (1)
    Set outlookFolder = GetChildFolder(rootOutlookFolder, subFolder)
    Debug.Print "Importing " & rootWindowsFolder & subFolder & " into Outlook folder " & outlookFolder.name & "..."
    Call ImportEMLFromFolder(outlookFolder, rootWindowsFolder & subFolder)
Wend
    Debug.Print "Finished"

End Sub
于 2015-11-17T15:58:07.937 回答
2

很可能是更简单或更好的方法，但一种方法可能是使用 Interop 来自动化 Outlook。可能有一些使用 Outlook 的内置导入功能的能力，这将是我尝试寻找的第一件事。假设这是不可能的，您应该仍然可以通过读取应用程序中的 eml 文件然后通过 Interop 创建邮件项来做到这一点。

通常，eml 文件只是 MIME 格式的文本文件，因此只需将它们作为文本文件读取并解析即可。这是一篇关于从 C# 解析 MIME 的文章，否则只需搜索“POP3 C#”，您就会找到其他相关文章。

然后，您可以使用此处Microsoft.Office.Interop.Outlook所述的命名空间中的Outlook 互操作。

猜测一下，我假设您可能必须首先创建一个Application对象，然后使用它来获取Store对象（我认为每个 PST 文件都是一个Store），然后Folder在其中找到某种方法来创建MailItem使用数据您从 eml 文件中解析。

本文介绍了使用 Outlook 自动化来创建联系人和约会，并且可能很有用。

于 2010-06-12T18:09:12.230 回答
2

您可以为此使用救赎。类似的东西：

  set Session = CreateObject("Redemption.RDOSession")
  Session.LogonPstStore("c:\temp\test.pst")
  set Folder = Session.GetDefaultFolder(olFolderInbox)
  set Msg = Folder.Items.Add("IPM.Note")
  Msg.Sent = true
  Msg.Import("c:\temp\test.eml", 1024)
  Msg.Save
于 2013-04-22T16:47:42.123 回答
0

您可以在此处找到 pst 文件格式的规范。但我想你会花一些时间把它们放在一起来自己创建一个 eml->pst 解析器。但这应该是可能的。

于 2010-06-12T18:23:25.660 回答