Tente adaptar estes código.
1 - Cria uma planilha e salva como pasta habilitada para macro.
2 - Renomeia a plan2 para "Relatório"
3 - Na plan1 crie uma Lista desta forma; seleciona as células da B4:B50 e click no campo de formula esquerdo dei um entra e escreve "Lista". Esta sera o campo de lista aonde vc vai cadastrar os email a ser enviado.
Agora ALT + F11 depois inserir UserForm1
1 - No UserForm1 click em caixa de ferramenta e inserir os seguintes;
ComboBox1, TextBox1, TextBox2 e CommandButton1
Agora dei dois click sobre o userform apaga as duas linha e cole todo este código.
Private Sub UserForm_Initialize()
Me.ComboBox1.List = Application.WorksheetFunction.Transpose(Plan1.Range("B4:B50")) 'AQUI BUSCA OS E-MAIL CADASTRADOS NA PLAN1
End Sub
Private Sub CommandButton1_Click()
On Error GoTo debugs
Application.DisplayAlerts = False
Sheets(Array("Relatório")).Copy 'Aqui salva a planilha Relatório.
' Sheets(Array("Relatório", "Plan3")).Copy 'se quiser mais planilha usa esta linha
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & TextBox1 & ".xlsx" 'Aqui o arquivo salvo recebe o nome do TextBox1
ActiveWorkbook.Save
ActiveWorkbook.Close
Call Enviar_Email 'Aqui chama enviar e-mail
End
debugs: 'Se de erro em salvar o arquivo exclui o arquivo e emiti mensagem qual o erro
MsgBox "ERRO!!!! O E-mail Não Foi Enviado ! ! !", vbOKOnly + vbCritical
If Err.Description <> "" Then MsgBox Err.Description, vbInformation, "O E-MAIL NÃO FOI ENVIADO ! ! ! ! ! ! ! !"
MsgBox "Provavelmente erro; mudança no nome da aba Relatório, ou sem internet,........."
End
End Sub
Sub Enviar_Email() 'aqui envia o email pelo gmail ou se preferir hotmail
'Label6 = "AGUARDE ENVIANDO......"
Application.ScreenUpdating = False
Dim oMensagem As Object
Dim oConfiguração As Object
Dim sCorpo As String
Dim vFields As Variant
Dim objWS As Object
Dim strCaminho As String
On Error GoTo debugs
Set objWS = CreateObject("WScript.Shell")
strCaminho = ThisWorkbook.Path & "\" & TextBox1 & ".xlsx"
'linha em branco
Set oMensagem = CreateObject("CDO.Message")
Set oConfiguração = CreateObject("CDO.Configuration")
oConfiguração.Load -1 'Padrões CDO
Set vFields = oConfiguração.Fields
With vFields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" 'se conta for hotmail usar este = "smtp.live.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 'se for hotmail usar este = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "SeuEmail@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "SenhaDoEmail"
.Update
On Error GoTo debugs
End With
With oMensagem
Set .Configuration = oConfiguração
.To = ComboBox1 'Destino do E-mail.
.cc = "" 'com cópia
.BCC = "" 'com cópia oculta
.From = "<SeuEmail@gmail.com>"
.Subject = TextBox2 'O titulo do e-mail recebe do TextBox2
.TextBody = sCorpo
.AddAttachment strCaminho
.send
'Label6 = ""
If send Then
Else
If resposta = send Then
MsgBox "E-mail Enviado com Sucesso"
Call excluir_Arquivo_Enviado
debugs:
MsgBox "ERRO!!!! O E-mail Não Foi Enviado ! ! !", vbOKOnly + vbCritical
If Err.Description <> "" Then MsgBox Err.Description, vbInformation, "Erro! E-mail Não Foi Enviado ! ! ! ! ! ! ! !"
Kill ThisWorkbook.Path & "\" & TextBox1 & ".xlsx"
UserForm1.Hide
Application.ScreenUpdating = True
End If
End If
End With
End Sub
Sub excluir_Arquivo_Enviado()
On Error Resume Next
Set objWS = CreateObject("WScript.Shell")
Kill ThisWorkbook.Path & "\" & TextBox1 & ".xlsx"
End
End Sub
Espero ter ajudado!
