问题描述
我正试图通过任务计划程序从Excel离线发送每日电子邮件。
- 该脚本在手动激活后会更新并发送电子邮件。
- 使用Task Scheduler运行时(即使处于联机状态),一小时后也会超时。 (只需要10分钟)
- 任务计划程序将打开Excel工作簿并在脚本的开头运行更新,但似乎在到达电子邮件时停滞
我知道手动运行会很容易,但是我正在努力使其能够正常运行,因此我也可以使用大量其他文档进行设置。
这是Scheduler任务的历史记录和代码:
Public Sub Workbook_open()
'Application.Wait (Now + TimeValue("0:01:00"))
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Rcount As Double
Dim Rnum As Double
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim lo As ListObject
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim dStart As Date
Dim dEnd As Date
On Error GoTo cleanup
Set OutApp = CreateObject("outlook.application")
With Application
.EnableEvents = False
'.ScreenUpdating = False
End With
ActiveWorkbook.RefreshAll
Application.CalculateUntilAsyncQueriesDone
Set Ash = Sheet2
Set FilterRange = Ash.Range("A1:Y" & Ash.Rows.Count)
FieldNum = 7
'MsgBox "1"
Rcount =
Application.WorksheetFunction.CountA(Worksheets("Mailinfo").Columns(1))
For Rnum = 1 To Rcount - 1
On Error Resume Next
Ash.AutoFilterMode = False
Set lo = Sheet2.ListObjects(1)
lo.AutoFilter.ShowAllData
mailAddress = Worksheets("Mailinfo").Cells(Rnum,2).Value
On Error GoTo 0
If mailAddress <> "" Then
Ash.ListObjects("RGAReview").Range.AutoFilter Field:=7,Criteria1:=Worksheets("Mailinfo").Cells(Rnum,1).Value
Ash.ListObjects("RGAReview").Range.AutoFilter Field:=8,Criteria1:=">=" & Format(DateAdd("m",-6,Now()),"yyyy-mm-dd")
On Error Resume Next
Set rng = Ash.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutcopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = Ash.Parent.Name & " " & Format(Now,"dd-mmm-yy h-mm-ss")
FileExtStr = ".xlsx": FileFormatNum = 51
Set OutMail = OutApp.CreateItem(0)
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr,FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "RGA Update for " & Format(Now,"dd-mmm-yy")
.Attachments.Add NewWB.FullName
.Body = "Text Stuff Here" & _
vbNewLine & vbNewLine & "Automatic message sent on " & Now
'.display
.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Set OutMail = nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Ash.AutoFilterMode = False
Next Rnum
Set OutApp = nothing
Application.displayAlerts = False
Application.displayAlerts = True
Application.Wait (Now + TimeValue("0:01:00"))
Application.Quit
cleanup:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Application.Wait (Now + TimeValue("0:01:00"))
Application.Quit
End Sub
解决方法
暂无找到可以解决该程序问题的有效方法,小编努力寻找整理中!
如果你已经找到好的解决方法,欢迎将解决方案带上本链接一起发送给小编。
小编邮箱:dio#foxmail.com (将#修改为@)