1

fiz uma macro onde ela abre o outlook, até ai beleza. agora preciso complementar ela com o seguinte itens.

Preciso pegar 4 abas da minha planilha, gerar um novo arquivo e depois anexar no e-mail e enviar.

Alguem pode me ajudar?

segue o codigo ( esse codigo só abre o excel )

Sub MandaEmail()

    Dim EnviarPara As String
    Dim Mensagem As String
    For i = 1 To 1
        EnviarPara = Worksheets("Tabela").Cells(5, 35)
        If EnviarPara <> "" Then
            Mensagem = Worksheets("Tabela").Cells(6, 35)
            Texto = Worksheets("Tabela").Cells(7, 35)
            Envia_Emails EnviarPara, Mensagem
        End If
    Next i
End Sub
Sub Envia_Emails(EnviarPara As String, Mensagem As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = EnviarPara
        .CC = ""
        .BCC = ""
        .Subject = Mensagem
        .Body = "Bom dia"
        .Display ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
1
  • esta na mão daniel obrigado pela ajuda Commented 21/05/2018 às 13:08

1 Resposta 1

1

Código

Sub MandaEmail()

    Dim EnviarPara As String
    Dim Mensagem As String, caminho As String, Texto As String
    Dim wb As Workbook
    'Criar Arquivo
    caminho = ThisWorkbook.Path & "\" & "temp.xlsx"
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(Array("Planilha1", "Planilha2", "Planilha3", "Planilha4")).Copy
    ActiveWorkbook.SaveAs Filename:=caminho, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

    'Enviar Email
    For i = 1 To 1
        EnviarPara = Worksheets("Tabela").Cells(1, "A")
        If EnviarPara <> "" Then
            Mensagem = Worksheets("Tabela").Cells(2, "A")
            Texto = Worksheets("Tabela").Cells(3, "A")
            Envia_Emails EnviarPara, Mensagem, caminho, Texto
        End If
    Next i

    Kill caminho 'Deleta o arquivo

    Application.DisplayAlerts = True
End Sub

Sub Envia_Emails(EnviarPara As String, Mensagem As String, caminho As String, Texto As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .Display
        Signature = .HTMLbody
        .To = EnviarPara
        .CC = ""
        .BCC = ""
        .Subject = Mensagem
        .Attachments.Add caminho
        .HTMLbody = "Bom dia" &  "<br>"& Texto &  "<br>" & Signature
        .Display                                 ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Explicação

Você adiciona o anexo no Outlook com .Attachments.Add

E cria um novo arquivo Excel com as planilhas desejadas com: ThisWorkbook.Sheets(Array("Planilha1", "Planilha2", "Planilha3", "Planilha4")).Copy

Depois salva a planilha na mesma pasta que o arquivo excel: ActiveWorkbook.SaveAs Filename:=caminho, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False e no fim do programa deleta este arquivo Excel Kill caminho

Para outras maneiras de inserir as tabelas no corpo do e-mail, ver esta resposta

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .