Copiar Planilha e Enviar como Anexo por Email com Outlook VBA

Copiar Planilha Excel e Enviar como Anexo por Email com Outlook VBA
Objetivo: Enviar planilha atual por email utilizando o Outlook.

Esta planilha utiliza-se da biblioteca do Outlook para enviar por email a planilha que você tenha aberta no momento.

Foi criada para ajudar a leitora Eliane Peller.

Abaixo o código fonte:

<pre><span style="color: #339966;">Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
    As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Public Sub lsCriarEnviar()
    Dim lQtdePlan   As Integer
    Dim lPlanAtual  As Integer
    Dim lCaminho    As String
 
    lCaminho = Worksheets("Configuração").Range("B1").Value
 
    lsCriarArquivo lCaminho, Worksheets("Configuração").Range("B1").Value &amp; ActiveSheet.Name &amp; ".xlsx"
 
End Sub
 
Private Sub lsCriarPasta(ByVal lPasta As String)
    On Error Resume Next
    MkDir lPasta
End Sub
 
Private Sub lsCriarArquivo(ByVal lCaminho As String, ByVal lArquivo As String)
    Dim lNomeArquivo    As String
 
    lsCriarPasta Sheets("Configuração").Range("B1")
 
    lNomeArquivo = Sheets("Configuração").Range("B1") &amp; ActiveSheet.Name &amp; ".xlsx"
    lArquivo = ActiveSheet.Name &amp; ".xlsx"
 
    Sheets(ActiveSheet.Name).Copy
    ChDir lCaminho
    ActiveWorkbook.SaveAs Filename:= _
        lNomeArquivo, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
 
    lsEnviarEmail
    Windows("EnviarPastaAtivaPorEmail.xlsm").Activate
    Windows(lArquivo).Activate
    Windows(lArquivo).Close (True)
End Sub
 
Public Function gfSelecionarPasta(ByVal vFolder As String, Optional Title As String, Optional hWnd) As String
 
    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String
 
    folder = String$(255, Chr$(0))
 
    With bi
        If IsNumeric(hWnd) Then .hOwner = hWnd
        .pidlRoot = 0
        If Title &lt;&gt; "" Then
            .lpszTitle = Title &amp; Chr$(0)
        Else
            .lpszTitle = "Select a Folder" &amp; Chr$(0)
        End If
    End With
 
    pidl = SHBrowseForFolder(bi)
 
    If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
        folder = Left(folder, InStr(folder, Chr$(0)) - 1)
    Else
        folder = ""
    End If
 
    If Right(folder, 1) &lt;&gt; "\" And Len(folder) &gt; 0 Then folder = folder &amp; "\"
 
    gfSelecionarPasta = folder
 
End Function
 
Public Sub gsPasta()
    Dim lPasta As String
 
    lPasta = gfSelecionarPasta("C:", "Selecione o local aonde será gravado o arquivo:")
 
    Cells(1, 2).Value = lPasta
End Sub
 
'Enviar email
Sub Enviar_email(ByVal lEndereco As String, ByVal lAnexo As String)
    Dim enderecos As Range
    Dim celula As Range
    Dim r As Integer
    Dim fim
    Dim enviar
    Dim objOlAppApp As Outlook.Application
    Dim objOlAppMsg As Outlook.MailItem
    Dim objOlAppRecip As Outlook.Recipient
    Dim objOlAppAnexo As Outlook.Attachment
 
    'Criar objeto do outlook
    Set objOlAppApp = CreateObject("Outlook.Application")
    Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)
 
    With objOlAppMsg
        'Email do destinatário
        Set objOlAppRecip = .Recipients.Add(lEndereco)
        objOlAppRecip.Type = olTo
        'Grau de importância do email
        .Importance = olImportanceHigh
        'Cabeçalho do email
        .Subject = ActiveSheet.Name
        'Texto do email
        .Body = ActiveSheet.Name
        'Anexo
        Set objOlAppAnexo = .Attachments.Add(lAnexo)
        'Enviar email
        .Send
    End With
 
    'Liberar variáveis
    Set objOlAppApp = Nothing
    Set objOlAppMsg = Nothing
    Set objOlAppAnexo = Nothing
    Set objOlAppRecip = Nothing
End Sub
 
'Enviar emails das pendências
Sub lsEnviarEmail()
    Dim lEmail As String
 
    lEmail = InputBox("Digite o endereço do email:", "Email...", ActName)
 
    If lEmail &lt;&gt; "" Then
        Windows("EnviarPastaAtivaPorEmail.xlsm").Activate
        Enviar_email lEmail, Sheets("Configuração").Range("B1").Value &amp; ActiveSheet.Name &amp; ".xlsx"
    End If
End Sub</span>

Para utilizar este arquivo você não deve esquecer de apontar as referências conforme descrito no link http://guiadoexcel.com.br/5w2h-envio-por-email-das-pendencias-vba-e-outlook.

GUT PPT

Abraço

Marcos Rieper

SISTEMA DE GESTÃO CONTA AZUL

O Excel é uma plataforma de trabalho muito aberta para servir ao gerenciamento de dados de uma empresa, dado a complexidade e a integração entre as diversas áreas que a compõe. Mas é a melhor para analisar suas informações.

Com a intenção de atender as micro e pequenas empresas a Conta Azul criou um software de gestão aonde você tudo o que você precisa para gerir a sua empresa: Estoque, Vendas, Financeiro e ainda emite Nota Fiscal Eletrônica, tudo isso em um sistema simples de trabalhar, que você acessa pela internet, não há a necessidade de comprar servidores e preocupar-se com backup e atendimento através de 0800.

O preço da ferramenta também chama a atenção, sendo um preço mais do que justo para se ter o controle dos dados e a geração de informações para a análise do seu negócio.

