Emailing each of 500 workbooks to a different email address located inside each one

[actjfc]

Excel friends,

I have 500 Excel workbooks that I need to email to an email address located inside each workbook, first sheet, cell C2. I need to write the same subject, and body text in each email. I use Outlook, and Excel 2010, and all the Excel workbooks are located in the same folder.

How to do it? Any help will be greatly appreciated!

Thanks!

 

[ranman256]

put this code in a module, change your folder name, where mine is: vDir = "Z:\Delivery Notes\Delivery Notes\" 'your folder goes here
be sure to add OUTLOOK to the vbe, in vbe menu, TOOLS, REFERENCES, checkmark OUTLOOK
then run: SendAllFilesInDir

'----------------
Public Sub SendAllFilesInDir()
'----------------
Dim fso, oFolder, oFile, vDir, vFil


vDir = "Z:\Delivery Notes\Delivery Notes\"             'your folder goes here


Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(vDir)


For Each oFile In oFolder.Files   'go thru all files
    If InStr(oFile.Name, ".xls") > 0 Then        'ONLY DO XL FILES
        vFil = vDir & oFile.Name            'get the full file name path
        Sheets(1).Select
        vTo = Range("C2").Value
        ActiveWorkbook.Close False
        
            'send email here
        vSuccess = Email1(vTo, "subject", "body text", vFil)
        If vSuccess <> 0 Then MsgBox "Email failed on " & vTo
    End If
Next


Set fso = Nothing
Set oFile = Nothing
Set oFolder = Nothing
MsgBox "Done", , "emails"
Exit Sub


'------------------
Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile)
'------------------
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem


On Error GoTo ErrMail


    'NOTE  BE SURE YOU ADD OUTLOOK APP VIA  VBE menu:TOOLS, REFERENCES


Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)


With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody
    
    If Not IsEmpty(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    .Send
End With


endIt:
Set oMail = Nothing
Set oApp = Nothing
Exit Function


ErrMail:
MsgBox Err.Description, vbCritical, Err
Email1 = Err
Resume endIt
End Function

 

[actjfc]

Thank you! I should be doing something wrong, but it is not working for me. I checked the reference for Outlook 14 Object Library, and I got an error about not having an End Sub, so I replaced your Exit Sub for End Sub, now the error is gone, but the workbook is closed after running the macro, and no emails are sent. Please, be more specific about how to "add OUTLOOK to the vbe", and let me know where I am wrong. Thank you again for your help.