Notifications
Clear all

Macro envio de e-mail planilha

4 Posts
2 Usuários
0 Reactions
909 Visualizações
(@leohkst)
Posts: 2
New Member
Topic starter
 

Bom dia,

Tenho uma macro pronta para envio de uma ficha que está em uma planilha de um arquivo de excel, porém, a macro envia somente uma planilha (aba) do arquivo, e eu queria incluir mais uma planilha do arquivo neste envio, poderiam me ajudar com este código? Segue macro abaixo:

Sub Envio()
Dim NovoArquivoXLS As Workbook
Dim sPlanAEnviar As String
Dim sExcluirAnexoTemporario As String
Dim end_mail As String
Dim end_mail_copia1 As String
Dim end_mail_copia2 As String
 
Dim FormulaCelula As String
Dim StrIncidente As String
 
'Selection.Copy
'Range("P4").Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
 
'ActiveCell.FormulaR1C1 = "=CONCATENATE(R[1]C[-19],""-"",RIGHT(YEAR(R[-1]C[-19]),2),MONTH(R[-1]C[-19]),DAY(R[-1]C[-19]),HOUR(NOW()))"
 
'=CONCATENAR(E6;"-";DIREITA(ANO(E4);2);MÊS(E4);DIA(E4);HORA(AGORA()))
 
Sheets("Entrada de Dados").Select
    Sheets("8D").Visible = True
 
FormulaCelula = Application.Sheets("8D").Range("N1").FormulaR1C1
 
Sheets("8D").Select
 
Range("N1").Select
 
Application.Sheets("8D").Range("N1").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
StrIncidente = ""
StrIncidente = Application.Sheets("8D").Range("N1").Value
'ActiveCell.FormulaR1C1 = "=CONCATENAR(E6;" - ";DIREITA(ANO(E4);2);MÊS(E4);DIA(E4);HORA(AGORA()))"
 
 
Sheets("8D").Select
 
 
end_mail = Cells(14, 6).Value
end_mail_copia1 = Cells(14, 27).Value
end_mail_copia2 = Cells(16, 28).Value
 
'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
sPlanAEnviar = "8D"
 '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)
 'Salva o arquivo
NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xls"
sExcluirAnexoTemporario = NovoArquivoXLS.FullName
 
'Envia o email
 
 NovoArquivoXLS.SendMail Array(end_mail, end_mail_copia1, end_mail_copia2), "Incidente Logístico Nº " & StrIncidente
 
 'Fecha o arquivo novo
NovoArquivoXLS.Close
 
'Exclui o arquivo criado apenas para ser enviado.
 
Kill sExcluirAnexoTemporario
 
Application.Sheets("8D").Range("N1").FormulaR1C1 = FormulaCelula
 
  Sheets("Entrada de Dados").Select
 
   Sheets("Ficha").Select
    ActiveWindow.SelectedSheets.Visible = False
 
End Sub
 
Sub Foto1()
    FotoGeral ("C51")
End Sub
 
Sub Foto2()
    FotoGeral ("Q51")
End Sub
Sub Foto3()
    FotoGeral ("AE51")
End Sub
Sub Foto4()
    FotoGeral ("C66")
End Sub
Sub Foto5()
    FotoGeral ("Q66")
End Sub
Sub Foto6()
    FotoGeral ("AE66")
End Sub
 
Sub FotoGeral(celula As String)
    Dim Pict
    Dim Imagem As Object
    Dim ImgFileFormat As String
    Dim Sheets As String
   
    Dim Centro, Esquerda, Altura, Largura As Integer
   
    ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
   
    Pict = Application.GetOpenFilename(ImgFileFormat)
    If Pict = False Then End
   
    Topo = Application.Sheets("8D").Range(celula).Top + 3 'Range(Celula).Top
    Esquerda = Application.Sheets("8D").Range(celula).Left + 16 'Range(Celula).Left
    Altura = 290
    Largura = 240
   
    Set Imagem = Application.Sheets("Ficha").Shapes.AddPicture(Pict, msoFalse, msoCTrue, Esquerda, Topo, Altura, Largura)
End Sub

Sou leigo no assunto macros mas qualquer ajuda vai ser de grande importância

Desde já obrigado

 
Postado : 02/03/2016 7:00 am
(@robo8268)
Posts: 73
Trusted Member
 

leohkst você está usando o outlook para o envio?
Se sim, use a propriedade Attachmens.Add

 
Postado : 02/03/2016 8:10 am
(@leohkst)
Posts: 2
New Member
Topic starter
 

Então, na verdade estou utilizando o excel, mas o envio é realizado via Outlook,

Como é um processo que é repetido diversas vezes durante o dia, precisava de uma mudança na Macro com esta alteração (Enviar mais de uma planiha(aba) do arquivo em anexo) , para uma melhor automatização do processo,

Teria como me ajudar? Como sou leigo no assunto se for possível me enviar o código pronto, seria de grande ajuda,

Muito obrigado pelo retorno,

 
Postado : 03/03/2016 7:52 am
(@robo8268)
Posts: 73
Trusted Member
 

Segue um código pronto que eu tenho para enviar planilhas

Sub email()
   'intervalo no qual será copiado para a nova planilha
   Dim rng As Range
   'criando um objeto do tipo pasta de trabalho que posteriormente será anexado no email
   Dim wb As Workbook
   Dim mes As String
   Criando um objeto do tipo aplicação do outlook e um objeto item, que é a janela do email.
   Dim outlook As Object, email As Object
   'caso a planilha já exista, ele deleta para criar uma nova
   On Error Resume Next
   Kill "C:WindowsTempBase de elogios " & mes & " de 2016.xlsx"
   
   mes = ThisWorkbook.Sheets("Base").Range("mesSelecionado").Value
   
   'copia o intervalo
   Set rng = [Base]
   
   rng.Copy
   
   'Cria uma nova planilha
   Set wb = Workbooks.Add
   
   
   wb.Sheets(1).Range("A1").Select
   
  'cola o intervalo na nova planilha
   Selection.PasteSpecial xlPasteAll
   
   wb.Worksheets(1).Columns("A:K").AutoFit
    
   wb.Sheets(1).Name = "2016" & mes
   
   'salva a planilha que será anexada, em uma pasta temporária
   wb.SaveAs "C:WindowsTempBase de elogios " & mes & " de 2016.xlsx"
   Set outlook = CreateObject("Outlook.Application")
   
  'cria uma janela de envio
   Set email = outlook.CreateItem(0)
   
   With email
     'destinatarios
     .To = "Insira seus destinatários aqui"
     'assunto
     .Subject = "Base de elogios " & mes & " de 2016"
     'anexos... propriedade full name pega o caminho no qual a planilha está salva
      .Attachments.Add wb.FullName
     'abre a tela de envio
     .Display
   End With
   
   'fecha a planilha criada
   On Error Resume Next
   wb.Close
   
   'deleta a planilha da pasta temporária
   On Error Resume Next
   Kill wb.FullName
   
End Sub

em caso de dúvidas estou à disposição.

 
Postado : 03/03/2016 1:05 pm