Question

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

单元格（17,2）中的用户输入日期是＆gt;比今天的日期 细胞（22.2）
当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

测试了您的代码并遇到了一些小问题。假设你的功能

RangetoHTML()

工作正常，您需要将以下内容更改为行

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

更改如下：更换'＆amp;'使用'And'和'mymail'与您在上面设置的对象（在您的情况下是OutMail）。

所以你的Sub将是：

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 = "test@testing.com"
        '& ";" & "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

比较日期和发送电子邮件

1 个答案: