У меня есть код VBA, который отправляет содержимое Sheet1 по электронной почте в тело письма, в список рассылки в определенное время дня.Это общая книга, поэтому она открыта несколькими пользователями одновременно.
Код работает нормально и отправляет электронное письмо, однако отправляется несколько раз, либо от одного и того же пользователя, либо от нескольких пользователей.«Отправитель» в электронном письме, я полагаю, потому что файл открыт у нескольких пользователей.
Как я могу изменить код так, чтобы он отправлялся только один раз по электронной почте и перестал отправлять его несколько раз?
Лист1 отправляется в теле письма внутри 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:05AM, включенный в ThisWorkbook
Private Sub Workbook_Open()
Application.OnTime TimeValue("09:05:00"), "Email"
End Sub