Este fórum foi descontinuado. LEIA AQUI e participe da Comunidade BABOO :)

Ir para conteúdo
carmelito

macro excel: enviar email + planilha anexa + copiar a célula A1 e colar no assunto e corpo de e-mail, outlook

Mensagem Recomendada

OLá!

"antes de tudo, tentei procurar, pesquisar no google, mas não achei nada parecido, por isso que peço ajuda de vocês."

 

Será que podem me ajudar, preciso enviar um e-mail, criei uma planilha de excel, com um botão, o botão tem vários códigos, entre eles, o de enviar e-mail que segue, no entanto, preciso inserir no assunto o título: "Segue em anexo o edital x" (  x corresponde a célula A1 do arquivo criado).
e no body escrever: "Segue o x (x é a célula A1 do arquivo criado) atualizado, favor, inserir o arquivo em anexo na intranet.
Obrigado.
Atenciosamente,
fulano."


Isso que eu queria que constasse no código abaixo, quem puder ajudar, será bem vindo.


Sub EnviarEmailPlanilhaEspecifica()
2 Dim NovoArquivoXLS As Workbook
3 Dim sPlanAEnviar As String
4 Dim sExcluirAnexoTemporario As String
5
6 'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
7 sPlanAEnviar = "Plan1"
8
9 'Cria um novo arquivo excel
10 Set NovoArquivoXLS = Application.Workbooks.Add
11
12 'Copia a planilha para o novo arquivo criado
13 ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)
14
15 'Salva o arquivo
16 NovoArquivoXLS.SaveAs ThisWorkbook.Path & "\" & sPlanAEnviar & ".xls"
17 sExcluirAnexoTemporario = NovoArquivoXLS.FullName
18
19 'Envia o email
20 NovoArquivoXLS.SendMail "xxxx@xxx.x", "Título do Email teste"
21
22 'Fecha o arquivo novo
23 NovoArquivoXLS.Close
24
25 'Exclui o arquivo criado apenas para ser enviado.
26 Kill sExcluirAnexoTemporario
'27 Sheets("Plan1").cell.ClearContents
28 End Sub


Carmelito

Compartilhar este post


Link para o post
Compartilhar em outros sites
Experimente:

 

"Segue o " & Range("A1").Value & " atualizado, favor, inserir o arquivo em anexo na intranet."

 

o problema que o código que consegui colocar no botão pra enviar e-mail, não permite colocar o texto no corpo do e-mail, que é esse:

   'Envia o email

   NovoArquivoXLS.SendMail "xxxx@xxx.x", "Título do Email teste"

Muito obrigado pela ajuda, se puderes dar, pois não sei mais onde procurar.

até mais.

O Assunto funcionou o seu código, mas não consigo colocar o mesmo no corpo do e-mail, você acha que tem uma solução?

ficou assim: 

 'Envia o email

   NovoArquivoXLS.SendMail "xxxx@xxx.x", "Título do Email teste" & Range("A1").Value & ""

pedidos_teste_versao_4_nova_versaoenviaemail.zip


Carmelito

Compartilhar este post


Link para o post
Compartilhar em outros sites

obrigado pela ajuda osvaldomp, o pessoal do outro forum me ajudou, o código fica assim:

 

Sub Copiar_AleVBA()


Application.ScreenUpdating = False
   Sheets("última_atualização").Cells.ClearContents
   ThisWorkbook.Sheets("cadastro_edital").Range("a1:m1000").Copy
   With Sheets("última_atualização").Range("A" & Rows.Count).End(xlUp)
     .PasteSpecial xlPasteFormats
     .PasteSpecial xlPasteValues
    Selection.Columns.AutoFit
    Selection.Rows.AutoFit
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True

Call Delet_AleVBA
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Ajustar linha e coluna automaticamente
    For Each cell In Target
        If Len(cell.Value) < 5 Then
            Columns(cell.Column).EntireColumn.AutoFit
            Rows(cell.Row).EntireRow.AutoFit
          
        End If
    Next cell
End Sub

 

Sub Delet_AleVBA()
    Dim lRows As Long
    Sheets("última_atualização").Select
    With Range("A7:M7")
     .AutoFilter
     .AutoFilter Field:=5, Criteria1:="sim"
    End With
    Selection.Columns.AutoFit
    Selection.Rows.AutoFit
    Application.Calculation = xlCalculationManual
    For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
        If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
    Next lRows
    ActiveSheet.AutoFilterMode = False
    Application.Calculation = xlCalculationAutomatic
   Selection.Columns.AutoFit
    Selection.Rows.AutoFit
       Call EnviarEmailPlanilhaEspecifica
