Adding multiple attachments to E-Mail

[Michael M]

Hi All
I have the following code which I modified from Ron DeBruins site...thanks again Ron.
However, I am trying to let the user add more attachments if required. There is already one "standard" attachment, which is done automatically
At the moment, I have an IF / Then statement , which switches from .display to .send, but the user has to go and select the files each time.
I am curious to know if there is a snippet of code that will alllow the user to open the Insert dialog box or Explorer, select the files to insert and then "plant' the selected files into the code as a variable.

This is a mailout for price tendering and whan extra attachments are required it could apply to a dozen or so E-Mails. Given that I am sending out hundreds, it's no big deal, but it would help speed things up.
Any assistance or even alternative methods would be appreciated

Set OutMail = OutApp.CreateItem(0)
        With Dest
            .SaveAs TempFilePath & TempFileName & FileExtStr, _
                    FileFormat:=FileFormatNum
            On Error Resume Next
        lr = Sheets("List").Cells(Rows.Count, "A").End(xlUp).Row
            Email_Send_From = ""
        ans = MsgBox("Will you need to add further attachments ??", vbYesNo)
                For i = lr To 8 Step -1
                        If Sheets("List").Range("G" & i).Value = 1 Then
                            Set Mail_Object = CreateObject("Outlook.Application")
                                With Mail_Object.CreateItem(o)
                                    .Subject = Sheets("User").Range("B4")
                                    .To = Sheets("List").Range("D" & i).Value
                                    .Body = Sheets("User").Range("B6") & Chr(13) & Chr(13) & Sheets("User").Range("B8")
                                    .Attachments.Add Dest.FullName
                                        If ans = vbYes Then
                                        .display  'requires to send the Email manually
                                        End If
                                    '.send ' will automatically send the email
                                End With
                        End If
                Next
            On Error GoTo 0
            .Close SaveChanges:=False
        End With

 

[daverunt]

Hi Michael,

not sure whether this is entirely what you are after but it may be a good start point. This will allow the user to add multiple extra selected files.

You can use attachments.add repetitively for a mail
So you can add this to your already added attachment code.

.Attachments.Add Dest.FullName
 If ans = vbYes Then
 
'Multiple file select dialog
AttachFileName = Application.GetOpenFilename("Files (*.**)," & _
"*.**", 1, "Select File", "Open", [COLOR=blue]True[/COLOR])
x = 1
 
For i = 1 To UBound(AttachFileName)
'MsgBox Dir(AttachFileName(i))
 
.Attachments.Add AttachFileName(i)
 
Next

 

[daverunt]

..don't know where x=1 came from?

 

[Michael M]

Hi Dave
Thank you for the response and excellent code. However, the current code means if I have say 6 e-mails that need extra attachments, I have to re attach the extra files each time !! I really wanted to include them in the FOR / Next loop.
So, I had a fiddle and while it is probably not elegant, I have achieved the desired result.
I have attached my modified code, and if you are interested you may want to "smarten " it up.......but what they don't see won't hurt them !!!
Many thanks again for your help.

      ans = MsgBox("Will you need to add further attachments ??", vbYesNo)
        If ans = vbYes Then
            AttachFileName = Application.GetOpenFilename("Files (*.**)," & _
                                "*.**", 1, "Select File", "Open", True)
            For i = lr To 8 Step -1
                    If Sheets("List").Range("G" & i).Value = 1 Then
                        Set Mail_Object = CreateObject("Outlook.Application")
                            With Mail_Object.CreateItem(o)
                                .Subject = Sheets("User").Range("B4")
                                .To = Sheets("List").Range("D" & i).Value
                                .Body = Sheets("User").Range("B6") & Chr(13) & Chr(13) & Sheets("User").Range("B8")
                                .Attachments.Add Dest.FullName
                                    For a = 1 To UBound(AttachFileName)
                                        .Attachments.Add AttachFileName(a)
                                    Next
                                 '.send ' will automatically send the email
                                  .display  'requires to send the Email manually
                            End With
                    End If
            Next
            On Error GoTo 0
            .Close SaveChanges:=False
            Kill TempFilePath & TempFileName & FileExtStr
            Set OutMail = Nothing
            Set OutApp = Nothing
            Sheets("List").Range("F8:F" & lr).AutoFilter Field:=6
            Sheets("List").Range("G8:G" & lr).ClearContents
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
            End With
            Exit Sub
       End If
            For i = lr To 8 Step -1
                    If Sheets("List").Range("G" & i).Value = 1 Then
                        Set Mail_Object = CreateObject("Outlook.Application")
                            With Mail_Object.CreateItem(o)
                                .Subject = Sheets("User").Range("B4")
                                .To = Sheets("List").Range("D" & i).Value
                                .Body = Sheets("User").Range("B6") & Chr(13) & Chr(13) & Sheets("User").Range("B8")
                                .Attachments.Add Dest.FullName
                                '.send ' will automatically send the email
                                  .display  'requires to send the Email manually
                            End With
                    End If
            Next
        On Error GoTo 0
        .Close SaveChanges:=False
        End With
        Kill TempFilePath & TempFileName & FileExtStr
        Set OutMail = Nothing
        Set OutApp = Nothing
        Sheets("List").Range("F8:F" & lr).AutoFilter Field:=6
        Sheets("List").Range("G8:G" & lr).ClearContents
             With Application
                 .ScreenUpdating = True
                 .EnableEvents = True
             End With
End Sub

 

[daverunt]

Hi Michael,

glad you got it working.
If I could smarten up your code I would.

 

[Michael M]

Hi Dave
Thanks for the response.....I don't really care if it's a little inelegant. Like I said, it works and the user doesn't have to see it !! Your provided code just sealed it for me !!

Thanks again....I'm sure someone will pop up with something about 3 lines long and we'll both just groan.....LOL !!