SendMsgAttachmentExcel

To | CC | Subject | Attachment

Public Sub SendMessageAttachmentExcel() Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim rCount As Long Dim bXStarted As Boolean Dim enviro As String Dim strPath As String Dim strAttachPath As String Dim olItem As Outlook.MailItem Dim Recip As Outlook.Recipient ' Get Excel set up enviro = CStr(Environ("USERPROFILE")) 'the path of the workbook strPath = enviro & "\Documents\send.xlsx" On Error Resume Next Set xlApp = GetObject(, "Excel.Application") If Err <> 0 Then Application.StatusBar = "Please wait while Excel source is opened ... " Set xlApp = CreateObject("Excel.Application") bXStarted = True End If On Error GoTo 0 'Open the workbook to input the data Set xlWB = xlApp.Workbooks.Open(strPath) Set xlSheet = xlWB.Sheets("Sheet1") ' Process the message record On Error Resume Next rCount = 2 strAttachPath = enviro & "\Documents\Send\" & xlSheet.Range("D" & rCount) Do Until Trim(xlSheet.Range("A" & rCount)) = "" 'Create Mail Item and view before sending Set olItem = Application.CreateItem(olMailItem) With olItem .To = xlSheet.Range("A" & rCount) .CC = xlSheet.Range("B" & rCount) .Subject = xlSheet.Range("C" & rCount) .Body = "Attached is the file you need." .Attachments.Add strAttachPath .Display .Send End With rCount = rCount + 1 Loop Set xlWB = Nothing Set xlApp = Nothing End Sub