Question

我要做的是将Outlook 2007共享收件箱文件夹中的所有电子邮件详细信息导出到Excel 2007工作表（发件人，主题，日期和时间），该工作正常（见下文）。

然后，我将在excel 2007中使用一些公式来尝试从主题中提取引用。然后针对从我们的计算机系统导出的一些数据查找引用，如果引用与文件引用匹配，则从公式设置条件将填充D列中的答案（以便接收发件人，主题，日期和时间，是/否）。如果无法找到引用或文件中的数据不符合条件，则响应列D将显示“是”（表示需要将其标记为已读并移至文件夹“无响应”它是与收件箱在同一级别上的同一共享邮箱的一部分）否则将显示“否”（在这种情况下，不需要对该电子邮件进行任何操作）。是/否列公式标准将是一项持续不断的工作。

到目前为止，将电子邮件详细信息导出到Excel工作表中以及所有公式都是可行的，但是我还没有设法让Outlook从Excel工作表中的详细信息中采取适当的操作。

Sub ExportToExcel()

' Fully working, will export Sender, Subject & Date Received from e-mails into spreadsheet *** Except For Non-Mail Items ***
' If getting "spreadsheet user-defined type not defined" go to Visual Basic > Tools > References and tick 'Microsoft Excel 12.0 Object Library'
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

'Set path for spreadsheet
strSheet = "OE.xlsx"
strPath = "C:\Users\JM\Desktop\"
strSheet = strPath & strSheet
Debug.Print strSheet

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub

ElseIf fld.DefaultItemType <> olMailItem Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub

ElseIf fld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub

End If

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
intColumnCounter = intColumnCounter
Set rng = wks.Cells(intRowCounter, intColumnCounter)
'rng.Value = msg.SenderEmailAddress
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm

MsgBox "Export Complete", vbOKOnly, "Information"
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub

ErrHandler:
If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
MsgBox "Export Completed", vbOKOnly
End Sub

这就是电子表格的样子，由于数据保护，我无法显示原始电子表格。

这是变得棘手的地方，我对excel VBA了如指掌，但对Outlook VBA的了解非常有限。大多数代码都是从几个不同的网站组合在一起的，并且被我删除，以便将它用于我的目的。

代码的主要来源是这个网站 http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&s=11b5bf88fb5e89d06f7c8b43f6f92d2e

我想要以下代码：

将“是”电子邮件标记为已读并将其移至Outlook中的共享“无响应”文件夹中（与收件箱中的电子邮件详细信息相同的共享邮箱中。

这是我到目前为止的地方......很近但不完全在那里。最令人沮丧的部分是代码将识别电子邮件，将其标记为未读，将其标记为完整但不会将项目移动到文件夹或处理整个文件夹。

Option Explicit
Const strWorkbook As String = "C:\Users\jmurrey\Desktop\OE.xlsm" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub ProcessFolder()
    Dim olItem As Object
    Dim olFolder As Folder
    Set olFolder = Session.PickFolder 'select the folder
    For Each olItem In olFolder.Items 'loop through the items
        If TypeName(olItem) = "MailItem" Then
            MoveToFolder olItem 'run the macro
        End If
        Exit For
    Next olItem
    Set olItem = Nothing
lbl_Exit:
    Exit Sub
End Sub
Sub MailFilter()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    MoveToFolder olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub MoveToFolder(olMail As Outlook.MailItem)
    Dim olReply As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim Arr() As Variant
    Dim iCols As Long
    Dim iRows As Long
    Dim strName As String
     'load the worksheet into an array
    Arr = xlFillArray(strWorkbook, strSheet)
    With olMail
        For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
             'If column 2 (starting at column 0) contains the e-mail address of the message
            If .SenderEmailAddress = Arr(0, iRows) Then
                'If the subject value is in the message subject
                If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                     If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
                     'If the received time is in the message subject
                        If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
                        'If The string above matches then mark the email as unread and move to 'No Response' folder
                            'MsgBox "Match Found", vbOKOnly, "Match"
                            .FlagStatus = olFlagComplete
                            .UnRead = False
                            .Save
                            .Move Application.Session.Folders("No Response")
                            Exit For
                        End If
                    End If
                End If
            End If
        Next iRows
    End With
lbl_Exit:
    Set olReply = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
    strWorksheetName As String) As Variant
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long

    strWorksheetName = strWorksheetName & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strWorkbook & ";" & _
    "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

我需要帮助的是将电子邮件移动到“无响应”文件夹，该文件夹与导出数据的收件箱位于同一共享邮箱中，并且还使代码通过所有电子邮件运行邮件在Excel工作表中而不是仅仅一个。以下是电子表格的概念：

