Question

我在excel 2013中有一个大型脚本花了我几个月的时间来编写，简而言之，它读取填充图表的历史和当前数据（第一部分工作正常），我将其复制并粘贴到发送的电子邮件中它关注的用户。

原始代码来源为http://www.rondebruin.nl/win/s1/outlook/bmail2.htm

前6-8个月，脚本运行得很好。现在发生的事情是我在脚本继续运行之前经历了大约70次循环迭代，但是电子邮件没有被发送出去，它们没有出现在outlook中的outbox / sent文件夹中（总共大约有150次循环迭代）。我必须在它停止工作的地方停止并重新启动脚本，这很麻烦。

我想首先确认我确实正在调用并在我的代码中正确关闭CreateObject函数。我并不完全相信，当Excel调用Outlook时，它正在调用活动会话（可能需要输入错误陷阱，但我不知道该怎么做）。任何帮助表示赞赏。 https://msdn.microsoft.com/en-us/library/office/ff869289.aspx?f=255&MSPPError=-2147217396

Public Sub SendChartByEmail(PasteAdd As String, ByRef UserEntriesArray() As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim Fname, SelectedRange, Message As String
Dim x As Integer
Dim oRange As Range

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'File path/name of the gif file
Fname = Environ$("temp") & "\User_Chart.gif" 'save the chart to %temp% otherwise problems with email
SelectedRange = Environ$("temp") & "\SelectedRange.gif"

ActiveWorkbook.Worksheets("Table").ChartObjects("Chart 1").Chart.Export _
        Filename:=Fname, Filtername:="GIF"

x = UBound(UserEntriesArray, 1) 'paste current month user specific data'
Application.Goto Reference:=Worksheets("Table").Range("I16")
ActiveCell = UserEntriesArray(x, 0)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 2)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 3)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 4)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 5)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 6)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 7)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 9)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 10)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 11)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 12)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 13)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate
ActiveCell = UserEntriesArray(x, 14)
ActiveCell.Offset(rowOffset:=0, ColumnOffset:=1).Activate

Set oRange = Range("I15:U16") 'used to reformat cell group

On Error Resume Next
With OutMail
    .To = UserEntriesArray(0, 1)
    .CC = ""
    .BCC = ""
    .Subject = "Report for the Month of " & PasteAdd
    .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri>" & "Greetings " + UserEntriesArray(0, 0) + ",<br>" & vbCrLf & "" & vbCrLf _
                & "<br>Message to the user here.<br><br>" & vbCrLf _
                & "<img src='User_Chart.gif'><br>" & vbCrLf _
                & RangetoHTML(oRange) & vbCrLf _ 'convert cells to html standard'
                & "<br><br><b>Message to the user here</b>"
    .Attachments.Add Fname ', olByValue, 0'
    .Send   'use .Display for testing .Send for mailing
End With
On Error GoTo 0
Application.Wait (Now + #12:00:03 AM#)
'Delete the gif file
Kill Fname

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Answer 1

如果Outlook尚未打开，您只需打开一次。肯定会多次创建和关闭Outlook会给资源带来压力。

请参阅以下代码，这将有所帮助。将它放在循环之前，以确保在需要发送邮件之前打开Outlook实例。

Dim olApp As Outlook.Application

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0

If olApp Is Nothing Then Set olApp = New Outlook.Application

我使用早期绑定，但你可以改为迟到。一旦你的循环结束，你就释放olApp（或者你称之为变量的任何东西）。

随着时间的推移，电子邮件脚本的GetObject使用会停止

1 个答案: