Segue a macro, onde ela cola uma parte de uma planilha no corpo do email.
O que eu estou precisando é que só pegue a data do dia, ou seja a data do computador para gerar o relatório.
Código: Selecionar todos'CODE
'Option Explicit
'Option Private Module
Dim assinatura As Variant
Public Function pega_assinatura(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
pega_assinatura = ts.readall
ts.Close
End Function
Sub Mail_Sheet_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim rng As Range
Dim maiuscula As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim Letra As String
Dim I As Integer
Dim Celula As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
ActiveWorkbook.RefreshAll
assinatura = pega_assinatura("C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Assinaturas\" & Environ("username") & ".htm")
StrBody = ("Prezados(as)," & vbCrLf & vbCrLf & _
"Segue Relatório de Turno elétrica e instrumentação das Usinas V a VII - " & Date & vbCrLf & vbCrLf & _
"Paradas GPV-PE responsabilidade GAELP: ( )Sim ; ( )Não" & vbCrLf & vbCrLf & _
"Perdas GPV-PE responsabilidade GAELP: ( )Sim ; ( )Não" & vbCrLf & vbCrLf & _
"Ocorrência e fatos relevantes de segurança e meio ambiente: ( )Sim ; ( )Não" & vbCrLf & vbCrLf & _
"Fatos relevantes ocorridos durante o turno: ( )Sim ; ( )Não" & vbCrLf & vbCrLf & _
"Pendências do turno / HN: ( )Sim ; ( )Não" & vbCrLf & vbCrLf & _
"Pendências do turno / Turno:( )Sim ; ( )Não ")
Sheets("Filtro").Select
Rows("2:1200").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Sheets("backlog").Select
Range("C:C,D:D").Select
Selection.Replace What:="_", Replacement:="-", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Sheets("backlog").Select
I = 5
Do While Range("G" & I).Value <> ""
I = I + 1
Loop
'MsgBox I
'Range("G1048576").End(xlUp).Offset(I, 0).Select
Range("G" & 5, "G" & I - 1).Select
'em todas as celulas dentro da selecção
For Each Celula In Selection
'variavel a comparar
Select Case Celula
'comparando se está com letra minuscula
Case LCase(Celula)
'converte para maiusculas
Celula = UCase(Celula)
'comparando se está com letra maiuscula
'Case UCase(celula)
'converte para a 1º letra de cada palavra em maiuscula
'celula = Application.WorksheetFunction.Proper(celula.Text)
'outro caso que não se incluia nos dois primeiro
'Case Else
'converte para minusculas
'celula = LCase(celula.Text)
End Select
Next
Sheets("backlog").Range("A4:Y1200").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("base").Range("AP4:BB6"), CopyToRange:=Sheets("Filtro").Range("A1:M1"), Unique:= _
True
Sheets("Filtro").Select
ActiveSheet.Range(ActiveSheet.UsedRange.Cells(1, 13), ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count, 1)).Select
With Selection.Font
.Name = "Calibri"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Copy
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'Set rng = Sheets("Filtro").UsedRange
'You can also use a sheet name
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To =
.CC =
.BCC = ""
.Subject = "Relatório de Turno de Automação e Instrumentação - Usinas V a VII - Letra " & Sheets("base").Range("N5").Value & " - " & Date
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & StrBody & RangetoHTML(rng) & assinatura & "</p>"
'.HTMLBody = StrBody & RangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Sheets("base").Visible = True
Sheets("base").Select
Range("V36").Select
ActiveCell.FormulaR1C1 = _
"=ShowHistoricalValue(ADDRESS(ROW(base!RC[-2]),COLUMN(base!RC[-2]),1,,""base""),base!RC[-2], 0)"
Range("V37").Select
ActiveCell.FormulaR1C1 = _
"=ShowHistoricalValue(ADDRESS(ROW(base!RC[-2]),COLUMN(base!RC[-2]),1,,""base""),base!RC[-2], 0)"
Range("V38").Select
ActiveCell.FormulaR1C1 = _
"=ShowHistoricalValue(ADDRESS(ROW(base!RC[-2]),COLUMN(base!RC[-2]),1,,""base""),base!RC[-2], 0)"
Range("N5").Select
Sheets("base").Visible = False
Sheets("backlog").Select
Cells.Select
ActiveSheet.Unprotect Password:="ip21v400"
Rows("4:4").Select
Selection.AutoFilter
ActiveWindow.LargeScroll ToRight:=-1
ActiveSheet.Range("$A$4:$M$1198").AutoFilter Field:=4
Cells.Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("A5:D1200,G5:M1200").Select
'Range("G1").Activate
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, Password:="ip21v400"
Range("D4").Select
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' 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
