Forum Discussion
Scott Feighner
Oct 05, 2017Copper Contributor
Macro that sends emails from excel, Need advanced help!
Here's my situation: I have about 300 unique reports that I need to send out to our sales force. I have a macro that sends out each individual's report, but I first have to hyperlink their file into ...
Scott Feighner
Oct 16, 2017Copper Contributor
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
Oct 17, 2017Copper Contributor
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