是否可以在 VBA 中以某种方式进行设置，直到在 Outlook 中创建邮件、附加文件和插入表格之前，它不会继续执行下一步操作？我的意思是直到 Outlook 不会回复为止。
尝试过“.display True”，也尝试过插入等待时间，但有时有效，有时无效...
您可以在下面找到用于发送邮件的子程序：
选项显式
子邮件_发送()
If MsgBox("您要发送报告吗？", vbYesNo) = vbNo then 前往跳过
结束如果
Dim OutApp As Object
Dim OutMail As Object
Dim rg1 As Range
Dim str1 As String
Dim emailRng1 As Range, cl1 As Range
Dim sTo1 As String
Dim emailRng2 As Range, cl2 As Range
Dim sTo2 As String
Dim MaxD As Date
' 设置最大日期
MaxD = GetMaxDate(Sheets("原始数据").Columns(33))
' emailRng1 - 命名收件人
Sheets("Mail loops and contact persons").Activate
Set emailRng1 = Sheets("Mail loops and contact persons").Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each cl1 In emailRng1
sTo1 = sTo1 & ";" & cl1.Value
Next
sTo1 = Mid(sTo1, 2)
' emailRng2 - 抄送收件人姓名
Set emailRng2 = Sheets("Mail loops and contact persons").Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
For Each cl2 In emailRng2
sTo2 = sTo2 & ";" & cl2.Value
Next
sTo2 = Mid(sTo2, 2)
'------------------------------------------------ ----- 工作表（“表”）.选择 设置 rg1 = Sheets("Table").Range(Cells(3, 2), Cells(7, 8))
Set OutApp = CreateObject("Outlook.Application")
str1 = "<BODY style = font-size:12pt-family:Calibri>" & _
"Dear all,<br><br> Please find the productivity report for the last working day."
出错时继续下一步 设置 OutMail = OutApp.CreateItem(0) 与外发邮件 .to = sTo1 .CC = sTo2 .Subject = "生产力报告" & " " & Format(MaxD - 1, "yyyy-mm-dd") .显示
.Attachments.Add ActiveWorkbook.FullName
.Display
.HTMLBody = str1 & RangetoHTML(rg1) & .HTMLBody
.Display True
Application.Wait（现在 + TimeValue（“0:00:10”））
结束
跳过：
Application.ScreenUpdating = True 应用程序.DisplayAlerts = True
结束子
我还使用了 2 个功能，这些也如下：
'' 获取最大日期
函数 GetMaxDate(rng As Range) 作为变体 Dim cur_date 作为日期，arr 作为变体，d 作为变体 arr = rng '将所有数据放入一个数组中以提高性能（从sheet中读取数据的一个操作） 对于 arr 中的每个 d If IsDate(d) Then ' 我们检查下一个值是否可以是日期 cur_date = CDate(d) ' 如果获取最大日期 < cur_date Then GetMaxDate = cur_date ' select max date End If Next If Not IsEmpty(GetMaxDate) Then GetMaxDate = Format(GetMaxDate, "yyyy-mm-dd") Else GetMaxDate = "#NODATE" End If End Function
'' 将范围转换为 HTML
函数 RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yyy h-mm-ss") & ".htm"
'复制范围并创建一个新工作簿以将数据粘贴到
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error GoTo 0
End With
' 将工作表发布到 htm 文件
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' 将 htm 文件中的所有数据读入 RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' 关闭 TempWB
TempWB.Close savechanges:=False
'删除我们在这个函数中使用的htm文件
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
结束功能