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

Question

在过去的几年里，我们收到了数千封电子邮件，其中包含我们至今未使用的附件，我想合并为一个文件。

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

每封电子邮件均从同一地址发送，并包含两个名为“channelname-yyyy-mm-dd-tagesreport.csv”和“channelname-yyyy-mm-dd-tageskategorien.csv”的文件。

我只需要“tageskategorien”文件。

所有文件都有相同的结构，第 1 行有一个标头，第 2 行有数据，用“;”分隔。 :

DATUM;PI;访问;UC 标签;使用时间标签;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.saveAttachtoDisk(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 文件（如果尚未包含）。然后.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 外接程序，请参阅演练：创建您的第一个适用于 Outlook 的 VSTO 外接程序以了解更多信息。

首先，我建议过滤附件存在的项目，这样您就可以向

Restrict

方法引入另一个条件。以下是一个示例搜索字符串，用于检查

Subject

行和附件：

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 的属性来提高性能，例如

ScreenUpdating

等。在最大化 Excel / VBA 自动化性能文章中了解更多相关信息。