比较date和发送电子邮件

如果满足两个条件，我想发送自动邮件

1. Cell（17,2）中的用户inputdate> Cell（22,2） '中的当前date

2. 当Cell (B3) = "Operation_Support"的值Cell (B3) = "Operation_Support"

当满足上述两个条件时，我想要一个自动邮件发射。

可以这样做吗？

代码如下所示。

 Sub datesexcelvba() Dim OutApp As Object Dim OutMail As Object Dim mydate1 As Date Dim mydate2 As Long Dim datetoday1 As Date Dim datetoday2 As Long Dim rng As Range Dim StrBody As String StrBody = "This is line " & "<br>" & _ "This is line " & "<br>" & _ "This is line " & "<br><br><br>" mydate1 = Cells(17, 2).Value mydate2 = mydate1 datetoday1 = Cells(22, 2).Value datetoday2 = datetoday1 If mydate2 > datetoday2 & Range("B3").Value = "Operation_Support" Then Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With mymail .To = "x" '& ";" & "x" .CC = "" .BCC = "" .Subject = "Test Mail" .HTMLBody = StrBody & RangetoHTML(rng) .Attachments.Add ActiveWorkbook.FullName ' You can add other files by uncommenting the following line. '.Attachments.Add ("C:\test.txt") .Display End With End If On Error GoTo 0 With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing End Sub Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2016 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy 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 Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete 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 

Answer 1

testing你的代码并遇到一些小问题。 假设你的function

 RangetoHTML() 

工作正常，你需要改变以下行

  If mydate2 > datetoday2 & Range("B3").Value = "Operation_Support" Then ... With mymail ... 

更改如下：用上面设置的对象replace'＆'和'And'和'mymail'（在你的情况下它是OutMail）。

所以你的小组将是：

 Sub datesexcelvba() Dim OutApp As Object Dim OutMail As Object Dim mydate1 As Date Dim mydate2 As Long Dim datetoday1 As Date Dim datetoday2 As Long Dim rng As Range Dim StrBody As String StrBody = "This is line " & "<br>" & _ "This is line " & "<br>" & _ "This is line " & "<br><br><br>" mydate1 = Cells(17, 2).Value mydate2 = mydate1 datetoday1 = Cells(22, 2).Value datetoday2 = datetoday1 If mydate2 > datetoday2 And Range("B3").Value = "Operation_Support" Then Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .To = "[e-mail]" '& ";" & "x" .CC = "" .BCC = "" .Subject = "Test Mail" .HTMLBody = StrBody '.Attachments.Add ActiveWorkbook.FullName ' You can add other files by uncommenting the following line. '.Attachments.Add ("C:\test.txt") .Display End With End If On Error GoTo 0 With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing End Sub