我试图将一段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
答案 0 :(得分：0)
设置objAttachments = Outlook.Attachments的语法不正确。
请稍后删除该行。
Set objAttachments = objMsg.Attachments