Need help generating e-mail with attachment based on cell data

[tonzovun]

Considering i have no real training/education on how to do any of this I'm quite please with what I've managed so far. However, I've reach the limits of what I'm capable of. I already have something built that creates new files based on a selected column. I would like to send each new file as it's made to the user in question. The other difficult thing is..if possible...the body of the email needs to change based on column C. I'll post the original macro that creates the new file below. If anyone can add the needed bits to accomplish both of these tasks it would save me hours of time. If i can only manage the emails. I'll just duplicate the macro and change the body text. And yes a large chunk of this is pieced together from different posts on this and other websites.

I'm using the version of excel that comes with Office 365 Proplus...if that helps.


Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created


iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow


Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.path


If Dir(sFilePath + "\Split", vbDirectory) = "" Then
MkDir sFilePath + "\Split"
End If


'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False


Do
' Get cell at cursor
Set rCell = osh.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")


If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1


' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1


' Reset section delimiters
iStartRow = 0
iStopRow = 0


' Ready to continue loop
iRow = iRow - 1
End If
End If


' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1


' Exit
Exit Do
End If
Loop


'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True


MsgBox Str(iCount) + " documents saved in " + sFilePath




End Sub


Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)


Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete


End Sub




Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
Dim ash As Worksheet ' Copied sheet
Dim awb As Workbook ' New workbook


' Copy book
osh.Copy
Set ash = Application.ActiveSheet


' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If


' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If


' Select left-topmost cell
ash.Cells(1, 1).Select


' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")


' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split" + sSectionName & " " & Format(Now(), "DD-MMM-YYYY"), fileFormat


' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub

[Paul_Hossler]

I packaged code I found here and on the web to make a (IMHO) simple to use function SendWithOutlook () to send email using Outlook

It works for me, but no promises it will work everywhere for everyone

This is how I use it -- the driver test prog below

The SendWithOutlook function is in the attached file since it's probably too long to post




Option Explicit

Sub drv()
Dim r As Range
Dim i As Long

Set r = ActiveSheet.Cells(1, 1).CurrentRegion

For i = 2 To r.Rows.Count

'SendWithOutlook(emailRecipient As String, _
' emailMessage As String, _
' Optional emailSubject As String = vbNullString, _
' Optional emailAttachmentFile As String = vbNullString) As Boolean

With r.Rows(i)
Call SendWithOutlook(.Cells(1).Value, .Cells(3).Value, .Cells(2).Value, Environ("USERPROFILE") & "\Documents\" & .Cells(4).Value)
End With


Next i
End Sub



I'd play around with the attachment to make sure that email can work, and then integrate it

[Logit]

.
http://www.rondebruin.nl/win/section1.htm