Página 1 de 1

Macro enviar Email

Enviado: Qua Jan 09, 2019 8:59 pm
por klifgdf
Boa noite,
Galera, eu tenho o codigo abaixo que peguei na net para enviar e-mail, como não tenho muito conhecimento em VBA as vezes que alterei o codigo sempre da erro.

na macro abaixo ele só insere os emails para as pessoa que quero enviar e o titulo, eu preciso que a macro coloque também emails em copia e que eu possa digitar o texto do corpo do e-mail.

Código: Selecionar todos

Private Sub CommandButton2_Click()
Dim NovoArquivoXLSX As Workbook
Dim sPlanAEnviar As String
Dim sExcluirAnexoTemporario As String

'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
 sPlanAEnviar = "DADOS"
 
 'Cria um novo arquivo excel
 Set NovoArquivoXLSX = Application.Workbooks.Add
 
 'Copia a planilha para o novo arquivo criado

 ThisWorkbook.Sheets(sPlanAEnviar).Copy before:=NovoArquivoXLSX.Sheets(1)
 
 Columns("A:Q").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
 'NovoArquivoXLS.Sheets(1).PasteSpecial xlValues
 
 'Salva o arquivo
 NovoArquivoXLSX.SaveAs ThisWorkbook.Path & "\" & sPlanAEnviar & ".xlsx"

sExcluirAnexoTemporario = NovoArquivoXLSX.FullName

 'Envia o email
 NovoArquivoXLSX.SendMail Recipients:=Array("email@teste.com"), Subject:="Relatorio de Corte"
 
 
 
 
 'Fecha o arquivo novo
 NovoArquivoXLSX.Close
 
'Exclui o arquivo criado apenas para ser enviado.
Kill sExcluirAnexoTemporario



End Sub




se poderem me ajudar agradeço

Re: Macro enviar Email

Enviado: Qui Jan 10, 2019 12:05 pm
por Wagner Morel
klifgdf0,

Boa tarde!

Não entendi... o código anexado abaixo nada tem a ver com envio de email's.

Re: Macro enviar Email

Enviado: Qui Jan 10, 2019 12:25 pm
por klifgdf
Boa tarde!
Wagner Morel,

a macro citada ela cria a copia do meu arquivo para enviar por e-mail.

abaixo segue a parte do codigo onde é inserido os emails e o titulo,
é nesta parte que tento alterar e sempre da erro.

Código: Selecionar todos

'Envia o email
 NovoArquivoXLSX.SendMail Recipients:=Array("email@teste.com"), Subject:="Relatorio de Corte"

Re: Macro enviar Email

Enviado: Sex Jan 11, 2019 11:50 am
por Wagner Morel
klifgdf0,

Bom dia!

Existem formas mais práticas de enviar e-mail diretamente do Excel. Anexe seu arquivo aqui no fórum, compactado com .ZIP e informe se envia email pelo outlook ou por outro provedor de email.

Re: Macro enviar Email

Enviado: Sex Jan 11, 2019 12:44 pm
por klifgdf
Boa tarde!
Obrigado aos que deram atenção.

consegui resolver o meu problema.

peguei um outro codigo de enviar email e inseri algumas linhas do codigo anterior.

abaixo segue codigo caso alguem nescessite.



Código: Selecionar todos

Private Sub CommandButton2_Click()

' Don't forget to copy the function GetBoiler in the module.
 Dim OutApp As Object
 Dim OutMail As Object
 Dim strbody As String
 Dim SigString As String
 Dim Signature As String
 Dim NovoArquivoXLSX As Workbook
 Dim sPlanAEnviar As String
 Dim sExcluirAnexoTemporario As String
 
 
 'Define a planilha que será enviada por email. Ex.: Plan1, Balancete, Lista De Nomes, etc
 sPlanAEnviar = "DADOS"
 
 'Cria um novo arquivo excel
 Set NovoArquivoXLSX = Application.Workbooks.Add
 
 'Copia a planilha para o novo arquivo criado

 ThisWorkbook.Sheets(sPlanAEnviar).Copy before:=NovoArquivoXLSX.Sheets(1)
 
 Columns("A:Q").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
   'Salva o arquivo
 NovoArquivoXLSX.SaveAs ThisWorkbook.Path & "\" & sPlanAEnviar & ".xlsx"

sExcluirAnexoTemporario = NovoArquivoXLSX.FullName
 

 

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
    "Local da assinatura"
  
 If Dir(SigString) <> "" Then
 
    Signature = GetBoiler(SigString)
    
    Signature = ""
 Else
 
   
    
 End If
 
    On Error Resume Next
    
    
 With OutMail
  .To = "Emails@teste.com.br"
  .CC = "Emails@teste.com.br"
  .Subject = "Titulo do email"
  .HTMLBody = .strbody & "<br>" & Signature
  .Attachments.Add ("Local do Arquivo")

  .Display 'or use .Send
  
 End With
 
  On Error GoTo 0
  
   Set OutMail = Nothing
   Set OutApp = Nothing
   'Fecha o arquivo novo
 NovoArquivoXLSX.Close
 'Exclui o arquivo criado apenas para ser enviado.
Kill sExcluirAnexoTemporario
 
 
 
 End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function