当运行调用vba脚本和Excel脚本时，电子邮件停止发送
我正在写一些代码，这是在Outlook中的一部分，在Excel中的一部分。 Outlook中代码的第一位是使用基于电子邮件地址的规则触发的。 然后，它会查看电子邮件并将文件移动到networking驱动器上的文件夹中。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long) Public Sub GetFacebookAttachment(itm As Outlook.MailItem) 'set up outlook objects Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim dateFormat As String Dim xlApp As Object Dim xlWbk As Object 'run attachment script dateFormat = Format(Now, "yyyy-mm-dd H-mm") saveFolder = "S:\VBA\Recieved" For Each objAtt In itm.Attachments If InStr(objAtt.DisplayName, ".csv") Then objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName Set objAtt = Nothing End If Next Sleep 10000 ' open and run excel script Set xlApp = CreateObject("Excel.Application") xlApp.Application.Visible = True xlApp.Workbooks.Open ("S:\VBA\vba.xlsm") xlApp.Application.Run "Module1.Combine_files" End Sub 我已经添加了睡眠的代码，因为我认为脚本可能是资源沉重，但问题仍然存在。
然后运行以下代码（从Microsoft站点复制，用于合并文件，但已编辑以保留标题）：
Public Sub Combine_files() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim LastRow As Long Dim LastColumn As Long Dim sourceHeaderRange As Range Dim destHeaderRange As Range Dim CostCell As Range Dim Costrange As Range Dim errorCell As Variant ' Change this to the path\folder location of your files. MyPath = "VBA\Recieved" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.csv*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of Excel files ' in the search folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop ' Set various application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 2 ' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next ' Change this range to fit your own needs. With mybook.Worksheets(1) LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column Set sourceRange = Range(Cells(2, 1), Cells(LastRow, LastColumn)) Set sourceHeaderRange = .Rows(1) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close SaveChanges:=False GoTo ExitTheSub Else ' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = MyFiles(FNum) End With ' Set the destination range. Set destrange = BaseWks.Range("A" & rnum) ' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With Set destHeaderRange = BaseWks.Rows(1) With sourceHeaderRange Set destHeaderRange = destHeaderRange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value destHeaderRange.Value = sourceHeaderRange.Value rnum = rnum + SourceRcount End If End If mybook.Close SaveChanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: ' Restore the application properties. With Application .EnableEvents = True .Calculation = CalcMode End With SetRate: 'reset lastrow and lastcolumn With ActiveWorkbook.Worksheets(1) LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column End With Set CostCell = Cells.Find(what:="Amount Spent (GBP)", MatchCase:=False) 'finds the cell that contains "amount spent (GPB)" Set Costrange = Range(Cells(2, CostCell.Column), Cells(LastRow, CostCell.Column)) 'sets the cost range to equal the amount spent column (excluding the header) Costrange = Evaluate(Costrange.Address & "*2") 'multipies the values by 1.25 clickTrackers: With ActiveWorkbook.Worksheets(1) 'reset lastrow and lastcolumn and copy/paste vlookup LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column Range("AA1").Value = "Tag" Range(Cells(2, LastColumn + 1), Cells(LastRow, LastColumn + 1)).FormulaR1C1 = "=VLOOKUP(LEFT(RC[-23],3)&RC[-22],'clicktags vlookup file]Ad Sheet'!C[-26]:C[-25],2,0)" End With CheckForMissingClickTrackers: 'if there are any errors and hence missing click trackers in the lookup the file will still save in the recived 'folder however it will not send and save as a xls for the addional click trackers to be updated. 'save as a csv before sending on. On Error Resume Next Set errorCell = ActiveWorkbook.Worksheets(1).Cells.SpecialCells(xlFormulas, xlErrors) If Not errorCell Is Nothing Then GoTo EmailErrorNotification With ActiveWorkbook.Worksheets(1) .SaveAs "S: \VBA\Processed\processedfile_" & Format(Now, "ddmmyyyy") & ".csv", FileFormat:=xlCSV End With ActiveWorkbook.Close Application.Wait (Now + TimeValue("0:00:10")) SaveAndSend: Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon Set OutMail = OutApp.CreateItem(0) With OutMail .To = "email@email.com" .Subject = "RE: did this work?" .Body = "BOOM! http://gifdanceparty.giphy.com/" .Attachments.Add ("S: \VBA\Processed\processedfile_" & Format(Now, "ddmmyyyy") & ".Csv") .SendUsingAccount = OutApp.Session.Accounts.Item(1) .Send End With Application.Wait (Now + TimeValue("0:00:15")) GoTo moveFiles EmailErrorNotification: Dim OutApp2 As Object Dim OutMail2 As Object Set OutApp2 = CreateObject("Outlook.Application") OutApp2.Session.Logon Set OutMail2 = OutApp2.CreateItem(0) With OutMail2 .To = "email@email.com" .Subject = "click trackers missing" .Body = _ "Hi" _ & vbNewLine & vbNewLine & _ "This is an automated email to let you know that todays facebook upload is missing click trackers in the vlookup. Please update the vlookup and send." _ & vbNewLine & vbNewLine & _ "Latest file - S:\VBA\Processed" _ & vbNewLine & vbNewLine & _ " Vlookup File - S:\clicktags vlookup file.xlsx" _ & vbNewLine & vbNewLine & _ " Thanks" _ & vbNewLine & vbNewLine & _ "Fane" .SendUsingAccount = OutApp.Session.Accounts.Item(1) .Send End With Application.Wait (Now + TimeValue("0:00:15")) With ActiveWorkbook.Worksheets(1) .SaveAs "S: \VBA\Processed\processedfile_" & Format(Now, "ddmmyyyy") & ".xlsx" End With ActiveWorkbook.Close Application.Wait (Now + TimeValue("0:00:15")) moveFiles: Call move_files With Application .DisplayAlerts = False .ScreenUpdating = True End With With Application .Quit End With End Sub Sub move_files() Dim objFile As File Dim objFolder As Folder Dim objFSO As FileSystemObject Dim current_path As String Dim dest_path As String current_path = "S:\VBA\Recieved" dest_path = "S:\VBA\OLD" Set objFSO = New FileSystemObject Set objFolder = objFSO.GetFolder(current_path) For Each objFile In objFolder.Files If (objFile.Name <> ThisWorkbook.Name) And (InStr(1, objFile.Name, ".xls") Or InStr(1, objFile.Name, ".csv")) Then objFile.Move (dest_path & "\" & objFile.Name) End If Next objFile End Sub
前面的代码调用并打开excel，打开并运行vba，将文件堆叠在一起，并以费率乘以成本。 检查文件是否有错误，如果有一些或只是保存并发送，如果没有则运行EmailErrorNotification。
然后将这些文件移动到一个文件夹中，并closures应用程序。 这将工作时testing每个单独的子本身，但会停止前台接收电子邮件，并不会运行代码作为这一结果。 任何帮助，这将是伟大的。
谢谢。
不要从Excel VBA中调用Application.Quit ，因为Excel是从Outlook启动/引用的。 如果要在完成时closuresExcel，请使用Outlook VBA中的xlApp.Quit 。
您可以使用GetObject函数来返回表示已在运行的会话的Application对象的引用。 请注意，由于在任何给定时间只能运行一个Outlook实例，因此与Outlook一起使用时，GetObject通常没什么用处。 总是可以使用CreateObject访问Outlook的当前实例，或者创build一个新的实例（如果不存在）。 但是，可以使用GetObject方法使用错误捕获来确定Outlook是否正在运行。
阅读有关从其他Office应用程序自动化Outlook文章中的更多信息。
另外，请尝试将Excelmacros中的Quit方法调用移动到Outlook以closuresExcel应用程序。
您是否尝试在debugging器下手动运行GetFacebookAttachment方法？