Boa noite Tiago, montei a macro no seu arquivo para gerar o e-mail em horários determinados. Abaixo as considerações a respeito da macro.
1 - A macro é composta de 2 partes, sendo a primeira parte está dentro do evento "workbook_Open" , quando a planilha é aberta ela executa a macro "Programação" e esta outra macro, que está no Módulo1, recebe os valores dos horários cadastrados na aba "E-mail" que está oculta e vai comparando com o horario do relógio do windows e assim que o horário do relogio for igual a um dos horários cadastrados na planilha ele executa a macro "Executar" que manda o e-mail.
Abaixo os dois códigos;
1 parte (este código fica em "EstaPasta_de_trabalho"):
Private Sub Workbook_Open()
Programação
End Sub
2 parte (este código fica em "Módulo1"):
Public Sub Programação()
tempo1 = Sheets("E-mail").Range("m5")
tempo2 = Sheets("E-mail").Range("m6")
tempo3 = Sheets("E-mail").Range("m7")
tempo4 = Sheets("E-mail").Range("m8")
tempo5 = Sheets("E-mail").Range("m9")
Application.OnTime TimeValue(tempo1), "Executar"
Application.OnTime TimeValue(tempo2), "Executar"
Application.OnTime TimeValue(tempo3), "Executar"
Application.OnTime TimeValue(tempo4), "Executar"
Application.OnTime TimeValue(tempo5), "Executar"
End Sub
Sub Executar()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim sendto As String
Dim sendcc As String
Dim subj As String
Dim planilha As String
Dim intervalo As String
Dim tipo As String
Dim endereco As String
Dim tabela As String
Dim linha As Integer
Dim ref As String
Sheets("E-mail").Visible = True
Sheets("E-mail").Select
Rows("29:229").Select
Selection.Delete Shift:=xlUp
Sheets("Documentação").Select
If ActiveSheet.FilterMode Then 'Se houver filtro na planilha
ActiveSheet.ShowAllData ' Limpa todos os filtros
End If ' Senão segue o codigo
Rows("6:6").Select
Selection.AutoFilter
ActiveSheet.Range("$b$6:$y$6").AutoFilter Field:=24, Criteria1:="SIF"
Range("i6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("E-mail").Select
Range("b28").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Documentação").Select
Range("w6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("E-mail").Select
Range("c28").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
endereco = Range("b" & Rows.Count).End(xlUp).Row + 2
Range("B" & endereco).Select
ActiveCell.FormulaR1C1 = "Att.: Administração"
Range("B28:C28").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
tabela = endereco - 2
Range("b29:c" & tabela).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A28").Select
ActiveCell.FormulaR1C1 = "=IF(R[1]C[1]="""","""",1)"
If Range("a28").Value = "1" Then
Range("b19").Select
sendto = ActiveCell
Range("f19").Select
sendcc = ActiveCell
Range("l2").Select
subj = ActiveCell
Range("l11").Select
planilha = ActiveCell
intervalo = "b24:h" & endereco
Set rng = Nothing
On Error Resume Next
Set rng = Sheets(planilha).Range(intervalo).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sendto
.CC = sendcc
.BCC = ""
.Subject = subj
.HTMLBody = RangetoHTML(rng)
.Send 'use .Display or .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
planilha = Empty
intervalo = Empty
Sheets("E-mail").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Documentação").Select
If ActiveSheet.FilterMode Then 'Se houver filtro na planilha
Range("b6").Select 'seleciona a range b6
Selection.AutoFilter ' Limpa todos os filtros
End If ' Senão segue o codigo
Range("b6").Select
Else
Sheets("E-mail").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Documentação").Select
If ActiveSheet.FilterMode Then 'Se houver filtro na planilha
Range("b6").Select 'seleciona a range b6
Selection.AutoFilter ' Limpa todos os filtros
End If ' Senão segue o codigo
Range("b6").Select
End If
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
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
2 - Existe uma planilha oculta com o nome "E-mail" e nela estão os dados que irão no e-mail. Nela também estão as configurações do e-mail que será enviado.
3 - Reexiba a planilha "E-mail" e dentro dela insira os seus dados nos campos marcados em verde. os demais serão importados da planilha "Documentação" no momento da execução da macro.
4 - Toda vez que alterar os horários de envio dos e-mail, deverá salvar e e fechar a planilha. depois abra novamente para que a alteração tenha efeito. Pois esta alteração só surte efeito quando a planilha é aberta.
5 - Lembre-se de que no momento em que a macro for executada, nos horários definidos, o Excel poderá travar se houver interação com a planilha pelo usuário, pois a macro irá manipular dados e comandos dentro da planilha e se o usuário fazer alguma alteração neste momento pode causar erro na execução do código.
Faça seus teste e me diz se te atende e caso deseje mudar algo e não saiba fazer é só avisar que mudamos.
Qualquer dúvida estou à disposição.
Lucélio Ferreira dos Santos
Eng. Eletricista
CREA: DF-7165/TD
[email protected]
Postado : 31/07/2016 10:19 pm