E-mail multiple attachments using outlook

[Peaceless]

Hi!

Ok so I have searched high and low for this but cannot seem to find anything that solves all of my problems in one go. I hope someone here will hear my cry for help!

This is my situation;

I have a master Excel file with lots of different functuality. My last issue to solve is to send some files to an e-mailadress.
The files are created by a macro and named according to a combination created by values in the master file. The names will vary between each time the master file is used. The files are copies, with values, of hidden sheets within the master file. The number of files can range from 1 up to 16 and are saved in the same location as where ever the master file is located. I want to grab those files, however many they are, attach them to an e-mail (outlook) and send them to an e-mailaddress specified in a cell in the master file.

An alternativ would be to make some temp-files, with values, and send those in an e-mail. The sheets created are visible in the master file, but the master file contains three other visible sheets together with some other hidden sheets, that are not supposed to be e-mailed.

I´m thinking I could modify the following but am not able to modify it myself for multiple sheets and attach multiple files

Sub SendInlösen()
     'Variable declaration
    Dim oApp As Object, _
    tag As String, _
    oMail As Object, _
    WB As Workbook, _
    FileName As String
     
     'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Sheets("Inlösen").Select
    'Application.Run "BLPLinkReset"
    'Cells.Select
    'Selection.Copy
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    '    :=False, Transpose:=False
    'Application.CutCopyMode = False
    'ActiveWorkbook.Save
    'Sheets("Skicka").Select
    'Application.Run "BLPLinkReset"
     
     'Make a copy of the active sheet and save it to
     'a temporary file
    ThisWorkbook.Sheets("Inlösen").Activate
    ActiveSheet.Copy
    Set WB = ActiveWorkbook
    FileName = "INLÖSEN " & ThisWorkbook.Sheets("Inlösen").Range("B7").Value & " " & ThisWorkbook.Sheets("Inlösen").Range("C7").Value
    On Error Resume Next
    Kill "L:\FXFI\Structured Products\Rutinbeskrivningar\Mallar\Förfall\" & FileName
    On Error GoTo 0
    WB.SaveAs FileName:="L:\FXFI\Structured Products\Rutinbeskrivningar\Mallar\Förfall\" & FileName
     
     'Create and show the outlook mail item
    
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
         tag = Left(ThisWorkbook.Sheets("Inlösen").Range("B7").Value, 4)
         If tag = "SPEC" Then
         .To = ThisWorkbook.Sheets("Skicka").Range("D11").Value
         .CC = ThisWorkbook.Sheets("Skicka").Range("D12").Value
         Else: .To = ThisWorkbook.Sheets("Skicka").Range("D11").Value
         End If
         .Subject = FileName & ThisWorkbook.Sheets("Blad1").Range("K1").Value
         .Body = "Med vänlig hälsning," & vbNewLine & "Structured Products"
         .Attachments.Add WB.FullName
         .Display 'Or use Send
    End With
     
     'Delete the temporary file
    WB.ChangeFileAccess Mode:=xlReadOnly
    Kill WB.FullName
    WB.Close SaveChanges:=False
     
     'Restore screen updating and release Outlook
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
End Sub

Anyone have an idea?

Many thanks in advance!

 

[healey21]

Hi and welcome to the forum, if I read your question right perhaps this thread may help in sending multiple attachments.

http://www.mrexcel.com/forum/excel-...ns-send-multiple-attachments-via-outlook.html

 

[daverunt]

Hi,

you can also use this method for multiple excel file attachments from the directory the macro workbook is in.
Change the Filename extn as required.

Sub AttachMultipleFiles()
     
'Get Path
    Filepath = ThisWorkbook.Path & "\"
    Filename = Dir(Filepath & "*.xls")
       
    SendTo = "Enter address"
    EmailSubject = "Enter Subject"
    MailBody = "Enter Message"
    
'Create Mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(o)
    With OutMail
        .Subject = EmailSubject
        .To = SendTo
        .Body = MailBody
        
 'Attach all files in current Dir
        Do While Filename <> ""
        
       If Filename <> ThisWorkbook.Name Then
        .Attachments.Add (Filepath & Filename)
        
       End If
       Filename = Dir
  Loop
        
        .Display
        '.send
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
    MailBody = ""
    
End Sub

 

[Peaceless]

Thank you so much to both of you! daverunt; your code did the trick!! So very greatful!

I modified it to the following:

Sub AttachMultipleFiles()

'Get Path
FilePath = ThisWorkbook.Path & "\"
FileName = Dir(FilePath & "*.xls")

'Create Mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.subject = EmailSubject
.To = ThisWorkbook.Sheets("sheet1").Range("w7").Value
.CC = ThisWorkbook.Sheets("sheet1").Range("w8").Value
.subject = "Blabla" & "Department name"
.Body = "Regards," & vbNewLine & vbNewLine & ThisWorkbook.Sheets("sheet1").Range("D3").Value

'Attach all files in current Dir
Do While FileName <> ""

If FileName <> ThisWorkbook.Name Then
.Attachments.Add (FilePath & FileName)

End If
FileName = Dir
Loop

.Display
'.send
End With

Set OutMail = Nothing
Set OutApp = Nothing
MailBody = ""

End Sub

I´m so happy that this is working! Thank you so much!!

 

[daverunt]

Now I'm happy too. Glad it works.