如果我只运行这个子程序，这是可行的，但在此之前，我有子程序来打开一个文件，从它复制数据，创建Piv。表等
我想一起完成整个过程。有时候Excel会关闭，而整个过程并没有完成。
是否有可能在Outlook中设置，直到邮件创建，附加文件和插入表在Outlook中完成，它将不会继续下一个动作？
尝试.display True，也尝试插入等待时间，但有时它不工作。
Option Explicit
Sub Mail_send()
If MsgBox("Do you want to send out the report?", vbYesNo) = vbNo Then
GoTo skip
End If
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
' Set Max Date
MaxD = GetMaxDate(Sheets("Raw data").Columns(33))
' emailRng1 - To name recipients
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 - CC name recipients
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)
' -----------------------------------------------------
Sheets("Table").Select
Set 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."
On Error Resume Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = sTo1
.CC = sTo2
.Subject = "Productivity Report" & " " & Format(MaxD - 1, "yyyy-mm-dd")
.Display
.Attachments.Add ActiveWorkbook.FullName
.Display
.HTMLBody = str1 & RangetoHTML(rg1) & .HTMLBody
.Display True
Application.Wait (Now + TimeValue("0:00:10"))
End With
skip:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub我还使用了两个函数：
'' Get Max Date
Function GetMaxDate(rng As Range) As Variant
Dim cur_date As Date, arr As Variant, d As Variant
arr = rng ' get all the data into an array to improve performance (one operation of reading data from the sheet)
For Each d In arr
If IsDate(d) Then ' we check whether the next value can be a date
cur_date = CDate(d) '
If GetMaxDate < 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
'' Convert Range to HTML
Function 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"
' Copy the range and create a new workbook to past the data in
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
' Publish the sheet to a htm file
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
' Read all data from the htm file into 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=")
' Close TempWB
TempWB.Close savechanges:=False
' Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
1条答案
按热度按时间bkhjykvo1#
为了确保该过程不会中断，并且在Outlook自动化时不会关闭Excel，我建议在Excel中打开一个模式表单（例如，带有进度条），以防止用户关闭它。