下面的代码距离完整的解决方案还有很长的路要走。它的目的是让您开始思考您的系统将如何运作。
展望未来，我设想需要一个名为HumanActionRequired.txt的文本文件。第 10 行代码是一个常量，指定将在其中创建此文件的文件夹。您必须将“C:\DataArea\Play”替换为系统上文件夹的名称。您可能希望重命名文件：见第六行。
虽然我设想这个文件是错误消息的目的地，但我在这里使用它来列出收件箱中消息的详细信息。我只输出了一小部分可用属性，但它应该让你思考什么是可能的。
下面的代码属于 OutLook 中的一个模块：
- 打开 Outlook。
- 选择工具、宏和安全。您需要将安全级别设置为“中”。稍后，您可以与 IT 部门讨论获取宏的受信任状态，但现在就可以了。
- 选择工具、宏和 Visual Basic 编辑器或单击 Alt+F11。
- 您可能会在左侧看到 Project Explorer（如果没有，则显示 Control+R）。如果您从未创建过 Outlook 宏，则右侧区域将为灰色。
- 选择插入、模块。灰色区域将变为白色，上面的代码区域和下面的立即窗口。
- 将下面的代码复制到代码区。
将光标定位在宏LocateInterestingEmails()中，然后单击 F5。您将被警告宏正在尝试访问您的电子邮件。勾选允许访问并选择时间限制，然后单击是。该宏会将 Inbox 中电子邮件的选定属性写入文件HumanActionRequired.txt。
Option Explicit
Sub LocateInterestingEmails()
Dim ErrorDescription As String
Dim ErrorNumber As Long
Static ErrorCount As Integer
Const FileCrnt As String = "HumanActionRequired.txt"
Dim FolderTgt As MAPIFolder
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim OutputFileNum As Long
Const PathCrnt As String = "C:\DataArea\Play"
ErrorCount = 0
OutputFileNum = 0
Restart:
' On Error GoTo CloseDown
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileCrnt For Append Lock Write As #OutputFileNum
For InxItemCrnt = 1 To FolderTgt.Items.Count
With FolderTgt.Items.Item(InxItemCrnt)
If .Class = olMail Then
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Subject: " & .Subject
Print #OutputFileNum, "Sender: " & .SenderEmailAddress
Print #OutputFileNum, "Recipient: " & .To
Print #OutputFileNum, "Date sent: " & .SentOn
If .Attachments.Count > 0 Then
Print #OutputFileNum, "Attachments:"
For InxAttachCrnt = 1 To .Attachments.Count
Print #OutputFileNum, " " & .Attachments(InxAttachCrnt).DisplayName
Next
End If
End If
End With
Next
CloseDown:
ErrorNumber = Err.Number
ErrorDescription = Err.Description
Err.Clear
Set FolderTgt = Nothing
If ErrorNumber <> 0 Then
' Here because of an error
If OutputFileNum = 0 Then
' Output file not open
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileCrnt For Append Lock Write As #OutputFileNum
End If
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Error at " & Now()
Print #OutputFileNum, "Error number = " & ErrorNumber & _
" description = " & ErrorDescription
End If
If OutputFileNum <> 0 Then
' File open
Close OutputFileNum
OutputFileNum = 0
End If
End Sub
版本 2
此版本包括第一个版本中的代码以及：
- 它会打开一个现有工作簿，其中保存有关找到的 Excel 附件的信息。
xls?它根据收到的日期/时间和发件人的姓名识别带有扩展名的附件并将其保存到光盘中。- 它会打开每个保存的附件。对于已保存附件中的每个工作表，它会在现有工作簿中创建一行，其中包含文件名、发件人姓名和电子邮件地址、工作表名称和单元格 A1 的值。
我认为这段代码不会直接有用，但它显示了如何保存附件和打开工作簿以读取或写入，我相信你会需要这些。
我知道唯一丢失的代码是：
- 将已处理的电子邮件移动到保存文件夹。
- 生成回复电子邮件。
但是，根据您希望如何自动化整个过程，可能需要更多代码。
下面的代码并不像我想要的那样整洁。在您完全理解之前，我不想再添加任何内容。我还希望更好地了解您计划发送的电子邮件以及整个过程所需的自动化。
对您不理解的代码的任何部分提出问题。
Option Explicit
Sub LocateInterestingEmails()
' I use constants to indentify columns in worksbooks because if I move the
' column I only need to update the constant to update the code. I said the
' same in a previous answer and some one responded that they preferred
' Enumerations. I use Enumerations a lot but I still prefer to use constants
' for column numbers.
Const ColSumFileNameSaved As String = "A"
Const ColSumFileNameOriginal As String = "B"
Const ColSumSenderName As String = "C"
Const ColSumSenderEmail As String = "D"
Const ColSumSheet As String = "E"
Const ColSumCellA1 As String = "F"
' You must change the value of this constant to the name of a folder on your
' computer. All file created by this macro are written to this folder.
Const PathCrnt As String = "C:\DataArea\Play"
' I suggest you change the values of these constants to
' something that you find helpful.
Const FileNameHAR As String = "HumanActionRequired.txt"
Const FileNameSummary As String = "Paolo.xls"
Dim CellValueA1 As Variant
Dim ErrorDescription As String
Dim ErrorNumber As Long
Dim FileNameReqDisplay As String
Dim FileNameReqSaved As String
Dim FolderTgt As MAPIFolder
Dim InxAttachCrnt As Long
Dim InxItemCrnt As Long
Dim InxSheet As Long
Dim OutputFileNum As Long
Dim Pos As Long
Dim ReceivedTime As Date
Dim RowSummary As Long
Dim SenderName As String
Dim SenderEmail As String
Dim SheetName As String
Dim XlApp As Excel.Application
Dim XlWkBkRequest As Excel.Workbook
Dim XlWkBkSummary As Excel.Workbook
' Ensure resource controls are null before macro does anything that can cause
' an error so error handler knows if the resource is to be released.
OutputFileNum = 0
Set XlApp = Nothing
Set XlWkBkRequest = Nothing
Set XlWkBkSummary = Nothing
' Open own copy of Excel
Set XlApp = Application.CreateObject("Excel.Application")
With XlApp
.Visible = True ' This slows your macro but helps during debugging
' Open workbook to which a summary of workbooks extracted will be written
Set XlWkBkSummary = .Workbooks.Open(PathCrnt & "\" & FileNameSummary)
With XlWkBkSummary.Worksheets("Summary")
' Set RowSummary to one more than the last currently used row
RowSummary = .Cells(.Rows.Count, ColSumFileNameSaved).End(xlUp).Row + 1
End With
End With
Restart:
' I prefer to have my error handler switched off during development so the
' macro stops on the faulty statement. If you remove the comment mark from
' the On Error statement then any error will cause the code to junp to label
' CloseDown which is at the bottom of this routine.
' On Error GoTo CloseDown
' Gain access to InBox
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
' Open text file for output. I envisage this file being used for error
' messages but for this version of the macro I write a summary of the
' contents of the InBox to it.
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileNameHAR For Output Lock Write As #OutputFileNum
For InxItemCrnt = 1 To FolderTgt.Items.Count
With FolderTgt.Items.Item(InxItemCrnt)
If .Class = olMail Then
' Only interested in mail items. Most of the other items will be
' meeting requests.
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Subject: " & .Subject
' Currently we are within With FolderTgt.Items.Item(InxItemCrnt).
' Values from this mail item are to be written to a workbook
' for which another With will be required. Copy values to
' variables for they are accessable.
' Note: XlApp.XlWkBkSummary.Worksheets("Summary")
' .Cells(RowSummary, ColSumFileNameOriginal).Value = _
' FolderTgt.Items.Item(InxItemCrnt).Attachments(InxAttachCrnt) _
' .DisplayName
' is legal but is not very clear. Code is much clearer will full use
' of With stateents even if it means values must be copied to variable.
SenderName = .SenderName
SenderEmail = .SenderEmailAddress
ReceivedTime = .ReceivedTime
Print #OutputFileNum, "SenderName: " & SenderName
Print #OutputFileNum, "SenderAddr: " & SenderEmail
Print #OutputFileNum, "Received: " & ReceivedTime
Print #OutputFileNum, "Date sent: " & .SentOn
If .Attachments.Count > 0 Then
Print #OutputFileNum, "Attachments:"
For InxAttachCrnt = 1 To .Attachments.Count
With .Attachments(InxAttachCrnt)
' I cannot find an example for which the
' DisplayName and FileName are different
FileNameReqDisplay = .DisplayName
Print #OutputFileNum, " " & FileNameReqDisplay & "|" & .FileName
Pos = InStrRev(FileNameReqDisplay, ".")
' With ... End With and If ... End If must be properly nested.
' Within the If below I want access to the attachment and to the
' workbook. Hence the need to terminate the current With and then
' immediately start it again within the If ... End If block.
End With
If LCase(Mid(FileNameReqDisplay, Pos + 1, 3)) = "xls" Then
With .Attachments(InxAttachCrnt)
' Save the attachment with a unique name. Note this will only be
' unique if you do not save the same attachment again.
FileNameReqSaved = _
Format(ReceivedTime, "yyyymmddhhmmss") & " " & SenderName
.SaveAsFile PathCrnt & "\" & FileNameReqSaved
End With
' Open the saved attachment
Set XlWkBkRequest = _
XlApp.Workbooks.Open(PathCrnt & "\" & FileNameReqSaved)
With XlWkBkRequest
'Examine every worksheet in workbook
For InxSheet = 1 To .Worksheets.Count
With .Worksheets(InxSheet)
' Save sheet name and a sample value
SheetName = .Name
CellValueA1 = .Cells(1, 1).Value
End With
' Save information about this sheet and its workbook
With XlWkBkSummary.Worksheets("Summary")
.Cells(RowSummary, ColSumFileNameSaved).Value = _
FileNameReqSaved
.Cells(RowSummary, ColSumFileNameOriginal).Value = _
FileNameReqDisplay
.Cells(RowSummary, ColSumSenderName).Value = SenderName
.Cells(RowSummary, ColSumSenderEmail).Value = SenderEmail
.Cells(RowSummary, ColSumSheet).Value = SheetName
.Cells(RowSummary, ColSumCellA1).Value = CellValueA1
RowSummary = RowSummary + 1
End With ' XlWkBkSummary.Worksheets("Summary")
Next InxSheet
.Close SaveChanges:=False
Set XlWkBkRequest = Nothing
End With ' XlWkBkRequest
End If
Next
End If
End If
End With
Next
CloseDown:
ErrorNumber = Err.Number
ErrorDescription = Err.Description
Err.Clear
Set FolderTgt = Nothing
If ErrorNumber <> 0 Then
' Have reached here because of an error
If OutputFileNum = 0 Then
' Output file not open
OutputFileNum = FreeFile
Open PathCrnt & "\" & FileNameHAR For Append Lock Write As #OutputFileNum
End If
Print #OutputFileNum, "-----------------------------"
Print #OutputFileNum, "Error at " & Now()
Print #OutputFileNum, "Error number = " & ErrorNumber & _
" description = " & ErrorDescription
End If
' Release resources
If OutputFileNum <> 0 Then
' File open
Close OutputFileNum
OutputFileNum = 0
End If
If Not (XlWkBkRequest Is Nothing) Then
XlWkBkRequest.Close SaveChanges:=False
Set XlWkBkRequest = Nothing
End If
If Not (XlWkBkSummary Is Nothing) Then
XlWkBkSummary.Close SaveChanges:=True
Set XlWkBkSummary = Nothing
End If
If Not (XlApp Is Nothing) Then
XlApp.Quit
Set XlApp = Nothing
End If
End Sub