电子邮件停止发送时，运行VBA脚本调用和Excel脚本

Question

我正在写一些代码，这是在Outlook中的一部分，在Excel中的一部分。 Outlook中代码的第一位是使用基于电子邮件地址的规则触发的。然后它会查看电子邮件并将文件移动到网络驱动器上的文件夹中。

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 

我已经添加了睡眠的代码，因为我认为脚本可能是资源沉重，但问题仍然存在。

它然后运行下面的代码（从微软网站复制的合并文件，但编辑，以保持头）：

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。

然后将文件移入文件夹并关闭应用程序。这将在测试每个单独的sub时自动运行，但会阻止outlook收到电子邮件，并且不会运行代码。任何对此的帮助都会很大。

谢谢。

Answer 1

不要在Excel VBA中调用Application.Quit，因为Excel是从Outlook启动/引用的。如果要在完成时关闭Excel，请在Outlook VBA中使用xlApp.Quit。

Answer 2

您可以使用GetObject函数返回对Application对象的引用，该对象表示已在运行的会话。请注意，由于在任何给定时间只能运行一个Outlook实例，因此与Outlook配合使用时，GetObject通常没有什么用处。总是可以使用CreateObject访问Outlook的当前实例，或者创建一个新的实例（如果不存在）。但是，可以使用GetObject方法使用错误捕获来确定Outlook当前是否正在运行。

阅读有关Automating Outlook from Other Office Applications文章的更多内容。

也尝试将Quit方法从Excel的宏调用到Outlook以关闭Excel应用程序。

您是否尝试在调试器下手动运行GetFacebookAttachment方法？