attach file and send vba email

Question

Good morning guys, I need some help.. I have this macro she’s working perfectly but I need to add 1 things to it.

When she run and generate the new file with the tabs I selected, I need you to open the outlook, that new file gets attached to it.

someone can help me?

follows the Cod.

' MACRO PARA CRIAR PASTA DE ANO/MES/DIA

Public Const sCaminho = "pasta local para salvar"
Dim Pasta As New FileSystemObject

Public Function fnccriardiretorio(data As Date)
If Pasta.FolderExists(sCaminho & "\" & Format(data, "yyyy")) Then
    fncmes (data)
Else
    Pasta.CreateFolder (sCaminho & "\" & Format(data, "yyyy"))
    fncmes (data)
End If


End Function

Public Function fncmes(data As Date)
If Pasta.FolderExists(sCaminho & "\" & Format(data, "yyyy") & _
"\" & Format(data, "mmmm")) Then
    Call fncdia(data)
Else
    Pasta.CreateFolder (sCaminho & "\" & Format(data, "yyyy") & _
"\" & Format(data, "mmmm"))
    Call fncdia(data)
End If
End Function

Public Function fncdia(data As Date)
If Pasta.FolderExists(sCaminho & "\" & Format(data, "yyyy") & _
"\" & Format(data, "mmmm") & "\" & Format(data, "dd")) Then

Else
    Pasta.CreateFolder (sCaminho & "\" & Format(data, "yyyy") & _
"\" & Format(data, "mmmm")) & "\" & Format(data, "dd")
End If


End Function

Sub salvareenviaremail()

Dim data As Date
data = Now()
Call fnccriardiretorio(data)
 Dim ws3 As Worksheet
 Dim UltimaLinhaE As Long


fname1 = (sCaminho & "\" & Format(data, "yyyy") & _
"\" & Format(data, "mmmm")) & "\" & Format(data, "dd") & _
"\" & "nome do arquivo"


    Worksheets(Array("Planilha1", "Planilha2", "Planilha3")).Copy

    Set ws3 = ActiveWorkbook.Worksheets("Planilha3")
    With ws3
        'Limpa os Autofiltros da Planilha para evitar erros
        If .FilterMode Then
            .ShowAllData
        End If
        'Última Linhada colunaE
        UltimaLinhaE = .Cells(.Rows.Count, "E").End(xlUp).Row
        'Autofiltro
        .Range("E1:E" & UltimaLinhaE).AutoFilter Field:=5, Criteria1:="Cell 01"
    End With


Set ws4 = ActiveWorkbook.Worksheets("Planilha2")
    With ws4

        'Limpa os Autofiltros da Planilha para evitar erros
        If .FilterMode Then
            .ShowAllData
        End If

        'Última Linhada colunaE
        UltimaLinhaE = .Cells(.Rows.Count, "E").End(xlUp).Row

        'Autofiltro
        .Range("E1:E" & UltimaLinhaE).AutoFilter Field:=5, Criteria1:="Cell 02"

    End With

    With ActiveWorkbook
        ActiveWorkbook.SaveAs Filename:=fname1, FileFormat:=xlOpenXMLWorkbookMacroEnabled

    End With
End Sub

Answer 1

First place the following line before the End Sub of its first function

Call Abrir_outlook

Then add this second function. Note that I have commented on some fields that may not be useful to you.

Sub Abrir_outlook()

Shell ("OUTLOOK")

Dim objMsg As MailItem
Dim intChoice As Integer
Dim strPath As String

Set objMsg = Application.CreateItem(olMailItem)

 With objMsg
  .To = "endereço de destino"
  .CC = "endereços copiados"
  .BCC = "endereços copisados ocultos"
  .Subject = "Assunto"
  .Categories = "Teste"
  '.VotingOptions = "sim, não, talvez"
  .BodyFormat = olFormatPlain
  '.Importance = olImportanceHigh
  '.Sensitivity = olConfidential

Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show

If intChoice <> 0 Then
    strPath = Application.FileDialog( _
        msoFileDialogOpen).SelectedItems(1)
End If

  .Attachments.Add (strPath)

  .Display
End With

Set objMsg = Nothing

End Sub