Este fórum está sendo desativado

Depois de 9 anos, este fórum será desativado. Mas calma.... estamos migrando para uma comunidade no DISCORD. Junte-se a nós.

ENTRAR PARA DISCORD

Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
#28310
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.
Você não está autorizado a ver ou baixar esse anexo.
#28327
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
#28417
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
#28424
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
long long title how many chars? lets see 123 ok more? yes 60

We have created lots of YouTube videos just so you can achieve [...]

Another post test yes yes yes or no, maybe ni? :-/

The best flat phpBB theme around. Period. Fine craftmanship and [...]

Do you need a super MOD? Well here it is. chew on this

All you need is right here. Content tag, SEO, listing, Pizza and spaghetti [...]

Lasagna on me this time ok? I got plenty of cash

this should be fantastic. but what about links,images, bbcodes etc etc? [...]

Estamos migrando para uma comunidade no Discord