我正在编写一些代码，这些代码属于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站点复制以组合文件，但编辑后保留标题）：
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，如果没有，则运行saveandsend。
然后将文件移动到文件夹中并关闭应用程序。这将在测试它自己的每个子上时起作用，但会停止接收电子邮件的Outlook，并且不会因此而运行代码。对此的任何帮助都会很棒。
感谢。
答案 0 :(得分：0)
请勿在Excel VBA中调用Application.Quit，因为Excel是从Outlook启动/引用的。如果要在完成后关闭Excel，请在Outlook VBA中使用xlApp.Quit。
答案 1 :(得分：0)
您可以使用 GetObject 函数返回对Application对象的引用，该对象表示已在运行的会话。请注意，因为在任何给定时间只能运行一个Outlook实例，所以与Outlook一起使用时，GetObject通常没什么用处。 CreateObject始终可用于访问Outlook的当前实例或创建新实例（如果不存在）。但是，您可以使用错误捕获与GetObject方法来确定Outlook当前是否正在运行。
在Automating Outlook from Other Office Applications文章中详细了解相关内容。
另请尝试将Quit方法调用从Excel的宏移至Outlook以关闭Excel应用程序。
您是否尝试在调试器下手动运行GetFacebookAttachment方法？