对于大量的代码我很抱歉，但我现在已经查看了很多天来尝试解决这个问题。基本上，这个代码在我启动时运行在outlook中。它会从不同的收件箱中导出不同类型的电子邮件，其中存在不同的主题标题。
它收集主题标题的部分内容和电子邮件正文的部分内容，并将其作为文本导出到我的Excel电子表格中。
我遇到的问题是此代码实际上工作正常，它用于在后台打开Excel电子表格并将信息导出到相关列中的新行。完成后，它会自动保存电子表格并关闭。
现在，由于某种原因，它会完成所有这些但不会关闭电子表格，Excel会在Windows任务管理器中显示为正在运行的服务。情况并非如此，电子表格应保存更改并自动关闭。
'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\Supplier SetUps & Amendments.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 SHEET_NAME4 = "Statistics"
Const MACRO_NAME = "Export Messages to Excel (Rev 7)"
Const xlContinuous As Integer = 1
Const vbBlack As Integer = 0
Const xlThin As Integer = 2
Dim olkMsg As Object, _
olkMsg2 As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
excWks2 As Object, _
excWks3 As Object, _
excWks4 As Object, _
intRow As Integer, _
intRow2 As Integer, _
intRow3 As Integer, _
intRow4 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)
Set excWks4 = excWkb.Worksheets(SHEET_NAME4)
intRow = excWks.UsedRange.Rows.Count + 1
intRow2 = excWks2.UsedRange.Rows.Count + 1
intRow3 = excWks3.UsedRange.Rows.Count + 1
intRow4 = excWks4.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
' Start looping through the items
For Each olkMsg In Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.UnRead = True Then
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Accept: (Update) New Supplier Request*" Or olkMsg.Subject Like "Accept: (Approval Required) - New Supplier Request*" Or olkMsg.Subject Like "Reject: (Approval Required) - New Supplier Request*" Or olkMsg.Subject Like "Accept: (IMPORTANT REMINDER!) - 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
olkMsg.UnRead = False
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
olkMsg.UnRead = False
End If
End If
If olkMsg.class = olMail Then
If olkMsg.Subject Like "New Supplier Request - Reference:*" Then
'Add a row for each field in the message you want to export
Dim FSO As Object
Dim FolderPath As String
Set FSO = CreateObject("scripting.filesystemobject")
Dim b4 As String
Dim strNewFolderName As String
If TypeName(olkMsg) = "MailItem" Then
b4 = olkMsg.Body
Dim indexOfNameb As Integer
indexOfNameb = InStr(UCase(b4), UCase("Company name: "))
Dim indexOfNamec As Integer
indexOfNamec = InStr(UCase(b4), UCase("Company number: "))
Dim finalStringb As String
finalStringb = Mid(b4, indexOfNameb, indexOfNamec - indexOfNameb)
LResult336 = Replace(finalStringb, "Company Name: ", "")
Dim LResult21 As String
Dim LResult211 As String
Dim LResult2113 As String
LResult21 = Trim(LResult336)
LResult211 = Replace(LResult21, Chr(10), "")
LResult2113 = Replace(LResult211, Chr(13), "")
excWks4.Cells(intRow4, 2) = Trim(LResult2113)
FolderPath = "\\uksh000-file06\purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113)
If FSO.FolderExists(FolderPath) = False Then
Dim strDir As String
strDir = "\\uksh000-file06\purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113)
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
FileCopy "X:\New_Supplier_Set_Ups_&_Audits\assets\audit.xls", "X:\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\audit.xls"
Else
MsgBox "Directory exists."
End If
Else
End If
End If
Dim b5 As String
If TypeName(olkMsg) = "MailItem" Then
b5 = olkMsg.Body
Dim indexOfNameb2 As Integer
indexOfNameb2 = InStr(UCase(b5), UCase("Company Number: "))
Dim indexOfNamec2 As Integer
indexOfNamec2 = InStr(UCase(b5), UCase("VAT Number: "))
Dim finalStringb2 As String
finalStringb2 = Mid(b5, indexOfNameb2, indexOfNamec2 - indexOfNameb2)
LResult3362 = Replace(finalStringb2, "Company Number: ", "")
excWks4.Cells(intRow4, 3) = LResult3362
End If
Dim b6 As String
If TypeName(olkMsg) = "MailItem" Then
b6 = olkMsg.Body
Dim indexOfNameb3 As Integer
indexOfNameb3 = InStr(UCase(b6), UCase("VAT Number: "))
Dim indexOfNamec3 As Integer
indexOfNamec3 = InStr(UCase(b6), UCase("Contact Name: "))
Dim finalStringb3 As String
finalStringb3 = Mid(b6, indexOfNameb3, indexOfNamec3 - indexOfNameb3)
LResult3363 = Replace(finalStringb3, "VAT Number: ", "")
excWks4.Cells(intRow4, 4) = LResult3363
End If
Dim l As String
excWks4.Cells(intRow4, 5) = Trim(excWks4.Cells(intRow4, 5))
l = excWks4.Cells(intRow4, 5).Address
excWks4.Cells(intRow4, 6).FormulaArray = "=IF(ISERROR(INDEX('Up'!$A$1:$G$10004,SMALL(IF(LEFT('Up'!$B$1:$B$10004,5)=LEFT(" & l & ",5),ROW($B$1:$B$10004)),ROW(1:1)),6)),""ZZZ"",INDEX('Up'!$A$1:$G$10004,SMALL(IF(LEFT('Up'!$B$1:$B$10004,5)=LEFT(" & l & ",5),ROW($B$1:$B$10004)),ROW(1:1)),6))"
Dim b7 As String
If TypeName(olkMsg) = "MailItem" Then
b7 = olkMsg.Body
Dim indexOfNameb4 As Integer
indexOfNameb4 = InStr(UCase(b7), UCase("Description of the provisional Supplier:"))
Dim indexOfNamec4 As Integer
indexOfNamec4 = InStr(UCase(b7), UCase("Current Status: "))
Dim finalStringb4 As String
Dim LResult3364 As String
Dim LResult33644 As String
Dim LResult336445 As String
finalStringb4 = Mid(b7, indexOfNameb4, indexOfNamec4 - indexOfNameb4)
LResult3364 = Replace(finalStringb4, "Description of the provisional Supplier:", "")
LResult33644 = Replace(LResult3364, Chr(10), "")
LResult336445 = Replace(LResult33644, Chr(13), "")
Dim TrimString As String
TrimString = Trim(LResult336445)
excWks4.Cells(intRow4, 5) = Trim(TrimString)
End If
Dim b77 As String
If TypeName(olkMsg) = "MailItem" Then
b77 = olkMsg.Body
Dim indexOfNameb47 As Integer
indexOfNameb47 = InStr(UCase(b77), UCase("Contact Number: "))
Dim indexOfNamec47 As Integer
indexOfNamec47 = InStr(UCase(b77), UCase("Contact Email: "))
Dim finalStringb47 As String
Dim LResult33647 As String
Dim LResult336447 As String
Dim LResult3364457 As String
finalStringb47 = Mid(b77, indexOfNameb47, indexOfNamec47 - indexOfNameb47)
LResult33647 = Replace(finalStringb47, "Contact Number: ", "")
LResult336447 = Replace(LResult33647, Chr(10), "")
LResult3364457 = Replace(LResult336447, Chr(13), "")
Dim TrimString7 As String
TrimString7 = Trim(LResult3364457)
excWks4.Cells(intRow4, 11) = Trim(TrimString7)
End If
Dim b777 As String
If TypeName(olkMsg) = "MailItem" Then
b777 = olkMsg.Body
Dim indexOfNameb477 As Integer
indexOfNameb477 = InStr(UCase(b777), UCase("Contact Email: "))
Dim indexOfNamec477 As Integer
indexOfNamec477 = InStr(UCase(b777), UCase("Case Reference: "))
Dim finalStringb477 As String
Dim LResult336477 As String
Dim LResult3364477 As String
Dim LResult33644577 As String
finalStringb477 = Mid(b777, indexOfNameb477, indexOfNamec477 - indexOfNameb477)
LResult336477 = Replace(finalStringb477, "Contact Email: ", "")
LResult3364477 = Replace(LResult336477, Chr(10), "")
LResult33644577 = Replace(LResult3364477, Chr(13), "")
Dim TrimString77 As String
TrimString77 = Trim(LResult33644577)
excWks4.Cells(intRow4, 12) = Trim(TrimString77)
End If
Dim b7777 As String
If TypeName(olkMsg) = "MailItem" Then
b7777 = olkMsg.Body
Dim indexOfNameb4777 As Integer
indexOfNameb4777 = InStr(UCase(b7777), UCase("Requested Payment Term: "))
Dim indexOfNamec4777 As Integer
indexOfNamec4777 = InStr(UCase(b7777), UCase("Description of the provisional Supplier: "))
Dim finalStringb4777 As String
Dim LResult3364777 As String
Dim LResult33644777 As String
Dim LResult336445777 As String
finalStringb4777 = Mid(b7777, indexOfNameb4777, indexOfNamec4777 - indexOfNameb4777)
LResult3364777 = Replace(finalStringb4777, "Requested Payment Term: ", "")
LResult33644777 = Replace(LResult3364777, Chr(10), "")
LResult336445777 = Replace(LResult33644777, Chr(13), "")
Dim TrimString777 As String
TrimString777 = Trim(LResult336445777)
excWks4.Cells(intRow4, 29) = TrimString777
End If
Dim s4 As String
s4 = olkMsg.Subject
Dim indexOfName4 As Integer
indexOfName4 = InStr(1, s4, "Reference: ")
Dim finalString4 As String
finalString4 = Right(s4, Len(s4) - indexOfName2 - 34)
excWks4.Cells(intRow4, 7) = finalString4
excWks4.Cells(intRow4, 9) = "Pending"
excWks4.Cells(intRow4, 10).Formula = "=IF(" & excWks4.Cells(intRow4, 25).Address & "=""Declined"",""Manager has Declined"",IF(" & excWks4.Cells(intRow4, 25).Address & "<>""Yes"",IFERROR(CONCATENATE(""Manager has "" & INDEX(Validations!$C$1:$C$9958,MATCH(" & excWks4.Cells(intRow4, 7).Address & ",Validations!$D$1:$D$9958,0))),IF((TODAY()-" & excWks4.Cells(intRow4, 13).Address & ")>=5,""Approval Is Overdue"",""Approval Is Pending"")),IFERROR(CONCATENATE(""Manager has "" & INDEX(Validations!$C$1:$C$9958,MATCH(" & excWks4.Cells(intRow4, 7).Address & ",Validations!$D$1:$D$9958))),""Approval Overidden"")))"
excWks4.Cells(intRow4, 15) = "Pending"
excWks4.Cells(intRow4, 13) = olkMsg.ReceivedTime
Dim LResult33 As String
LResult33 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult33 = Left(LResult33, InStrRev(LResult33, "@") - 1)
excWks4.Cells(intRow4, 17) = LResult33
excWks4.Cells(intRow4, 18) = "=IFERROR(INDEX('Depot Data'!$F$1:$F$10004,MATCH(" & excWks4.Cells(intRow4, 17).Address & ",'Depot Data'!$E$1:$E$10004,0)),"""")"
excWks4.Cells(intRow4, 19) = "=IFERROR(INDEX('Depot Data'!$H$1:$H$10004,MATCH(" & excWks4.Cells(intRow4, 17).Address & ",'Depot Data'!$E$1:$E$10004,0)),"""")"
excWks4.Cells(intRow4, 20) = "Yes"
excWks4.Cells(intRow4, 23) = "Attach"
excWks4.Cells(intRow4, 24) = "Audit"
excWks4.Cells(intRow4, 25).Formula = "No"
excWks4.Cells(intRow4, 27) = "=Username()"
excWks4.Cells(intRow4, 28) = "Pending"
excWks4.Cells(intRow4, 31) = "V0000847"
excWks4.Cells(intRow4, 32) = "Action"
excWks4.Cells(intRow4, 33) = 1
excWks4.Cells(intRow4, 33).Interior.ColorIndex = 35
Dim LResult21234 As String
LResult21234 = GetSMTPAddress(olkMsg, intVersion)
excWks4.Cells(intRow4, 34) = "=HYPERLINK(""\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\log.txt"",""Log"")"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\log.txt", True)
a.WriteLine ("Log for Supplier: " & Trim(LResult2113) & " (Created: " & Date & ")")
a.WriteLine (Date & " - " & Time & " - Request received in NewSuppliers@Hewden.co.uk by " & LResult21234 & ", and added to New Supplier Database")
a.Close
Dim Rng As Object
Set Rng = excWks4.Range("B" & intRow4 & ":AH" & intRow4 & "")
With Rng.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
excWks4.Range("B" & intRow4 & ":AH" & intRow4 & "").WrapText = False
intRow4 = intRow4 + 1
olkMsg.UnRead = False
If IsNumeric(LResult3362) Then
TempFilePath = "\\UKSH000-File06\Purchasing\New_Supplier_Set_Ups_&_Audits\assets\"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<p style='color:#000;font-family:calibri;font-size:16'>" & "Dear New Accounts, " & vbNewLine & vbNewLine & _
"<br><B>F.A.O: Beth Crowe </b>" & vbNewLine & vbNewLine & _
"<br><br>" & "This is an automated email sent to you from New Suppliers. This is a credit refrence request." & vbNewLine & vbNewLine & _
"<br>" & "Please would you be able to perform a credit check on the following new supplier:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "Company Name: " & "<b>" & Trim(LResult2113) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Company Number: " & "<b>" & Trim(LResult3362) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Case Reference Number (Purchasing Use Only): " & "<b>" & finalString4 & "</b>" & vbNewLine & vbNewLine & _
"<br><br><br>" & "In the event that you have any enquiries, please keep a note of the case reference number. For any questions please contact NewSuppliers@Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Hewden Supply Chain Department</b></font></p>" & vbNewLine & _
"<br><br><img src='cid:cover.jpg'" & "width='800' height='64'><br>" & vbNewLine & _
"<img src='cid:subs.jpg'" & "width='274' height='51'>"
With OutMail
.SentOnBehalfOfName = "newsuppliers@hewden.co.uk"
.To = "mark.o'brien@hewden.co.uk"
.CC = ""
.BCC = ""
.Subject = "(Credit Reference) New Supplier Credit Check - Reference: " & finalString4
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
.HtmlBody = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
Else
Dim b9 As String
If TypeName(olkMsg) = "MailItem" Then
b9 = olkMsg.Body
Dim indexOfName9 As Integer
indexOfName9 = InStr(UCase(b9), UCase("Full Name of Tradesman: "))
Dim indexOfNam9 As Integer
indexOfNam9 = InStr(UCase(b9), UCase("D.O.B of Tradesman: "))
Dim finalString9 As String
finalString9 = Mid(b9, indexOfName9, indexOfNam9 - indexOfName9)
LResult3369 = Replace(finalString9, "Full Name of Tradesman: ", "")
End If
Dim b10 As String
If TypeName(olkMsg) = "MailItem" Then
b10 = olkMsg.Body
Dim indexOfName99 As Integer
indexOfName99 = InStr(UCase(b10), UCase("D.O.B of Tradesman: "))
Dim indexOfNam99 As Integer
indexOfNam99 = InStr(UCase(b10), UCase("Address of Tradesman: "))
Dim finalString99 As String
finalString99 = Mid(b10, indexOfName99, indexOfNam99 - indexOfName99)
LResult33699 = Replace(finalString99, "D.O.B of Tradesman: ", "")
End If
Dim b101 As String
If TypeName(olkMsg) = "MailItem" Then
b101 = olkMsg.Body
Dim indexOfName991 As Integer
indexOfName991 = InStr(UCase(b101), UCase("Address of Tradesman: "))
Dim indexOfNam991 As Integer
indexOfNam991 = InStr(UCase(b101), UCase("VAT Number: "))
Dim finalString991 As String
finalString991 = Mid(b101, indexOfName991, indexOfNam991 - indexOfName991)
LResult336991 = Replace(finalString991, "Address of Tradesman: ", "")
End If
TempFilePath = "\\UKSH000-File06\Purchasing\New_Supplier_Set_Ups_&_Audits\assets\"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<p style='color:#000;font-family:calibri;font-size:16'>" & "Dear New Accounts, " & vbNewLine & vbNewLine & _
"<br><B>F.A.O: Beth Crowe </b>" & vbNewLine & vbNewLine & _
"<br><br>" & "This is an automated email sent to you from New Suppliers. This is a credit refrence request." & vbNewLine & vbNewLine & _
"<br>" & "Please would you be able to perform a credit check on the following new supplier:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "Trading Name: " & "<b>" & Trim(LResult2113) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Full Name of Tradesman: " & "<b>" & LResult3369 & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Tradesman Date of Birth: " & "<b>" & LResult33699 & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Tradesman Address: " & "<b>" & LResult336991 & "</b>" & vbNewLine & vbNewLine & _
"<br><br>" & "Case Reference Number (Purchasing Use Only): " & "<b>" & finalString4 & "</b>" & vbNewLine & vbNewLine & _
"<br><br><br>" & "In the event that you have any enquiries, please keep a note of the case reference number. For any questions please contact NewSuppliers@Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Hewden Supply Chain Department</b></font></p>" & vbNewLine & _
"<br><br><img src='cid:cover.jpg'" & "width='800' height='64'><br>" & vbNewLine & _
"<img src='cid:subs.jpg'" & "width='274' height='51'>"
With OutMail
.SentOnBehalfOfName = "newsuppliers@hewden.co.uk"
.To = "mark.o'brien@hewden.co.uk"
.CC = ""
.BCC = ""
.Subject = "(Credit Reference) New Supplier Credit Check - Reference: " & finalString4
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
.HtmlBody = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
End If
End If
End If
End If
Next
答案 0 :(得分：0)
我在代码中看不到保存和关闭行。尝试类似：
excWks4.Save
excWks4.Close
您可能需要声明excWks4，例如Workbook而不是Object。
Dim excWks4 as Workbook