Notifications
Clear all

Enviar e-mail diretamente do Excel sem o uso Outlook.

11 Posts
4 Usuários
0 Reactions
1,968 Visualizações
(@polchera)
Posts: 0
New Member
Topic starter
 

Boa tarde! Meu nome é Luciano moro em Colatina/ES.
Estou precisando que a planilha em questão envie e-mail automaticamente ao abri-la com os dados constantes na mesma para todos os destinatários da coluna "F" sempre que um prazo da coluna "E" for <=30 dias.
A intenção é que sempre que a planilha for aberta verificar a condição (<=30 dias) e enviar o e-mail.
Problemas:
1-Não estou conseguindo fazer a planilha executar ao abrir, ou seja, verificar a condição (<=30 dias) e enviar o e-mail;
2-Não sei como inserir a condição (coluna "E" for <=30 dias);
3-Não sei como coletar as informações da planilha para carregar no e-mail.

Private Sub Workbook_Open()

linhadados = 2
conta = 0

Do While Sheets(1).Cells(linhadados, 5).Value <> ""

    If Sheets(1).Cells(linhadados, 5).Value = 30 Then
End If

Function Enviaemail()
Dim iMsg, iConf, Flds

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
'Configura o smtp
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
'Configura o email do remetente
Flds.Item(schema & "sendusername") = "xxx@gmail.com"
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = "9999"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
   'Email do destinatário
   .To = Range("F2")
   .To = Range("F3")
   .To = Range("F4")
   'Seu email
   .From = "xxx@gmail.com"
   'Título do email
   .Subject = "Aviso de vencimento - Certificado Digital"
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = "Em anexo Certificado Digital com vencimento menor que 30 dias."
   'Seu nome ou apelido
   .Sender = "Luciano"
   'Nome da sua organização
   .Organization = "XXXX S/A"
   'e-mail de responder para
   .ReplyTo = "xxx@gmail.com"
    Set .Configuration = iConf
   .Send
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Function

Sub disparar()
   Enviaemail
   MsgBox "O e-mail foi disparado com sucesso!", vbOKOnly, "e-mail enviado"
End Sub
 
Postado : 25/12/2017 6:07 am
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

Luciano,

Boa noite!

Seja muito bem vindo ao fórum.

Para aproveitar ao máximo o fórum e sempre manter o mesmo de forma organizada, sugiro ler os tópico da regras abaixo:
viewtopic.php?f=7&t=16757
viewtopic.php?f=7&t=203
viewtopic.php?f=7&t=7903
viewtopic.php?f=7&t=3841
viewtopic.php?f=7&t=12600
viewtopic.php?f=7&t=3371

Quanto a sua demanda, somente agora que estava lendo a sua mensagem do dia 25/12. Não sei se a resposta ainda lhe interessa...

Pedimos, por gentileza, quando postar códigos VBA aqui no fórum, utilizar a ferramenta CODE que fica localizada logo acima da caixa de mensagens.

O que é que não está funcionando no seu código? Dá algum erro? Anexo seu arquivo aqui mesmo no fórum, compactado com .ZIP. Isso facilitará a resposta de forma mais rápida.

 
Postado : 30/12/2017 5:34 pm
(@polchera)
Posts: 0
New Member
Topic starter
 

wagner

Obrigado!
Ainda aguardo ajuda.

 
Postado : 07/01/2018 10:14 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Movi teu tópico para VBA & Macros que é o assunto da tua dúvida.

Onde você havia postado, não é permitido postar dúvidas, é exclusivo para a apresentação dos novos usuários.

[]s

Patropi - Moderador

 
Postado : 07/01/2018 12:57 pm
(@klarc28)
Posts: 0
New Member
 
Private Sub Workbook_Open()

linhadados = 2

Do While Sheets(1).Cells(linhadados, 5).Value <> ""

    If Sheets(1).Cells(linhadados, 5).Value <= 30 Then
    Call Enviaemail(linhadados)
    
End If