End Sub
Sub EnviarEmailPlanilhaEspecifica()
 
Dim NovoArquivoXLS As Workbook
Dim sPlanAEnviar As String
Dim sExcluirAnexoTemporario As String
Dim objOlAppApp As Outlook.Application
Dim objOlAppMsg As Outlook.MailItem
Dim objOlAppRecip As Outlook.Recipient
Dim Destinatario As String
Dim x As String

'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
sPlanAEnviar = "última_atualização"


'Cria um novo arquivo excel
Set NovoArquivoXLS = Application.Workbooks.Add

'Copia a planilha para o novo arquivo criado
ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)

'Determina o x
x = Range("c5").Value

'Salva o arquivo
NovoArquivoXLS.SaveAs ThisWorkbook.Path & "\" & sPlanAEnviar & "  " & x & ".xls"
sExcluirAnexoTemporario = NovoArquivoXLS.FullName

'Aqui começa o envio do email:
'Criar objeto do outlook
Set objOlAppApp = CreateObject("Outlook.Application")
Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)

'Determina o destinatário
Destinatario = "xxx@xxx.br"


With objOlAppMsg
'Email do destinatário
Set objOlAppRecip = .Recipients.Add(Destinatario)
objOlAppRecip.Type = olTo
'Anexa o arquivo
.Attachments.Add (sExcluirAnexoTemporario)
'Grau de importância do email
.Importance = olImportanceNormal
'Cabeçalho do email
.Subject = ("Segue em anexo, o arquivo do " & x & " para atualizar o edital na intranet")
'Texto do email
.Body = "Segue o " & x & " atualizado, favor, inserir o arquivo em anexo na intranet." & vbCrLf & "Obrigado." & vbCrLf & "Atenciosamente," & vbCrLf & "Cristina" & vbCrLf & "Serviço de Controle e Provimento de Cargos" & vbCrLf & "Ramal 7239."
'Enviar email
.Send
 'se quiser ver o email antes de enviar automaticamente .Display
 
End With
   
'MsgBox "E-mail enviado com sucesso!", vbOKOnly, "Aviso"

'Fecha o arquivo novo
NovoArquivoXLS.Close

'Exclui o arquivo criado apenas para ser enviado.
Kill sExcluirAnexoTemporario

'Sheets("Plan1").cell.ClearContents
End Sub


 


Carmelito

Compartilhar este post


Link para o post
Compartilhar em outros sites
Em 29/01/2013 at 9:26 AM, osvaldomp disse:

Osvaldo, será que você pode me ajudar? eu não tenho conhecimento de macro, mesmo assim recebi do meu chefe a tarefa de criar um relatório de avaliação que ao terminar de ser preenchido seja renomeado, salvo e encaminhado por e-mail/Outlook. Pesquisei bastante e consegui mesclar informações, então agora tenho duas macros, (1) renomeia e salva copia do arquivo e (2) envia e-mail. O problema é que não consigo fazer as duas funcionarem juntas.

Sub SalvarComo()
NameFolder = "C:\Users\USUARIO\Desktop\Aprendendo Macro"
NameFile = "XXXX - " & Format(Now, "dd-mmm.yyyy - ") & Sheets("Avaliação").Range("c3") & ".xls"
ThisWorkbook.SaveAs (NameFolder & "\" & NameFile)
End Sub


Sub MandaEmail()
    Dim EnviarPara As String
    Dim Mensagem As String
    For i = 1 To 10
        EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
        If EnviarPara <> "" Then
            Mensagem = ThisWorkbook.Sheets(1).Cells(i, 3)
            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 = "x@x.com.br"
        .CC = ""
        .BCC = ""
        .Subject = "XXXX - " & Format(Now, "dd-mmm.yyyy - ") & Sheets("Avaliação").Range("c3")
        .Body = "Olá! Segue Check List de Operações."
        .Attachments.Add ActiveWorkbook.FullName
        .Display 'para envia o email diretamente defina o código Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub
 

Por favor me ajude!!!! Obrigado!

Compartilhar este post


Link para o post
Compartilhar em outros sites

Olá, Fabiano.

Se as duas macros estão funcionado satisfatoriamente é possível rodar as duas em sequência. Coloque no final da primeira um comando para chamar a segunda, conforme abaixo (acrescente a linha em vermelho ao seu primeiro código).

...

ThisWorkbook.SaveAs (NameFolder & "\" & NameFile)

MandaEmail

End Sub


 

Osvaldo

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

×
×
  • Criar Novo...