Jump to content
Fórum Script Brasil
  • 0

Enviar mais de 1 anexo PDF email


Question

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

 

Link to post
Share on other sites

1 answer to this question

Recommended Posts

  • 0

@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

 

Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.



  • Forum Statistics

    • Total Topics
      148692
    • Total Posts
      644524
×
×
  • Create New...