Enviar mais de 1 anexo PDF email

[Rafael Peixoto]

Bom dia.

Sou iniciante aventureiro em VBA e preciso de ajuda.

Quero quma macro que abra a caixa de dialogo onde eu possa selecionar mais de  um arquivo e posteriormente todos serem anexados em um email..

Consegui fazer, porém mesmo selecionado vários arquivos, apenas o primeiro é anexado.   Como posso fazer?

 

Segue o código
 

Sub Enviar_Email()

Dim objMsg As MailItem
Dim intChoice As Integer
Dim strFile As String
    
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
 With xEmailObj
               
        Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
intChoice = Application.FileDialog(msoFileDialogOpen).Show

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

        .Display
        .To = Sheets("CADASTRO").Range("b6").Value
        .CC = Sheets("CADASTRO").Range("B7").Value
        .Subject = "INFORME LANÇAMENTOS EM RESCISÃO"
        .Attachments.Add (strFile)
        
        .HTMLBody = "<p style = 'font-family: calibri; font-size: 14'> Prezado,<br /><br /> Segue anexo PDA para lan&ccedil;amento em rescis&atilde;o.<br /><br /><ul>Empresa: <b>" & Range("b6").Value & "</b><br />Matrícula: <b>" & Range("d8").Value & "</b><br />Nome: <b>" & Range("b8").Value & "</b><br />Demiss&atilde;o: <b>" & Range("g8").Value & " </b><br />Tipo de Demiss&atilde;o: <b>" & Range("b10").Value & "</b><br /><br /></ul> " & vbCrLf & "Atenciosamente," & "<br>" & .HTMLBody
        
If DisplayEmail = False Then
'.Send

End If
  
End With

Set objMsg = Nothing

End Sub

 

[Alyson Ronnan Martins]

@Rafael Peixoto Boa noite. 

Eu fiz a seguinte alteração mais não testei olha ai e da um retorno para agente.

Sub Enviar_Email()

Dim objMsg As MailItem
Dim intChoice As Integer
Dim strFile As String
    
Print
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
    intChoice = Application.FileDialog(msoFileDialogOpen).Show

    .Display
    .to = Sheets("CADASTRO").Range("b6").Value
    .CC = Sheets("CADASTRO").Range("B7").Value
    .Subject = "INFORME LANÇAMENTOS EM RESCISÃO"
        
    If intChoice <> 0 Then 'Verificar se tem arquivo selecionado
        'Conta quantos arquivos tem selecionados
        qtdArquivos = Application.FileDialog(msoFileDialogOpen).SelectedItems.Count
        
        For x = 1 To qtdArquivos Step 1
            strFile = Application.FileDialog(msoFileDialogOpen).SelectedItems(x) 'Endereço do arquivo
            .Attachments.Add (strFile)
        Next x
        
    End If
        
        .HTMLBody = "<p style = 'font-family: calibri; font-size: 14'> Prezado,<br /><br /> Segue anexo PDA para lan&ccedil;amento em rescis&atilde;o.<br /><br /><ul>Empresa: <b>" & Range("b6").Value & "</b><br />Matrícula: <b>" & Range("d8").Value & "</b><br />Nome: <b>" & Range("b8").Value & "</b><br />Demiss&atilde;o: <b>" & Range("g8").Value & " </b><br />Tipo de Demiss&atilde;o: <b>" & Range("b10").Value & "</b><br /><br /></ul> " & vbCrLf & "Atenciosamente," & "<br>" & .HTMLBody
        
If DisplayEmail = False Then
'.Send

End If
  
End With

Set objMsg = Nothing

End Sub