VBA Outlook：获取电子邮件并导出到excel并保存附件

Question

我试图放在一起执行以下操作的一段VBA代码。

首先，它在我的收件箱文件夹中查找帐户NewSuppliers@Hewden.co.uk中的所有电子邮件，其中主题包含某些关键字。

其次，它在我的收件箱文件夹CreditChecks@Hewden.co.uk中查找所有电子邮件，其中主题包含某些关键字。

然后将某些数据逐行导出到excel。

除我从CreditChecks@Hewden.co.uk收件箱中导出的电子邮件外，此方法工作正常，我只想导出包含pdf附件的电子邮件并将此附件保存在目录中，并将每个单独的pdf文档放置在文件夹中与pdf文件同名。

我已经分别测试了我的保存附件和导出电子邮件脚本，它们可以正常工作，但是当我将它们放在一起时，出现错误提示

找不到方法或对象

Set objAttachments = Outlook.Attachments

有人可以帮助我让我的代码执行我需要做的事情吗？ 提前致谢

这是我的代码：

'On the next line edit the path to the spreadsheet you want to export to
    Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\NewSupplierSet-Up.xls"
    'On the next line edit the name of the sheet you want to export to
    Const SHEET_NAME = "Validations"
    Const SHEET_NAME2 = "BankSetup"
    Const SHEET_NAME3 = "CreditChecks"
    Const MACRO_NAME = "Export Messages to Excel (Rev 7)"



    Private Sub Application_Startup()
        Dim olkMsg As Object, _
        olkMsg2 As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            excWks2 As Object, _
             excWks3 As Object, _
            intRow As Integer, _
            intRow2 As Integer, _
            intRow3 As Integer, _
            intExp As Integer, _
            intVersion As Integer
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
        Set excWks = excWkb.Worksheets(SHEET_NAME)
        Set excWks2 = excWkb.Worksheets(SHEET_NAME2)
        Set excWks3 = excWkb.Worksheets(SHEET_NAME3)
        intRow = excWks.UsedRange.Rows.Count + 1
        intRow2 = excWks2.UsedRange.Rows.Count + 1
        intRow3 = excWks3.UsedRange.Rows.Count + 1
       'Write messages to spreadsheet
        Dim ns As Outlook.NameSpace
        Dim Items As Outlook.Items
        Dim Items2 As Outlook.Items
        Dim objAttachments As Outlook.Attachments
        Dim objMsg As Outlook.MailItem 'Object
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolderPath As String
        Dim strDeletedFiles As String
        Dim withParts As String
        Dim withoutParts As String
        ' Get the MAPI Namespace
        Set ns = Application.GetNamespace("MAPI")
        ' Get the Items for the Inbox in the specified account
        Set Items = ns.Folders("New Suppliers").Folders("Inbox").Items
        Set Items2 = ns.Folders("Credit Checks").Folders("Inbox").Items
        Set objAttachments = Outlook.Attachments

        ' Start looping through the items
        For Each olkMsg In Items
                'Only export messages, not receipts or appointment requests, etc.
                If olkMsg.class = olMail Then
                If olkMsg.Subject Like "Accept: New Supplier Request*" Or olkMsg.Subject Like "Reject: New Supplier Request*" Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
                        Dim LResult As String
                        LResult = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
                        LResult = Left(LResult, InStrRev(LResult, "@") - 1)
                        excWks.Cells(intRow, 2) = LResult
                        excWks.Cells(intRow, 3) = olkMsg.VotingResponse
                        Dim s As String
                        s = olkMsg.Subject
                        Dim indexOfName As Integer
                        indexOfName = InStr(1, s, "Reference: ")
                        Dim finalString As String
                        finalString = Right(s, Len(s) - indexOfName - 10)
                        excWks.Cells(intRow, 4) = finalString
                        intRow = intRow + 1
                    End If
                End If


                If olkMsg.class = olMail Then
                If olkMsg.Subject Like "Complete: Bank Details Set-Up for New Supplier*" Or olkMsg.Subject Like "Incomplete: Bank Details Set-Up for New Supplier*" Then
                        'Add a row for each field in the message you want to export
                        excWks2.Cells(intRow2, 1) = olkMsg.ReceivedTime
                        Dim LResult2 As String
                        LResult2 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
                        LResult2 = Left(LResult2, InStrRev(LResult2, "@") - 1)
                        excWks2.Cells(intRow2, 2) = LResult2
                        excWks2.Cells(intRow2, 3) = olkMsg.VotingResponse
                        Dim s2 As String
                        s2 = olkMsg.Subject
                        Dim indexOfName2 As Integer
                        indexOfName2 = InStr(1, s2, "Reference: ")
                        Dim finalString2 As String
                        finalString2 = Right(s2, Len(s2) - indexOfName2 - 10)
                        excWks2.Cells(intRow2, 4) = finalString2
                        intRow2 = intRow2 + 1
                    End If
                End If

                Next

                strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.Count

            For Each olkMsg2 In Items2
            If olkMsg2.class = olMail Then
            If olkMsg2.Subject Like "RE: New Supplier Credit*" Then
            If lngCount > 0 Then
            For i = lngCount To 1 Step -1
            strFile = objAttachments.item(i).FileName
            If Right(strFile, 3) = "pdf" Then

        ' Combine with the path to the Temp folder.
        withParts = strFile
        withoutParts = Replace(withParts, ".pdf", "")

        strFile = strFolderPath & withoutParts & "\" & strFile

        ' Save the attachment as a file.
        objAttachments.item(i).SaveAsFile strFile


                        'Add a row for each field in the message you want to export
                        excWks3.Cells(intRow3, 1) = olkMsg2.ReceivedTime
                        Dim LResult3 As String
                        LResult3 = Replace(GetSMTPAddress(olkMsg2, intVersion), ".", " ")
                        LResult3 = Left(LResult3, InStrRev(LResult3, "@") - 1)
                        excWks3.Cells(intRow3, 2) = LResult3
                        excWks3.Cells(intRow3, 3) = "Complete"
                        excWks3.Cells(intRow3, 4) = "File Attached"
                        Dim s3 As String
                        s3 = olkMsg2.Subject
                        Dim indexOfName3 As Integer
                        indexOfName3 = InStr(1, s3, "Reference: ")
                        Dim finalString3 As String
                        finalString3 = Right(s3, Len(s3) - indexOfName3 - 10)
                        excWks3.Cells(intRow3, 5) = finalString3
                        excWks3.Cells(intRow3, 6) = "File Path"
                        intRow3 = intRow3 + 1
                End If

                Next i
                End If
                End If
                End If