非常感谢任何帮助

约翰

Answer 1

我的代码存在很多问题。有些问题，我确信您的代码有问题。对于其他问题，我不太确定。我将编写代码来讨论我的问题，希望能帮助您解决问题。

如果可以避免，请不要在开发期间或发布后使用On Error GoTo ErrHandler。您的代码将报告工作簿的不存在，但如果发生任何其他错误，它将停止，而不会指示它未能完成其任务或原因。

尝试使用此工作簿问题，并在发现任何其他问题时添加代码：

  Set wkb = Nothing
  On Error Resume Next
  Set wkb = appExcel.Workbooks.Open(strSheet)
  On Error GoTo 0
  If wkb Is Nothing Then
    Call MsgBox("I cannot open the workbook", vbOKOnly)
    Exit Sub
  End If

Dim intRowCounter As Integer。我们被告知停止对VBA使用数据类型Integer，因为它声明了一个16位变量，这些变量需要特殊 - 慢速处理32位和64位计算机。当我开始测试这个声明时，我无法检测到处理速度的任何差异。我没有使用Integer作为行号的原因是它的最大值是32767.我假设你每个文件夹不会有那么多电子邮件，但我仍然建议你养成将行号声明为{{{ 1}}。

您没有初始化Long。默认值为0，您在首次使用前添加1，因此它从1开始。

intRowCounter。不是很重要，但我讨厌任何可能导致未来混乱的事情。 “OE.xlsx”是工作簿的名称，而不是工作表的名称。术语“电子表格”可以追溯到每个文件只有一张纸时，我认为它已经过时了。

如果您希望能够针对多个文件夹运行此宏，请使用strSheet = "OE.xlsx"选择该文件夹。我担心你使用PickFolder，因为你不知道如何获得文件夹引用，特别是在PickFolder中使用资源管理器时。

或者，由于您正在使用资源管理器，也许这种技术会吸引人。用户选择目标文件夹，然后在开头使用此代码启动宏：

MailFilter()

Dim Exp As Outlook.Explorer Dim Fldr As Folder Set Exp = Outlook.Application.ActiveExplorer If Exp.Selection.Count = 0 Then Call MsgBox("No emails selected", vbOKOnly) Exit Sub Else Set Fldr = Exp.Selection(1).Parent End If是第一个或唯一选定的电子邮件。

Exp.Selection(1)是包含所选电子邮件的文件夹。

无需激活工作表。

除非任务的性质需要，否则我永远不会按编号标识列。我会用以下代码替换你的代码：

Exp.Selection(1).Parent

我认为这更易于阅读，更重要的是，如果任何列移动，您只需要更新常量。

在您的第一个宏中，您使用Const ColEmSenderEmailAddress As Long = 1 Const ColEmSubject As Long = 2 Const ColEmReceivedTime As Long = 3 wks.Cells(intRowCounter, ColEmSenderEmailAddress).Value = msg.SenderEmailAddress wks.Cells(intRowCounter, ColEmSubject).Value = msg.Subject wks.Cells(intRowCounter, ColEmReceivedTime).Value = msg.ReceivedTime来访问邮件项目。在第二个中，您使用资源管理器访问第一个或唯一选定的电子邮件。你必须保持一致。

我很少使用For Each itm In fld.Items并且从未尝试过将项目呈现给宏的顺序。在第二个宏中，您将通过将其移动到其他位置来从文件夹中删除项目。我再也没有尝试过，所以不知道这可能会如何影响For Each itm In fld.Items返回的项目。我怀疑会有效果，但您需要检查是否要在两个宏中使用For Each itm In fld.Items。

我会在第一个宏中使用这样的东西：

For Each itm In fld.Items

由于您从工作表中的第1行开始，这意味着项目编号Dim InxMi As Long Dim itm As MailItem For InxMi = 1 To Fldr.Items.Count Set itm = Fldr.Items(InxMi) Output macro to worksheet Next和行号InxMi将相同，使第二个宏中的行和邮件项更容易匹配。如果在创建工作表和运行第二个宏之间没有对文件夹进行任何更改，则会有完全匹配。如果允许在两个宏之间添加和删除，则会更复杂，但行和邮件项目将按相同顺序排列，因此不会太复杂。

在第二个宏中，您需要从工作表的底行开始并从底部读取文件夹：

intRowCounter

文件夹中的邮件项目就像工作表中的行一样，如果删除一个，那么下面的所有邮件都会向上移动。如果向上移动工作表和文件夹，行和邮件将继续匹配，因为移动的邮件项目将低于当前位置。

你没有提供足够的细节让我更具体，但我希望上面有助于你进步。

Answer 2

嘿，为什么不从Excel文件中运行它并保持简单 -

基本示例

Option Explicit
Public Sub Example()
    Dim App As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim Inbox  As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Item As Object

    Dim iRow As Long
    Dim i As Long

    Dim RevdTime As String
    Dim Subject As String
    Dim Email As String

    Set App = New Outlook.Application
    Set olNs = App.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox
    Set Items = Inbox.Items

    iRow = 1 ' Row Count
    With Worksheets("Sheet1") ' Update with Correct Sheet Name

        Do Until IsEmpty(.Cells(iRow, 4))
            DoEvents

            If Cells(iRow, 4).Value = "Yes" Then
                RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
                Subject = .Cells(iRow, 2).Value ' Email Subject
                Email = .Cells(iRow, 1).Value ' Email Sender Name

                For i = Items.Count To 1 Step -1
                    Set Item = Items(i)

                    If Item.Class = olMail And _
                       Item.Subject = Subject And _
                       Item.ReceivedTime = RevdTime And _
                       Item.SenderEmailAddress = Email Then

                       Debug.Print Item.Subject ' Immediate Window
                       Debug.Print Item.ReceivedTime ' Immediate Window
                       Debug.Print Item.SenderEmailAddress ' Immediate Window

                       Item.UnRead = False
                       Item.Save
                       Item.Move olNs.GetDefaultFolder(olFolderInbox) _
                                              .Folders("No Response")
                    End If

                Next
            End If
            iRow = iRow + 1 ' Go to Next Row
        Loop
    End With

    Set App = Nothing
    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Items = Nothing
    Set Item = Nothing

End Sub

用于延迟绑定，请参阅

Option Explicit
Public Sub Example()
    Dim App As Object ' Outlook.Application
    Dim olNs As Object ' Outlook.Namespace
    Dim Inbox  As Object ' Outlook.MAPIFolder
    Dim SubFolder As Object ' Outlook.MAPIFolder
    Dim Items As Object ' Outlook.Items
    Dim Item As Object

    Dim iRow As Long
    Dim i As Long

    Dim RevdTime As String
    Dim Subject As String
    Dim Email As String

    Set App = CreateObject("Outlook.Application")
    Set olNs = App.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(6) '  olFolderInbox = 6
    Set Items = Inbox.Items

    iRow = 1 ' Row Count
    With Worksheets("Sheet1") ' Update with Correct Sheet Name

        Do Until IsEmpty(.Cells(iRow, 4))
            DoEvents

            If Cells(iRow, 4).Value = "Yes" Then
                RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
                Subject = .Cells(iRow, 2).Value ' Email Subject
                Email = .Cells(iRow, 1).Value ' Email Sender Name

                For i = Items.Count To 1 Step -1
                    Set Item = Items(i)

                    ' olMail - 43 = A MailItem object.
                    If Item.Class = 43 And _
                       Item.Subject = Subject And _
                       Item.ReceivedTime = RevdTime And _
                       Item.SenderEmailAddress = Email Then

                       Debug.Print Item.Subject ' Immediate Window
                       Debug.Print Item.ReceivedTime ' Immediate Window
                       Debug.Print Item.SenderEmailAddress ' Immediate Window

                       Item.UnRead = False
                       Item.Save
                       Item.Move olNs.GetDefaultFolder(6) _
                                        .Folders("No Response")
                    End If

                Next
            End If
            iRow = iRow + 1 ' Go to Next Row
        Loop
    End With

    Set App = Nothing
    Set olNs = Nothing
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set Items = Nothing
    Set Item = Nothing

End Sub

如果你想从Outlook运行它让我知道它不应该很难 -

Answer 3

我不知道从哪里开始修复代码所以我已经从头开始根据您对您的要求的最佳猜测。

我创建了一个名为OE.xlsx的文件，其中包含一个名为“Emails”的工作表，因为我避免使用默认工作表名称。我创建了一个带有值的标题行：“Sender”，“Subject”，“Received”，“Yes / No”和“Folder”。虽然我添加了“文件夹”，但我保留了你的序列。

我已将主宏命名为“Part1”和“Part2”，因此不会与其他宏混淆。所有其他宏都来自我的库。它们比你需要的更复杂，但我不想花时间编写更简单的东西。我建议你接受这些例程做评论所说的，而不是担心如何。

您还没有说过电子邮件的来源是否始终是同一个共享文件夹。我添加了文件夹列以允许多个共享文件夹。这意味着宏“Part2”不需要询问源文件夹，因为它从工作簿中获取此信息，尽管需要告知目标文件夹。

您没有说明如何创建在“是/否”列中设置值的公式。我会得到宏“Part1”来创建它们，我已经包含了一个例子，根据主题的长度设置“是”或“否”。

在宏“Part1”中，我使用“For Each FldrSrcNameArr ...”来获取来自两个文件夹的电子邮件的详细信息。如果您有固定的源文件夹，则可以使用类似的东西。如果您的要求更复杂，则需要提供更多详细信息。

宏“Part1”会在任何现有行下方添加新电子邮件。在宏“Part2”中，我清除了移动的电子邮件的行，然后将剩余的行写回工作表。我知道你的宏不能这样工作，但我想展示什么是可能的。如果不需要，可以轻松删除冗余代码。

我相信您应该很容易根据您的要求调整以下代码。如有必要，请回答问题。

Option Explicit
  ' Requires references to "Microsoft Excel nn.0 Object Library", "Microsoft Office
  ' nn.0 Object Library" and "Microsoft Scripting Runtime" Value of "nn" depends
  ' on version of Office being used.

  ' Technique for locating desktop from answer by Kyle:
  ' http://stackoverflow.com/a/17551579/973283

  Const ColEmailSender As Long = 1
  Const ColEmailSubject As Long = 2
  Const ColEmailReceived As Long = 3
  Const ColEmailYesNo As Long = 4
  Const ColEmailFolderName As Long = 5
  Const RowEmailDataFirst As Long = 2

Sub Part1()

  Dim ColEmailLast As Long
  Dim FldrSrc As Folder
  Dim FldrSrcName As String
  Dim FldrSrcNameArr As Variant
  Dim ItemCrnt As MailItem
  Dim ItemsSrc As Items
  Dim Path As String
  Dim RowEmailCrnt As Long
  Dim WbkEmail As Excel.Workbook
  Dim WshtEmail As Excel.Worksheet
  Dim xlApp As Excel.Application

  Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

  Set xlApp = Application.CreateObject("Excel.Application")
  xlApp.Visible = True         ' This slows your macro but helps during debugging
  With xlApp
    Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
  End With

  With WbkEmail
    Set WshtEmail = .Worksheets("Emails")
  End With
  Call FindLastRowCol(WshtEmail, RowEmailCrnt, ColEmailLast)

  ' Output first new row under any existing rows.
  RowEmailCrnt = RowEmailCrnt + 1

  For Each FldrSrcNameArr In VBA.Array(VBA.Array("test folders", "Test emails 1"), _
                                       VBA.Array("test folders", "Test emails 2"))

    Set FldrSrc = GetFldrRef(FldrSrcNameArr)
    FldrSrcName = Join(GetFldrNames(FldrSrc), "|")

    Set ItemsSrc = FldrSrc.Items
    ' This shows how to sort the emails by a property should this be helpful.
    ItemsSrc.Sort "[ReceivedTime]"        ' Ascending sort. Add ", False" for descending

    For Each ItemCrnt In ItemsSrc
      With ItemCrnt
        WshtEmail.Range(WshtEmail.Cells(RowEmailCrnt, 1), _
                        WshtEmail.Cells(RowEmailCrnt, 5)).Value = _
               VBA.Array(.SenderEmailAddress, .Subject, .ReceivedTime, _
                         "=IF(MOD(LEN(" & ColCode(ColEmailSubject) & RowEmailCrnt & "),2)=0,""Yes"",""No"")", _
                         FldrSrcName)
      End With
      RowEmailCrnt = RowEmailCrnt + 1
    Next

    Set ItemCrnt = Nothing
    Set ItemsSrc = Nothing
    Set FldrSrc = Nothing

  Next

  WbkEmail.Close SaveChanges:=True

  Set WshtEmail = Nothing
  Set WbkEmail = Nothing
  xlApp.Quit
  Set xlApp = Nothing

End Sub
Sub Part2()

  Dim ColEmailCrnt As Long
  Dim ColEmailLast As Long
  Dim FldrDest As Folder
  Dim FldrSrc As Folder
  Dim FldrSrcNameCrnt As String
  Dim FldrSrcNamePrev As String
  Dim InxIS As Long
  Dim ItemsSrc As Items
  Dim ItemsToMove As New Collection
  Dim Path As String
  Dim RngSortF As Range
  Dim RngSortR As Range
  Dim RngWsht As Range
  Dim RowEmailCrnt As Long
  Dim RowEmailLast As Long
  Dim WbkEmail As Excel.Workbook
  Dim WshtEmail As Excel.Worksheet
  Dim WshtEmailValues As Variant
  Dim xlApp As Excel.Application

  Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

  Set xlApp = Application.CreateObject("Excel.Application")
  xlApp.Visible = True         ' This slows your macro but helps during debugging
  With xlApp
    Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
  End With

  With WbkEmail
    Set WshtEmail = .Worksheets("Emails")
  End With
  Call FindLastRowCol(WshtEmail, RowEmailLast, ColEmailLast)

  With WshtEmail

    Set RngWsht = .Range(.Cells(1, 1), .Cells(RowEmailLast, ColEmailLast))
    Set RngSortF = .Range(.Cells(2, ColEmailFolderName), .Cells(RowEmailLast, ColEmailFolderName))
    Set RngSortR = .Range(.Cells(2, ColEmailReceived), .Cells(RowEmailLast, ColEmailReceived))

    ' Ensure rows are sequecnced by Folder name then Received
    ' For each folder, the items are sorted by ReceivedTime.  THis means the two lists
    ' are in the same sequence.
    With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=RngSortF, SortOn:=xlSortOnValues, _
                         Order:=xlAscending, DataOption:=xlSortNormal
      .SortFields.Add Key:=RngSortR, SortOn:=xlSortOnValues, _
                         Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange RngWsht
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With

    WshtEmailValues = RngWsht.Value

  End With

  FldrSrcNamePrev = ""
  Set FldrDest = GetFldrRef("test folders", "No response")

  For RowEmailCrnt = RowEmailDataFirst To RowEmailLast
    If WshtEmailValues(RowEmailCrnt, ColEmailYesNo) = "Yes" Then
      ' This row identifies an email that is to be moved
      FldrSrcNameCrnt = WshtEmailValues(RowEmailCrnt, ColEmailFolderName)
      If FldrSrcNamePrev <> FldrSrcNameCrnt Then
        ' New source folder
        Set FldrSrc = Nothing
        Set FldrSrc = GetFldrRef(Split(FldrSrcNameCrnt, "|"))
        FldrSrcNamePrev = FldrSrcNameCrnt
        Set ItemsSrc = FldrSrc.Items
        ItemsSrc.Sort "[ReceivedTime]"
        InxIS = 1
      End If
      ' Scan down mail items within sorted folder until reach or are past current email
      Do While InxIS <= ItemsSrc.Count
        If ItemsSrc(InxIS).ReceivedTime >= WshtEmailValues(RowEmailCrnt, ColEmailReceived) Then
          Exit Do
        End If
        InxIS = InxIS + 1
      Loop
      If InxIS <= ItemsSrc.Count Then
        If ItemsSrc(InxIS).ReceivedTime = WshtEmailValues(RowEmailCrnt, ColEmailReceived) And _
           ItemsSrc(InxIS).SenderEmailAddress = WshtEmailValues(RowEmailCrnt, ColEmailSender) And _
           ItemsSrc(InxIS).Subject = WshtEmailValues(RowEmailCrnt, ColEmailSubject) Then
          ' Have found email to be moved
          ' ItemsSrc is what VBA calls a Collection but most languages call a List.
          ' Moving a mail item to another folder removes an item from the Collection and
          ' upsets the index. Better to save a reference to the mail item and move it later.
          ItemsToMove.Add ItemsSrc(InxIS)
          ' Clear row in WshtEmailValues to indicate email moved
          For ColEmailCrnt = 1 To ColEmailLast
            WshtEmailValues(RowEmailCrnt, ColEmailCrnt) = ""
          Next
          InxIS = InxIS + 1
        ' Else  there is no mail item matching email row
        End If
      ' Else  no more emails in folder
      End If
    ' Else email row marled "No"
    End If
  Next

  ' Move mail items marked "Yes"
  Do While ItemsToMove.Count > 0
    ItemsToMove(1).Move FldrDest
    ItemsToMove.Remove 1
  Loop

  ' Upload worksheet values with rows for moved files cleared
  RngWsht.Value = WshtEmailValues

  ' Sort blank lines to bottom
  With WshtEmail
    With .Sort
      .Apply
    End With
  End With

  WbkEmail.Close SaveChanges:=True
  Set WshtEmail = Nothing
  Set WbkEmail = Nothing
  xlApp.Quit
  Set xlApp = Nothing
  'Set ItemCrnt = Nothing
  'Set ItemsSrc = Nothing
  'Set FldrSrc = Nothing

End Sub
' =================== Standard Outlook VBA routines ===================
Function GetFldrNames(ByRef Fldr As Folder) As String()

  ' * Fldr is a folder. It could be a store, the child of a store,
  '   the grandchild of a store or more deeply nested.
  ' * Return the name of that folder as a string array in the sequence:
  '    (0)=StoreName (1)=Level1FolderName (2)=Level2FolderName  ...

  ' 12Oct16  Coded
  ' 20Oct16  Renamed from GetFldrNameStr and amended to return a string array
  '          rather than a string

  Dim FldrCrnt As Folder
  Dim FldrNameCrnt As String
  Dim FldrNames() As String
  Dim FldrNamesRev() As String
  Dim FldrPrnt As Folder
  Dim InxFN As Long
  Dim InxFnR As Long

  Set FldrCrnt = Fldr
  FldrNameCrnt = FldrCrnt.Name
  ReDim FldrNamesRev(0 To 0)
  FldrNamesRev(0) = Fldr.Name
  ' Loop getting parents until FldrCrnt has no parent.
  ' Add names of Fldr and all its parents to FldrName as they are found
  Do While True
    Set FldrPrnt = Nothing
    On Error Resume Next
    Set FldrPrnt = Nothing   ' Ensure value is Nothing if following statement fails
    Set FldrPrnt = FldrCrnt.Parent
    On Error GoTo 0
    If FldrPrnt Is Nothing Then
      ' FldrCrnt has no parent
      Exit Do
    End If
    ReDim Preserve FldrNamesRev(0 To UBound(FldrNamesRev) + 1)
    FldrNamesRev(UBound(FldrNamesRev)) = FldrPrnt.Name
    Set FldrCrnt = FldrPrnt
  Loop

  ' Copy names to FldrNames in reverse sequence so they end up in the correct sequence
  ReDim FldrNames(0 To UBound(FldrNamesRev))
  InxFN = 0
  For InxFnR = UBound(FldrNamesRev) To 0 Step -1
    FldrNames(InxFN) = FldrNamesRev(InxFnR)
    InxFN = InxFN + 1
  Next

  GetFldrNames = FldrNames

End Function
Function GetFldrRef(ParamArray FolderNames() As Variant) As Folder

  ' FolderNames can be used as a conventional ParamArray: a list of values. Those
  ' Values must all be strings.
  ' Alternatively, its parameter can be a preloaded one-dimensional array of type
  ' Variant or String. If of type Variant, the values must all be strings.
  ' The first, compulsory, entry in FolderNames is the name of a Store.
  ' Each subsequent, optional, entry  in FolderNames is the name of a folder
  ' within the folder identified by the previous names.  Example calls:
  '  1) Set Fldr = GetFolderRef("outlook data file")
  '  2) Set Fldr = GetFolderRef("outlook data file", "Inbox", "Processed")
  '  3) MyArray = Array("outlook data file", "Inbox", "Processed")
  '     Set Fldr = GetFolderRef(MyArray)
  ' Return a reference to the folder identified by the names or Nothing if it
  ' does not exist

  Dim FolderNamesDenested() As Variant
  Dim ErrNum As Long
  Dim FldrChld As Folder
  Dim FldrCrnt As Folder
  Dim InxP As Long

  Call DeNestParamArray(FolderNamesDenested, FolderNames)

  If LBound(FolderNamesDenested) > UBound(FolderNamesDenested) Then
    ' No names specified
    Set GetFolderRef = Nothing
    Exit Function
  End If

  For InxP = 0 To UBound(FolderNamesDenested)
    If VarType(FolderNamesDenested(InxP)) <> vbString Then
      ' Value is not a string
      Debug.Assert False     ' Fatal error
      Set GetFolderRef = Nothing
      Exit Function
    End If
  Next

  Set FldrCrnt = Nothing
  On Error Resume Next
  Set FldrCrnt = Session.Folders(FolderNamesDenested(0))
  On Error GoTo 0
  If FldrCrnt Is Nothing Then
    ' Store name not recognised
    Debug.Print FolderNamesDenested(0) & " is not recognised as a store"
    Debug.Assert False     ' Fatal error
    Set GetFldrRef = Nothing
    Exit Function
  End If

  For InxP = 1 To UBound(FolderNamesDenested)
  Set FldrChld = Nothing
    On Error Resume Next
    Set FldrChld = FldrCrnt.Folders(FolderNamesDenested(InxP))
    On Error GoTo 0
    If FldrChld Is Nothing Then
      ' Folder name not recognised
      Debug.Print FolderNamesDenested(InxP) & " is not recognised as a folder within " & _
                  Join(GetFldrNames(FldrCrnt), "->")
      Debug.Assert False    ' Fatal error
      Set GetFldrRef = Nothing
      Exit Function
    End If
    Set FldrCrnt = FldrChld
    Set FldrChld = Nothing
  Next

  Set GetFldrRef = FldrCrnt

End Function
' =================== Standard VBA routines ===================
Sub DeNestParamArray(Denested() As Variant, ParamArray Original() As Variant)

  ' Each time a ParamArray is passed to a sub-routine, it is nested in a one
  ' element Variant array.  This routine finds the bottom level of the nesting and
  ' sets RetnValue to the values in the original parameter array so that other routines
  ' need not be concerned with this complication.

    '   Nov10  Coded
    '  6Aug16  Minor correction to documentation
    '  6Aug16  The previous version did not correctly handle an empty ParamArray.
    ' 15Oct16  replaced call of NumDim by call of NumberOfDimensions
    '          Tested that routine could denest a ParamArray that started as a reloaded
    '          array rather than a list of values in a call.

  Dim Bounds         As Collection
  Dim Inx1           As Long
  Dim Inx2           As Long
  Dim DenestedCrnt() As Variant
  Dim DenestedTemp() As Variant

  DenestedCrnt = Original
  ' Find bottom level of nesting
  Do While True
    If VarType(DenestedCrnt) < vbArray Then
      ' Have found a non-array element so must have reached the bottom level
      Debug.Assert False   ' Should have exited loop at previous level
      Exit Do
    End If
    Call NumberOfDimensions(Bounds, DenestedCrnt)
    ' There is one entry in Bounds per dimension in NestedCrnt
    ' Each entry is an array: Bounds(N)(0) = Lower bound of dimension N
    ' and Bounds(N)(1) = Upper bound of dimenssion N
    If Bounds.Count = 1 Then
      If Bounds(1)(0) > Bounds(1)(1) Then
        ' The original ParamArray was empty
        Denested = DenestedCrnt
        Exit Sub
      ElseIf Bounds(1)(0) = Bounds(1)(1) Then
        ' This is a one element array
        If VarType(DenestedCrnt(Bounds(1)(0))) < vbArray Then
          ' But it does not contain an array so the user only specified
          ' one value (a literal or a non-array variable)
          ' This is a valid exit from this loop
            'Debug.Assert False
            Exit Do
        End If
        ' The following sometimes crashed Outlook
        'DenestedCrnt = DenestedCrnt(Bounds(1)(0))
        If VarType(DenestedCrnt(Bounds(1)(0))) = vbArray + vbString Then
          ' DenestedCrnt(Bounds(1)(0))) is an array of strings.
          ' This is the array sought but it must be converted to an array
          ' of variants with lower bound = 0 before it can be returned.
          ReDim Denested(0 To UBound(DenestedCrnt(Bounds(1)(0))) - LBound(DenestedCrnt(Bounds(1)(0))))
          Inx2 = LBound(DenestedCrnt)
          For Inx1 = 0 To UBound(Denested)
            Denested(Inx1) = DenestedCrnt(Bounds(1)(0))(Inx2)
            Inx2 = Inx2 + 1
          Next
          Exit Sub
        End If
        DenestedTemp = DenestedCrnt(Bounds(1)(0))
        DenestedCrnt = DenestedTemp
      Else
        ' This is a one-dimensional, non-nested array
        ' This is the usual exit from this loop
        Exit Do
      End If
    Else
      ' This is an array but not a one-dimensional array
      ' There is no code for this situation
      Debug.Assert False
      Exit Do
    End If
  Loop

  ' Have found bottom level array.  Save contents in Return array.
  If LBound(DenestedCrnt) <> 0 Then
    ' A ParamArray should have a lower bound of 0.  Assume the ParamArray
    ' was loaded with a 1D array that did not have a lower bound of 0.
    ' Build Denested so it has standard lbound
    ReDim Denested(0 To UBound(DenestedCrnt) - LBound(DenestedCrnt))
    Inx2 = LBound(DenestedCrnt)
    For Inx1 = 0 To UBound(Denested)
      Denested(Inx1) = DenestedCrnt(Inx2)
      Inx2 = Inx2 + 1
    Next
  Else
    Denested = DenestedCrnt
  End If

End Sub
Function NumberOfDimensions(ByRef Bounds As Collection, _
                                   ParamArray Params() As Variant) As Long

  ' Example calls of this routine are:
  '    NumDim = NumberOfDimensions(Bounds, MyArray)
  ' or NumDim = NumberOfDimensions(Bounds, Worksheets("Sheet1").Range("D4:E20"))

  ' * Returns the number of dimensions of Params(LBound(Params)).  Param is a ParamArray.
  '   MyArray, in the example call, is held as the first element of array Params.  That is
  '   it is held as Params(LBound(Params)) or Params(LBdP) where LBdP = LBound(Params).
  ' * If the array to test is a regular array, then, in exit, for each dimension, the lower
  '   and upper bounds are recorded in Bounds. Entries in Bounds are zero-based arrays
  '   with two entries: lower bound and upper bound.
  ' * If the array is a worksheet range, the lower bound values in Bounds are 1 and the
  '   upper bound values are the number of rows (first entry in Bounds) or columns (second
  '   entry in Bounds)
  ' * The collection Bounds is of most value to routines that can be pased an array as
  '   a parameter but does not know if that array is a regular array or a range. The values
  '   returned in Bounds means that whether the test array is a regular array or a range,
  '   its elements can be accessed so:
  '      For InxDim1 = Bounds(0)(0) to Bounds(0)(1)
  '        For InxDim2 = Bounds(1)(0) to Bounds(1)(1)
  '          :  :  :
  '        Next
  '      Next

  ' If there is an official way of determining the number of dimensions, I cannot find it.

  ' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
  ' By trapping that failure it can determine the last test that did not fail.

  ' *  Params() is a ParamArray because it allows the passing of arrays of any type.
  ' *  The array to be tested in not Params but Params(LBound(Params)).
  ' *  The routine does not check for more than one parameter.  If the call was
  '    NumDim(Bounds, MyArray1, MyArray2), it would ignore MyArray2.

  '   Jun10  Coded
  '   Jul10  Documentation added
  ' 13Aug16  Return type changed from Integer
  ' 14Aug16  Upgraded to handle ranges. VarType reports a worksheet range as an
  '          array but LBound and UBound do not recognise a range as an array.
  '          Added Bounds to report bounds of both regular arrays and ranges.
  ' 14Aug16  Renamed from NumDim.
  ' 14Aug16  Switched between different approaches as built up understanding of
  '          bounds of ranges as documented elsewhere in macro.
  ' 15Aug16  Switched back to use of TestArray.

  Dim InxDim As Long
  Dim Lbd As Long
  Dim LBdC As Long
  Dim LBdP As Long
  Dim LBdR As Long
  Dim NumDim As Long
  Dim TestArray As Variant
  'Dim TestResult As Long
  Dim UBdC As Long
  Dim UBdR As Long

  Set Bounds = New Collection

  If VarType(Params(LBound(Params))) < vbArray Then
    ' Variable to test is not an array
    NumberOfDimensions = 0
    Exit Function
  End If

  On Error Resume Next

  LBdP = LBound(Params)

  TestArray = Params(LBdP)

  NumDim = 1
  Do While True
    Lbd = LBound(TestArray, NumDim)
    'Lbd = LBound(Params(LBdP), NumDim)
    If Err.Number <> 0 Then
      If NumDim > 1 Then
        ' Only known reason for failing is because array
        ' does not have NumDim dimensions
        NumberOfDimensions = NumDim - 1
        On Error GoTo 0
        For InxDim = 1 To NumberOfDimensions
          Bounds.Add VBA.Array(LBound(TestArray, InxDim), UBound(TestArray, InxDim))
          'Bounds.Add VBA.Array(LBound(Params(LBdP), InxDim), _
                               UBound(Params(LBdP), InxDim))
        Next
        Exit Function
      Else
        Err.Clear
        Bounds.Add VBA.Array(TestArray.Row, TestArray.Rows.Count - TestArray.Row + 1)
        Bounds.Add VBA.Array(TestArray.Column, TestArray.Columns.Count - TestArray.Column + 1)
        If Err.Number <> 0 Then
          NumberOfDimensions = 0
          Exit Function
        End If
        On Error GoTo 0
        NumberOfDimensions = 2
        Exit Function
      End If

    End If
    NumDim = NumDim + 1
  Loop

End Function
' =================== Standard Excel routines ===================
Function ColCode(ByVal ColNum As Long) As String

  ' Convert column number to column code
  ' For example: 1 -> A, 2 -> B, 26 -> Z and 27 -> AA

  Dim PartNum As Long

  '  3Feb12  Adapted to handle three character codes.
  ' 28Oct16  Renamed ColCode to match ColNum.

  If ColNum = 0 Then
    Debug.Assert False
    ColCode = "0"
  Else
    ColCode = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      ColCode = Chr(65 + PartNum) & ColCode
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

End Function
Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                   ByRef ColLast As Long)

  ' Sets RowLast and ColLast to the last row and column with a value
  ' in worksheet Wsht

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not.
  ' I had known the Find would missed merged cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UsedRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If not Rng Is Nothing Then
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If not Rng Is Nothing Then
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          Debug.Assert False
          ' Column after ColLastFind has value
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

  End Sub

Excel中的Outlook电子邮件然后使用Outlook VBA标记为已读并移至文件夹

3 个答案: