Página 1 de 1

Colar parte de uma planilha no corpo do email

Enviado: 21 Nov 2017 às 14:15
por WadsonRocha
Sr.s;
Tenho uma planilha de relatório diário onde ao final do turno devo enviar via email para os envolvidos.
Tenho uma macro onde ao clicar num botão gerar email, já me abre o outlook com dados pré definidos.
O que preciso é que se envie também, os fatos ocorridos naquele dia, ou seja, colar no email os relatos do dia embaixo do cabeçalho.

Re: Colar parte de uma planilha no corpo do email

Enviado: 21 Nov 2017 às 14:55
por alexandrevba
Boa tarde!!

Você precisa por um arquivo como anexo, uma guia, um intervalo?

Veja:
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Att

Re: Colar parte de uma planilha no corpo do email

Enviado: 21 Nov 2017 às 18:43
por WadsonRocha
Preciso colar uma parte da tabela ou seja, só o relato do dia.

Re: Colar parte de uma planilha no corpo do email

Enviado: 22 Nov 2017 às 07:21
por alexandrevba
Bom dia!!

Você verificou o link que eu postei?
=========================
Preciso colar uma parte da tabela ou seja, só o relato do dia.
Onde fica isso no seu arquivo? :?

Att

Re: Colar parte de uma planilha no corpo do email

Enviado: 24 Nov 2017 às 10:46
por WadsonRocha
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

Re: Colar parte de uma planilha no corpo do email

Enviado: 24 Nov 2017 às 14:48
por alexandrevba
Boa tarde!!

Eu acho que eu não entendi, mas caso isso ajude, tente:
Use a função, Now()
Código: Selecionar todos
Sub MyDateTime()
'http://www.excelfunctions.net/vba-now-function.html
'https://www.techonthenet.com/excel/formulas/now.php
    Range("A1").Value = Now()
End Sub
Att