ContaAzul é um software de gestão financeira e fiscal para micro e pequenas empresas. Ele funciona 100% em plataforma web, não necessitando nenhuma instalação ou atualização. Você pode acessar de qualquer lugar e não tem necessidade de comprar nova licença caso troque de computador.

  O Guia do Excel recomenda o Conta Azul no gerenciamento de sua empresa.
Use QR-Code to get this permaking using your Smartphone. QR Code for Copiar Planilha e Enviar como Anexo por Email com Outlook VBA

6 Comentários

  1. Ramerson disse:

    Muito bom esse post, é claro que tem que habilitar as Bibliotecas do OutLook, isso dentro do Painel de programação VBA, vá no menu Ferramentas (tools) -> Preferencias ( Preferencies ) selecione a Opção Microsoft OutLook …

    Parabens Pelo Post

  2. Walter Bernal disse:

    Marcos,

    Esta dando erro nessa macro na hora de selecionar o botão de salvar o caminho.

    Abraço

  3. Lucio Carvalho disse:

    ‘Segue uma bem mais simples:

    Sub Parametros()

    destino = Sheets(“Plan1″).Range(“C2″).Value
    titulo = Sheets(“Plan1″).Range(“C3″).Value
    msg = Sheets(“Plan1″).Range(“C4″).Value
    Anexo = “W:\Informação de Negocio\Lucio\teste.txt”

    Call Envia(destino, titulo, msg, Anexo)

    MsgBox “Enviado”

    End Sub

    Public Sub Envia(destino, titulo, msg, Anexo)
    Dim OutLook
    Dim EmailItem
    Dim Email

    Set OutLook = CreateObject(“OutLook.Application”)

    ATE = Sheets(“Plan1″).Range(“D2″).Value

    For x = 1 To ATE
    Set Email = OutLook.createItem(EmailItem)

    With Email
    .To = destino
    .Subject = titulo
    .body = msg
    .Attachments.Add (Anexo)
    .send
    End With
    Set Email = Nothing

    Next x

    Set OutLook = Nothing

    End Sub

  4. Marcos Rieper disse:

    Obrigado pela contribuição Lúcio.

    Abraço

    Marcos Rieper

  5. Marcos Rieper, tenho uma macro mais não consigo adicionar o endereço do anexo.
    Será que consege me ajudar ?

    Agradeço desde já, segue macro !

    Sub teste()
    Dim contador As Integer

    Set enderecos = Range(“D1:D1″)
    contador = 0
    ‘Processar endereços para o envio
    For Each celula In enderecos

    Enviar_email Sheets(“Sheet1″).Range(“D” & enderecos.Row + contador).Value, Sheets(“Sheet1″).Range(“E” & enderecos.Row + contador).Value, “”
    contador = contador + 1
    Next
    End Sub
    Sub Enviar_email(celula As String, celula2 As String, arquivo As String)
    ‘celula = primeiro remetente
    ‘celula2 = segundo remetente
    ‘arquivo caso não exista =”"
    Dim anexo As String
    Dim r As Integer
    Dim objOlAppApp As Outlook.Application
    Dim objOlAppMsg As Outlook.MailItem
    Dim objOlAppRecip As Outlook.Recipient
    Dim objOlAppAnexo As Outlook.Attachment

    Set objOlAppApp = CreateObject(“Outlook.Application”)
    Set objOlAppMsg = objOlAppApp.CreateItem(olMailItem)
    ‘Celulas com os endereços
    With objOlAppMsg
    If celula “” And InStr(1, celula, “@”) > 0 Then
    Set objOlAppRecip = .Recipients.Add(celula)
    objOlAppRecip.Type = olTo
    ‘definir o tipo do destinatario
    If celula2 “” Then
    Set objOlAppRecip = .Recipients.Add(celula2)
    End If
    objOlAppRecip.Type = olCC
    End If
    ‘verificar se existe destinatário
    If .Recipients.Count = 0 Then GoTo fim
    ‘Anexar ficheiro, com o nome e caminho escrito na celula C13
    anexo = arquivo
    ‘verificar se o caminho para o anexo é válido
    If Dir(anexo) = “” Then
    r = MsgBox(“Anexo inexistente ou caminho invalido, ” & _
    “pretende enviar assim mesmo ? “, _
    vbYesNo, _
    “Erro de anexo”)
    If r = vbYes Then GoTo enviar Else GoTo fim
    End If
    If arquivo “” Then
    Set objOlAppAnexo = .Attachments.Add(anexo)
    End If
    enviar:
    ‘definir a sua importancia
    .Importance = olImportanceHigh
    ‘O assunto
    .Subject = “Exemple text”
    ‘O conteudo do Mail
    .Body = “Exemple text,” & vbCrLf & _
    “” & vbCrLf & _
    “Exemple text.” & vbCrLf & _
    “Exemple text” & vbCrLf & _
    “” & vbCrLf & _
    “Exemple text.” & vbCrLf & _
    “” & vbCrLf & _
    “Exemple text,” & vbCrLf & _
    “” & vbCrLf & _
    “Exemple text”

    ‘enviar mensagem
    .Send
    End With
    fim:
    ‘Libertar as variaveis
    Set objOlAppApp = Nothing
    Set objOlAppMsg = Nothing
    Set objOlAppAnexo = Nothing
    Set objOlAppRecip = Nothing
    End Sub

  6. Marcos Rieper disse:

    Boa tarde Lúcio,

    Pode postar a sua dúvida com a planilha no nosso fórum http://www.guiadoexcel.com.br/forum, eu não entendi bem também sobre o endereço do anexo, explique no fórum por favor.

    Abraço

    Marcos Rieper

Deixe o seu comentário


 
%d blogueiros gostam disto: