使用Outlook VBA提高从Excel附件复制的速度

Question

在过去的几年中，我们收到了数千封电子邮件，直到现在直到现在，我都想将其合并到一个文件中。

Outlook收件箱有38.000个未读电子邮件。

每个电子邮件都是从同一地址发送的，并包含两个名为“ ChannelName-Yyyy-Mm-DD-TagesReport.csv”和“ ChannelName-yyyy-yyyy-mm-dd-tageskategorien.csv”的文件。

我只需要“ TagesKategorien”文件。

所有文件都具有相同的结构，LINE1中的标题和第2行中的数据将“;”分开。 ：

datum; pi;访问; uc tag; usetime标签; pi laufende woche;访问laufende
Woche; Pi Laufender Monat;访问Laufender Monat

我有工作代码，但很慢（每封电子邮件9秒）。
它通过非默认邮箱进行查看，将附件保存到本地文件夹中，并根据某些条件将第二行复制到另一个工作簿中。

如果不是为此做VBA，请告诉我。

当我将邮件项目限制到一个月的时间范围时，它通常会陷入困境或表现很奇怪（仅在某些时间内进行一些例程）。

代码的第一部分逐一访问电子邮件，并调用两个子例程：

Option Explicit

Sub SearchEmails()

Dim oINS As NameSpace
Dim FolderInbox As MAPIFolder
Dim filtered_items As Items
Dim olMail As MailItem
Dim strFilter As String
Dim olRecip As Recipient

Set oINS = GetNamespace("MAPI")
Set FolderInbox = oINS.Folders("Onlinearchiv - [email protected]")
Set FolderInbox = FolderInbox.Folders("Posteingang")

strFilter = "[ReceivedTime]>'" & Format(Date - 10, "DDDDD HH:NN") & "'"

Set filtered_items = FolderInbox.Items.Restrict(strFilter)

If filtered_items.Count = 0 Then
    GoTo empty_objects
End If

For Each olMail In filtered_items
    Call SaveTagesreport.saveAttachtoDisk(olMail)
    Call mergeReport.Merge_oewaReport(olMail)
Next olMail

empty_objects:
    Set FolderInbox = Nothing
    Set oINS = Nothing

End Sub

CALL SAVETAGESREPORT.SAVEATTACHTOCHTODISK（OLMAIL）将两个附件文件之一（取决于名称）保存到本地文件夹中。有人告诉我，这是需要的，因为我们只能在保存文件时复制一行。最初，我想直接访问它而无需保存。

Option Explicit
Function FileExists(FilePath As String) As Boolean
    Dim TestStr As String

    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim x As Long
Dim saveFolder As String
Dim Name As String

saveFolder = "Mypath/mylocalfolder"

For Each objAtt In itm.Attachments
    x = InStr(1, "tageskategorien.csv", objAtt.DisplayName)
    Name = objAtt.DisplayName
    If InStr(1, objAtt.DisplayName, "tageskategorien.csv", 1) = 0 Then
        If Not FileExists(saveFolder & objAtt.DisplayName) Then
            objAtt.SaveAsFile saveFolder & objAtt.DisplayName
        End If
    End If

    Set objAtt = Nothing

Next

End Sub

最后一部分打开.csv文件，如果尚未包含在alldata.xlsx文件中，则将数字写入alldata.xlsx文件。然后删除.csv文件，因为它仅包含我写入alldata.xlsx文件的一行，因此之后不需要。

Option Explicit

Sub Merge_oewaReport(itm As Outlook.MailItem)

'AllData.file Dims
Dim wb_path As String
Dim app_master As Excel.Application
Dim wb_master As Excel.Workbook
Dim ws_master As Excel.Worksheet

Dim ic_last As Integer
Dim ir_last As Integer
Dim ic_zeitr As Integer
Dim ic_date As Integer
Dim ic_ID As Integer

'EmailFile Dims
Dim objAtt As Outlook.Attachment
Dim FileName As String

Dim app_email As Excel.Application
Dim wb_email As Excel.Workbook
Dim ws_email As Excel.Worksheet

Dim ic_last2 As Integer
Dim ic_Date_e As Integer
Dim headerList() As String
Dim content() As String

'other dims
Dim Path As String
Dim datestr As Date
Dim datetemp As Date

Dim fID() As String
Dim fDay As String
Dim columnHeading As String
Dim i As Integer
Dim j As Integer
Dim Duplicate As Boolean

'Set up identifiers for AllData.file
Path = "mypath/mylocalfolder/"
wb_path = Path & "AllData.xlsx"
Set app_master = CreateObject("Excel.Application")
Set wb_master = app_master.Workbooks.Open(wb_path, ReadOnly:=False)
Set ws_master = wb_master.Sheets(1)

