Question

我有一个VBA代码，该代码通过电子邮件将Sheet1的内容发送到电子邮件正文中，并在一天中的特定时间发送到通讯组列表。这是一个共享工作簿，因此多个用户可以同时打开它。

该代码可以正常工作，并发送电子邮件，但是由于电子邮件中的“发件人”，它是从同一用户或从多个用户多次发送的，我想是因为多个用户的文件都是Open。 / p>

如何修改代码，使其仅发送一次电子邮件并停止发送多次？

Sheet1在Module1内部的电子邮件正文中发送：

Sub Email()

'Worksheets("Sheet1").Unprotect Password:="1"

Dim ChartName1 As String
Dim dataTable As String
Dim rng As Range

Set appOutlook = CreateObject("outlook.application")
        'create a new message
        Set Message = appOutlook.CreateItem(olMailItem)


Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("Sheet1").Range("A1:E11").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0




    ChartName1 = Environ$("temp") & "\Chart1.gif"
    ActiveWorkbook.Worksheets("Sheet1").ChartObjects("Chart 1").Chart.Export _
    Filename:=ChartName1, FilterName:="GIF"

        With Message
            .Subject = " Files status " & Format(Date, "dd/mm/yyyy")


        .HTMLBody = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=2>" _
                & "Dear all,<br ><br >Please see below the Open Files status for today : " _
               & "<br><BR>"

             .HTMLBody = .HTMLBody & rangetoHTML(rng) & "<br>"

             .HTMLBody = .HTMLBody & "<html><body><img src=" & "'" & ChartName1 & "'><Br><Br><Br/></body></html>"

             '  .HTMLBody = .HTMLBody & "<br><B>WEEKLY REPPORT:</B><br>" _
            '  & "<br>Best Regards,<br>Ed</font></span>"


            .To = "recipients here "
            .Cc = ""

            .Display
            .Send
        End With

        Kill ChartName1
        Set OutMail = Nothing
        Set OutApp = Nothing

'Worksheets("Sheet1").Protect Password:="1"
End Sub

将图形作为图片发送的功能：

Function rangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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

此工作簿中包含的每天上午09:05发送文件的代码

Private Sub Workbook_Open()
    Application.OnTime TimeValue("09:05:00"), "Email"
End Sub

Answer 1

如果您可以从一个应执行宏的位置选择一个用户，则在调用该过程之前，您可以根据以下内容检查该用户：

$date = new DateTime('01/02/2019');
$date->add(new DateInterval('P6M'));
echo $date->format('d/m/Y') . "\n";

希望它可能有用。

发送自动电子邮件-共享工作簿

1 个答案: