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

我正在写一段代码，它是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

我在代码中添加了睡眠，因为我认为脚本可能会占用大量资源，但问题仍然存在

然后运行以下代码（从Microsoft站点复制用于合并文件，但经过编辑以保留标题）：

公共子组合_文件（）
将MyPath设置为字符串，将FileInPath设置为字符串
将MyFiles（）设置为字符串
暗源计数等于长，FNum等于长
将mybook设置为工作簿，将BaseWks设置为工作表
变暗源范围作为范围，减小范围作为范围
尺寸与长度相同，计算模式与长度相同
最后一排一样长
将最后一列变长
Dim sourceHeaderRange作为范围
作为范围的差旅
暗淡的肋细胞范围
变暗Costrange作为范围
Dim errorCell作为变体
'将此更改为文件的路径\文件夹位置。
MyPath=“VBA\Received”
'如果需要，在路径末尾添加斜杠。
如果正确（MyPath，1）“\”则
MyPath=MyPath&“\”
如果结束
'如果文件夹中没有Excel文件，请退出。
FilesInPath=Dir（MyPath&“*.csv*”）
如果FilesInPath=“”，则
MsgBox“未找到任何文件”
出口接头
如果结束
'用Excel文件列表填充myFiles数组
'在搜索文件夹中。
FNum=0
在文件输入路径“”时执行此操作
FNum=FNum+1
ReDim保留我的文件（1到FNum）
MyFiles（FNum）=FilesInPath
FilesInPath=Dir（）
环
'设置各种应用程序属性。
应用
CalcMode=.Calculation
.Calculation=xlCalculationManual
.ScreenUpdate=False
.EnableEvents=False
以
'添加带有一张工作表的新工作簿。
Set BaseWks=工作簿。添加（XLWBATWORKEM）。工作表（1）
rnum=2
'遍历myFiles数组中的所有文件。
如果FNum>0，则
对于FNum=LBound（MyFiles）到UBound（MyFiles）
设置mybook=Nothing
出错时继续下一步
设置mybook=Workbooks.Open（MyPath&MyFiles（FNum））
错误转到0
如果不是的话，我的书什么都不是
出错时继续下一步
'更改此范围以满足您自己的需要。
使用mybook.工作表（1）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
LastColumn=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
设置sourceRange=Range（单元格（2，1），单元格（LastRow，LastColumn））
设置sourceHeaderRange=.Rows（1）
以
如果错误编号>0，则
呃，明白了
设置sourceRange=Nothing
其他的
'如果源范围使用所有列，则
'跳过此文件。
如果sourceRange.Columns.Count>=BaseWks.Columns.Count，则
设置sourceRange=Nothing
如果结束
如果结束
错误转到0
如果不是sourceRange，则为Nothing
SourceRcount=sourceRange.Rows.Count
如果rnum+SourceRcount>=BaseWks.Rows.Count，则
MsgBox“目标工作表中没有足够的行。”
BaseWks.Columns.AutoFit
mybook.Close SaveChanges:=False
下地狱
其他的
'复制A列中的文件名。
使用sourceRange
基底细胞（rnum，“A”）_
调整大小（.Rows.Count）.Value=MyFiles（FNum）
以
'设置目标范围。
Set destrange=BaseWks.Range（“A”和rnum）
'从源范围复制值
'到目标范围。
使用sourceRange
设置减小范围=减小范围_
调整大小（.Rows.Count、.Columns.Count）
以
设置destHeaderRange=BaseWks.Rows（1）
带着信使
设置destHeaderRange=destHeaderRange_
调整大小（.Rows.Count、.Columns.Count）
以
destrange.Value=sourceRange.Value
destHeaderRange.Value=sourceHeaderRange.Value
rnum=rnum+源计数
如果结束
如果结束
mybook.Close SaveChanges:=False
如果结束
下一个FNum
BaseWks.Columns.AutoFit
如果结束
退出主题：
'还原应用程序属性。
应用
.EnableEvents=True
.Calculation=CalcMode
以
设定值：
'重置lastrow和lastcolumn
使用Active工作簿。工作表（1）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
LastColumn=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
以
Set CostCell=Cells.Find（内容：=“花费金额（GBP）”，MatchCase:=False）
'查找包含“花费金额（GPB）”的单元格
设置Costrange=范围（单元格（2，CostCell.Column），单元格（LastRow，CostCell.Column））
'将成本范围设置为等于“花费金额”列（不包括标题）
Costrange=Evaluate（Costrange.Address&“*2”）
'将值乘以1.25
点击跟踪器：
使用Active工作簿。工作表（1）
'重置lastrow和lastcolumn并复制/粘贴vlookup
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
LastColumn=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
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