Forum Discussion
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 an excel column. Is there a quicker way to do this instead of hyperlinking one-by-one? It doesn't work when I use the hyperlink function either.
Scott, your post has not gotten any replies yet, despite some views and I am guessing that may be because you have left out a lot of the many details that could make a targeted response simple to address. Excel is indeed very capable of sending reports via automation with an email service such as Outlook. When you say you are relying on hyperlinks, I am not sure why. If you have all of the email addresses in a list somewhere, and a means of associating an email address with a file someplace on disk or in a share directory, you would write a macro to loop through cells with this information, and write some code to automate Outlook to create and send messages and add attachments. If the files are somewhat large, you might run into problems with attachment sizes. If you want to include the information within the files in the body of those emails, that is possible with some code by Ron De Bruin . If you need to zip the files, he also has good methods for doing this. There are many options here. I never use the hyperlink function. I use hyperlinks to enable users to perform specific actions, or to take the user to certain locations, but this seems like a simple case of executing commands in a loop, and the code is very simple.
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.
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