Next


                    Set olkMsg = Nothing
                    Set olkMsg2 = Nothing
        excWkb.Close True
        Set excWks = Nothing
        Set excWks2 = Nothing
        Set excWks3 = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing

        On Error GoTo ErrHandle

ErrHandle:

Resume Next

End Sub


    Private Function GetSMTPAddress(item As Outlook.MailItem, intOutlookVersion As Integer) As String
        Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
        On Error Resume Next
        Select Case intOutlookVersion
            Case Is < 14
                If item.SenderEmailType = "EX" Then
                    GetSMTPAddress = SMTP2007(item)
                Else
                    GetSMTPAddress = item.SenderEmailAddress
                End If
            Case Else
                Set olkSnd = item.Sender
                If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                    Set olkEnt = olkSnd.GetExchangeUser
                    GetSMTPAddress = olkEnt.PrimarySmtpAddress
                Else
                    GetSMTPAddress = item.SenderEmailAddress
                End If
        End Select
        On Error GoTo 0
        Set olkPrp = Nothing
        Set olkSnd = Nothing
        Set olkEnt = Nothing
    End Function

    Function GetOutlookVersion() As Integer
        Dim arrVer As Variant
        arrVer = Split(Outlook.Version, ".")
        GetOutlookVersion = arrVer(0)
    End Function

    Function SMTP2007(olkMsg As Outlook.MailItem) As String
        Dim olkPA As Outlook.PropertyAccessor
        On Error Resume Next
        Set olkPA = olkMsg.PropertyAccessor
        SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
        On Error GoTo 0
        Set olkPA = Nothing
    End Function

Answer 1

设置objAttachments = Outlook.Attachments不是正确的语法。

稍后删除该行即可。

 Set objAttachments = objMsg.Attachments