none
Botão enviando parte da planilha a emails RRS feed

  • Pergunta

  •  Quero criar um "botão " que mandaria a pagina para um grupo de email, porem não pode ser em anexo, o corpo do email seria a planilha, e também com um titulo espenicado na pagina, exemplo ter um campo da pagina aonde editaria que seria o titulo.

    sexta-feira, 31 de outubro de 2014 21:58

Respostas

  • 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!
    segunda-feira, 3 de novembro de 2014 19:58