End Sub
Sub Enviaemail(ByVal linha As Long)
Dim iMsg, iConf, Flds

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
'Configura o smtp
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
'Configura o email do remetente
Flds.Item(schema & "sendusername") = "xxx@gmail.com"
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = "9999"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
   'Email do destinatário
   .To = Planilha1.Range("F" & linha)
 '  .To = Range("F3")
'   .To = Range("F4")
   'Seu email
   .From = "xxx@gmail.com"
   'Título do email
   .Subject = "Aviso de vencimento - Certificado Digital"
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = "Em anexo Certificado Digital com vencimento menor que 30 dias."
   'Seu nome ou apelido
   .Sender = "Luciano"
   'Nome da sua organização
   .Organization = "XXXX S/A"
   'e-mail de responder para
   .ReplyTo = "xxx@gmail.com"
    Set .Configuration = iConf
   .Send
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
   MsgBox "O e-mail foi disparado com sucesso!", vbOKOnly, "e-mail enviado"

End Sub


 
Postado : 07/01/2018 1:12 pm
(@polchera)
Posts: 0
New Member
Topic starter
 

Não está dando certo.

 
Postado : 08/01/2018 9:35 pm
(@klarc28)
Posts: 0
New Member
 
Private Sub Workbook_Open()

linha = 2

Do While Sheets(1).Cells(linha, 5).Value <> ""

    If Sheets(1).Cells(linha, 5).Value <= 30 Then
    Call Enviaemail(linha)
    
End If
linha = linha + 1
Loop
End Sub
Sub Enviaemail(ByVal linha As Long)
'Necessario realizar a chamada da biblioteca Microsoft CDO for Windows 2000 Library
'Necessário alterar a configuração do Gmail
'Permitir que aplicativos menos seguros usem sua conta
Dim iMsg, iConf, Flds

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
'Configura o smtp
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
'Configura a porta de envio de email
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
'Configura o email do remetente
Flds.Item(schema & "sendusername") = "diniabr2011@gmail.com"
'Configura a senha do email remetente
Flds.Item(schema & "sendpassword") = "senha"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
   'Email do destinatário
   .To = Planilha1.Range("F" & linha).Value
 '  .To = Range("F3")
'   .To = Range("F4")
   'Seu email
   .From = "diniabr2011@gmail.com"
   'Título do email
   .Subject = "Aviso de vencimento "
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = "Em anexo comprovante de vencimento"
   'Seu nome ou apelido
   .Sender = "ANDERSON DINIZ"
   'Nome da sua organização
   .Organization = "MINHA EMPRESA"
   'e-mail de responder para
   .ReplyTo = "diniabr2011@gmail.com"
   'ANEXO
     .AddAttachment Planilha1.Range("G" & linha).Value
    Set .Configuration = iConf
   .Send
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
   MsgBox "O e-mail para " & Planilha1.Range("F" & linha).Value & " foi disparado com sucesso!", vbOKOnly, "e-mail enviado"

End Sub

 
Postado : 09/01/2018 4:24 am
(@klarc28)
Posts: 0
New Member
 

Necessário realizar a chamada da biblioteca Microsoft CDO for Windows 2000 Library

 
Postado : 09/01/2018 4:41 am
(@klarc28)
Posts: 0
New Member
 

É necessário configurar o Gmail:

https://www.youtube.com/watch?v=1lL81rGUSLA
https://support.google.com/accounts/answer/6010255?hl=pt-BR

Como pode ver na imagem, funcionou perfeitamente.

 
Postado : 09/01/2018 4:45 am
(@polchera)
Posts: 0
New Member
Topic starter
 

Ok! Estava faltando marcar o Microsoft CDO for Windows 2000 Library, porém só executa manualmente, Workbook_Open não esta executado automaticamente ao abrir o arquivo.

 
Postado : 09/01/2018 10:27 pm
(@klarc28)
Posts: 0
New Member
 

Naquela planilha não consegui, fiz outra planilha (em anexo).

 
Postado : 10/01/2018 9:31 am