Macro that sends emails from excel, Need advanced help!

Copper Contributor

Oct 16, 2017

Bill,

Thanks for the response, sorry I left out details. I thought hyperlinks were the only way for a macro to send out files to people through email? The files are not in a shared directory and only I have access to them. Each salesperson has 1 unique excel file that I need to send them. I have all of their email addresses in an excel document. My company only uses Outlook when it comes to emailing. What VBA would be best for this situation? Let me know if you need more details.

Bill Benson

Copper Contributor

Oct 17, 2017

Left out an important line in the Dir() loop. The code was cobbed together from various projects, it has not been debugged.

Option Explicit
Dim FileNameZip As String
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

Function getTemp() As String
getTemp = "c:\users\" & Environ("username") & "\Desktop\Temp"
    On Error Resume Next
    MkDir getTemp

End Function
Sub SendMail(DataRange As Range)
    Dim ol As Object
    Dim MailItm As Object
    Dim strSubject As String
    Dim strPath As String
    Dim strFile As String
    Set ol = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If ol Is Nothing Then
        Set ol = CreateObject("Outlook.Application")
    End If
    Set MailItm = ol.CreateItem(0)
    
    On Error Resume Next
    With MailItm
        .To = "" 'ADD RECIPIENT HERE
        .Subject = "" 'ADD A SUBJECT HERE
        .CC = "" 'ADD CC HERE
        .HTMLBody = RangetoHTML(DataRange)
'''''''''''''' ALTERNATELY ATTACH SOME FILES
        With .Attachments
            strFile = Dir(strPath)
            Do Until strFile = ""
                .Add strPath & "\" & strFile, , 1, 1, "Test"
                StrFile = Dir()
            Loop
''''''''''''''''''' ALTERNATELY, ATTACH A ZIP OF ALL THE FILES
           .Add ZipAttachment("C:\users\" & Environ("username") & "\Reports Folder"), 1, 1, "Test"
            
        End With
        .Save
        .Display
        
    End With
End Sub
Function ZipAttachment(strPath As String) As String
    Dim oApp  As Object
    Dim FSO As Object
    Dim Fil As Object
    Dim iFilesExpected As Long
    Dim TimerNow As Double
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    FileNameZip = strPath & "\ZippedFile" & Format(Date, "Mmm dd") & ".zip"
    On Error Resume Next
    Kill FileNameZip
    On Error GoTo 0
    NewZip FileNameZip
    Set oApp = CreateObject("Shell.Application")
    'strAttachList = Replace$(strAttachList, "\My Documents\", "\Documents\")
    For Each Fil In FSO.GetFolder(strPath).Files
        If InStr(UCase(Fil.Name), ".MSG") <> 0 Then
            iFilesExpected = oApp.Namespace(CVar(FileNameZip)).Items.Count + 1
            oApp.Namespace(CVar(FileNameZip)).copyhere CVar(Fil.Path)
            Do
                TimerNow = Timer
                Do
                    'Wait a full second
                Loop Until Timer > TimerNow + 1
            Loop Until oApp.Namespace(CVar(FileNameZip)).Items.Count = iFilesExpected
            'Kill Fil.Path optionally delete the individual files
        End If
    Next
    ZipAttachment = FileNameZip
End Function

Function RangetoHTML(Rng As Excel.Range) As String
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = getTemp & "\Temp" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    'Copy the range and create a new workbook to past the data in
    On Error Resume Next

    Kill TempFile
    On Error GoTo 0
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

Bill Benson

Copper Contributor

Oct 17, 2017

Here are some code ideas to play with...

Option Explicit
Dim FileNameZip As String
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

Function getTemp() As String
getTemp = "c:\users\" & Environ("username") & "\Desktop\Temp"
    On Error Resume Next
    MkDir getTemp

End Function
Sub SendMail(DataRange As Range)
    Dim ol As Object
    Dim MailItm As Object
    Dim strSubject As String
    Dim strPath As String
    Dim strFile As String
    Set ol = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If ol Is Nothing Then
        Set ol = CreateObject("Outlook.Application")
    End If
    Set MailItm = ol.CreateItem(0)
    
    On Error Resume Next
    With MailItm
        .To = "" 'ADD RECIPIENT HERE
        .Subject = "" 'ADD A SUBJECT HERE
        .CC = "" 'ADD CC HERE
        .HTMLBody = RangetoHTML(DataRange)
'''''''''''''' ALTERNATELY ATTACH SOME FILES
        With .Attachments
            strFile = Dir(strPath)
            Do Until strFile = ""
                .Add strPath & "\" & strFile, , 1, 1, "Test"
            Loop
''''''''''''''''''' ALTERNATELY, ATTACH A ZIP OF ALL THE FILES
           .Add ZipAttachment("C:\users\" & Environ("username") & "\Reports Folder"), 1, 1, "Test"
            
        End With
        .Save
        .Display
        
    End With
End Sub
Function ZipAttachment(strPath As String) As String
    Dim oApp  As Object
    Dim FSO As Object
    Dim Fil As Object
    Dim iFilesExpected As Long
    Dim TimerNow As Double
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    FileNameZip = strPath & "\ZippedFile" & Format(Date, "Mmm dd") & ".zip"
    On Error Resume Next
    Kill FileNameZip
    On Error GoTo 0
    NewZip FileNameZip
    Set oApp = CreateObject("Shell.Application")
    'strAttachList = Replace$(strAttachList, "\My Documents\", "\Documents\")
    For Each Fil In FSO.GetFolder(strPath).Files
        If InStr(UCase(Fil.Name), ".MSG") <> 0 Then
            iFilesExpected = oApp.Namespace(CVar(FileNameZip)).Items.Count + 1
            oApp.Namespace(CVar(FileNameZip)).copyhere CVar(Fil.Path)
            Do
                TimerNow = Timer
                Do
                    'Wait a full second
                Loop Until Timer > TimerNow + 1
            Loop Until oApp.Namespace(CVar(FileNameZip)).Items.Count = iFilesExpected
            'Kill Fil.Path optionally delete the individual files
        End If
    Next
    ZipAttachment = FileNameZip
End Function

Function RangetoHTML(Rng As Excel.Range) As String
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim FSO As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = getTemp & "\Temp" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    'Copy the range and create a new workbook to past the data in
    On Error Resume Next

    Kill TempFile
    On Error GoTo 0
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

Forum Discussion

Macro that sends emails from excel, Need advanced help!

Resources