VBA code to send excel files by email

[Jonathan Jones]

Hi,

I have a folder of excel sheets containing product information which are named as each supplier of those products e.g. NIKE. I also have another excel spreadsheet which has the name of each supplier in column A and the email address of that supplier in column B.

I would like to send each supplier their excel spreadsheet of product information for them to complete.

Obviously, I could attach each to an email one by one but I was hoping it was possible to achieve this with code. My default email client is Outlook 2016. Any help would be very much appreciated.

Jonathan

 

[ranman256]

I dont see anyway to attach the file so here is the code:

paste code into a module, then run SENDEMAILFILES

col A, has co names
col B, has email addr
the folder for the files is hardcoded as C:\TEMP\
emails will show up in DRAFT. It does not send them. But you can change .SAVE to .SEND in the email code.

NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library

Option Explicit
Private moApp As Outlook.Application
Private moMail As Outlook.MailItem


Sub SendEmailFiles()
Dim vName, vEmail, vFile, vSubj, vBody
Const kDIR = "c:\temp\"     'folder holding the files


'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set moApp = CreateObject("Outlook.Application")
Set moMail = moApp.createitem(olmailitem)


vSubj = "Here's your file"
vBody = "your file is attached"


Columns("d:d").ClearContents
Range("A2").Select
While ActiveCell.Value <> ""
   vName = ActiveCell.Offset(0, 0).Value
   vEmail = ActiveCell.Offset(0, 1).Value
   
   If vEmail <> "" Then
      'find file
      vFile = kDIR & vName & ".txt"
      If FileExists(vFile) Then                      'send email
           Email1 vEmail, vSubj, vBody, vFile
      Else
             'err no file to send
         ActiveCell.Offset(0, 3).Value = "No file to send"
      End If
   Else           'err no email
         ActiveCell.Offset(0, 3).Value = "No email addr "
   End If
   
   ActiveCell.Offset(1, 0).Select   'next row
Wend


Set moMail = Nothing
Set moApp = Nothing
End Sub


Public Function FileExists(ByVal pvFile) As Boolean
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
FileExists = FSO.FileExists(pvFile)
Set FSO = Nothing
End Function




Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean


On Error GoTo ErrMail


With moMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsNull(pvBody) Then .Body = pvBody
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    
    '.Display True
    
    .Save
    '.Send
End With


Email1 = True
endit:
Exit Function


ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

 

[Jonathan Jones]

Hi,

Thanks for sending this code, however when I run the code nothing seems to happen. In column D of the file with the co names and email addresses it says "no file to send". The location of the file is "C:\Users\jdj98\Desktop\Delete\Supplier Review 2018\Ready to send"

Any ideas?

Jonathan