尝试从Outlook归档电子邮件文件

时间：2018-02-13 21:45:46

标签： vba outlook outlook-vba

我们正在尝试削减Outlook PSTs的大小，在项目完成后，不再将相关的电子邮件拉出到各种项目文件夹中。因此，在实现副本之后，您只需退出Outlook几乎无法运行，并且不会继承其任何元数据，我一直在寻找其他解决方案。并找到了一些部分VBA脚本来做它，我已经拼凑在一起并在这里改变以尝试获得我想要的东西。

例程从Outlook中读取选择，并根据需要将电子邮件保存到提供的时间戳和发送者或接收者的位置。分类到子文件夹。那部分似乎运作得很好。但在我的测试中，我在238封电子邮件的outlook文件夹上运行，我的测试日志有233个条目，但只输出了231个文件。有什么想法吗？

可能是因为文件夹太大了？这样我可能需要在较小的部分中进行。或者超越自己，这样我需要在某处添加延迟？

Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim enviro As String
    Dim sUser As String
    Dim fso As Object
    Dim log As Object
    Dim count As Integer

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set log = fso.CreateTextFile("C:\TestLog.txt", True)
    count = 1

    sUser = "UserName"  'During test this was the actual name
    enviro = CStr(Environ("USERPROFILE"))

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sUser + "_" + sName + ".msg"
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            log.WriteLine (CStr(count) + "/" + CStr(ActiveExplorer.Selection.count) + " - " + sPath + sName)
            oMail.SaveAs sPath + sName, olMSG
            count = count + 1
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+{}@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function

1 个答案:

答案 0 :(得分：1)

感谢上面评论中的0m3r和niton帮助我弄明白。那里有一些日历笔记，当然不是电子邮件，因此必须将其删除，并且一些电子邮件与相同的发件人，时间和主题一起到达，因此脚本会覆盖它们。

在此之后我遇到了一些问题，让Outlook在其他机器上运行以允许宏运行。所以我回过头来重写为C＃中的VSTO插件。只有我更改的功能是让RemoveSpecials检查除时间之外的所有内容，并添加路径长度检查，因此事情不会生成超过260个字符。哪会导致事情停止。

这是我搬到c＃

之前的VBA脚本 
Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim sLastPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim sUser As String
    Dim sExtension As String
    Dim iRepeatCount As Integer

    iRepeatCount = 1
    sLastPath = ""
    sExtension = ".msg"

    sUser = "Username"  'During test this was the actual name

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    Dim i As Integer

    For i = 1 To ActiveExplorer.Selection.count
        If ActiveExplorer.Selection.Item(i).MessageClass = "IPM.Note" Then
            Set oMail = ActiveExplorer.Selection.Item(i)
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sTo + "_" + sName
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            If sPath + sName + sExtension = sLastPath Then
                sName = sName + "(" + CStr(iRepeatCount) + ")"
                iRepeatCount = iRepeatCount + 1
            Else
                iRepeatCount = 1
                sLastPath = sPath + sName + sExtension
            End If
            oMail.SaveAs sPath + sName + sExtension, olMSG            
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+{}@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function
相关问题
最新问题