ic_last = ws_master.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
ir_last = ws_master.Cells(ws_master.Rows.Count, 1).End(-4162).Row
ic_date = ws_master.Cells.Find(What:="DATUM", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
ic_ID = ws_master.Cells.Find(What:="ID", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
ic_zeitr = ws_master.Cells.Find(What:="Zeitraum", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column

For Each objAtt In itm.Attachments

    FileName = objAtt.DisplayName
    If InStr(1, FileName, "tageskategorien.csv", 1) = 0 Then
        Set app_email = CreateObject("Excel.Application")
        Set wb_email = app_email.Workbooks.Open(Path & FileName, True, True)
        Set ws_email = wb_email.Sheets(1)
        
        'find Date and Name in Emailfile
        fID = Split(FileName, " - ")
        headerList = Split(ws_email.Cells(1, 1), ";")
        content = Split(ws_email.Cells(2, 1), ";")
        For i = 0 To UBound(headerList)
            If headerList(i) = "DATUM" Then
                datestr = content(i)
                Exit For
            End If
        Next i
        
        'check ID of every line that matches the date, to find if new Data already exists
        Duplicate = False
        For i = 2 To ir_last
            datetemp = ws_master.Cells(i, ic_date)
            If ws_master.Cells(i, ic_date).Value = datestr Then
                If ws_master.Cells(i, ic_ID) = fID(0) Then
                    Duplicate = True
                    Exit For
                End If
            End If
        
        Next i
        
        'If the new data is not a duplicate, then fill in a new line
        If Not Duplicate = True Then
            j = ws_master.Cells.Find(What:="ID", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
            ws_master.Cells(ir_last + 1, j) = fID(0)
            
            fID = Split(fID(1), "-")
            fDay = fID(UBound(fID))
            fDay = Split(fDay, ".")(0)
            If fDay = "tagesreport" Then
                ws_master.Cells(ir_last + 1, ic_zeitr) = "Tag"
            End If
            ir_last = ir_last + 1
            
            For i = 0 To UBound(headerList)
                columnHeading = headerList(i)
                
                Select Case columnHeading
                        
                    Case "DATUM"
                        ws_master.Cells(ir_last, ic_date) = datestr
                        
                        j = ws_master.Cells.Find(What:="Month", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = Month(datestr)
                        
                        j = ws_master.Cells.Find(What:="Year", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = Year(datestr)
                    
                    Case "PI"
                        j = ws_master.Cells.Find(What:="PI", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit"
                        j = ws_master.Cells.Find(What:="Visit", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "UC Tag"
                        j = ws_master.Cells.Find(What:="UC Tag", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Usetime Tag"
                        j = ws_master.Cells.Find(What:="Usetime Tag", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "PI laufende Woche"
                        j = ws_master.Cells.Find(What:="PI laufende Woche", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit laufende Woche"
                        j = ws_master.Cells.Find(What:="Visit laufende Woche", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "PI laufender Monat"
                        j = ws_master.Cells.Find(What:="PI laufender Monat", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                    Case "Visit laufender Monat"
                        j = ws_master.Cells.Find(What:="Visit laufender Monat", SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
                        ws_master.Cells(ir_last, j) = content(i)
                        
                End Select
            Next i
            
        End If
    End If
    Set objAtt = Nothing

Next

wb_master.Close SaveChanges:=True

'Delete the temp file again
For Each objAtt In itm.Attachments
    If FileExists(Path & objAtt.DisplayName) Then
        ' First remove readonly attribute, if set
        SetAttr Path & objAtt.DisplayName, vbNormal
        ' Then delete the file
        Kill Path & objAtt.DisplayName
    End If
Next

End Sub

Answer 1

有几个方面可以改善代码的整体性能。如果您没有在多台计算机上部署解决方案的计划，则VBA是实施此类任务的有效方法。但是，如果您需要分发解决方案，建议您改用VSTO加载项，请参见练习：创建您的第一个vsto加载项以获取Outlook 以获取更多信息。

首先，我建议在附件存在上过滤项目，以便您可以向限制方法引入更多条件。这是一个示例搜索字符串，该字符串检查主题行和附件：

Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
                   Chr(34) & " Like '%training%' AND " & _
                   Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                   Chr(34) & "=1"

其次，我建议在处理Outlook项目时保持Excel应用程序打开。无需每次打开和关闭它。

第三，您可以尝试设置Excel的属性以提高性能，例如secredupdating和等。在最大化Excel/VBA自动化性能文章。