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:

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 & ActiveSheet.Name & ".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") & ActiveSheet.Name & ".xlsx"
    lArquivo = ActiveSheet.Name & ".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 <> "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "Select a Folder" & 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) <> "\" And Len(folder) > 0 Then folder = folder & "\"

    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 <> "" Then
        Windows("EnviarPastaAtivaPorEmail.xlsm").Activate
        Enviar_email lEmail, Sheets("Configuração").Range("B1").Value & ActiveSheet.Name & ".xlsx"
    End If
End Sub

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.

Abraço

Marcos Rieper