I am trying to send out emails based on a due date on my excel sheet. I have a list of items in which each item has a specific owner, the description of that item and a due date for that item.
The recepients of the item are in column "F" and the due date is in column "R". Here is the code that I have so far but I am getting an error stating that there is a Runtime error 13 and Type Mismatch. The code runs fine for a little while and then I start receiving this error. When I have multiple due dates, that is when this error occurs. I am not sure what I am doing wrong. If there is any way I can edit the code please propose it, or if there is another way about sending emails out based on a due date, please let me know the code. I will specify where in the code there is an error.
Thank you!
Public Sub CheckAndSendMail()
Dim lRow As Long
Dim lstRow As Long
Dim toDate As Date
Dim toList As String
Dim ccList As String
Dim bccList As String
Dim eSubject As String
Dim EBody As String
Dim vbCrLf As String
Dim ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 3 To lstRow
'THIS IS WHERE I RECEIVE THE ERROR:
toDate = Cells(lRow, "R").Value
'toDate = Replace(Cells(lRow, "L"), ".", "/")
If Left(Cells(lRow, "R"), 17) <> "Mail" And toDate - Date <= 7 Then
vbCrLf = "<br><br>"
toList = Cells(lRow, "F") 'gets the recipient from col F
eSubject = "Text" & Cells(lRow, "C") & " is due on " & Cells(lRow, "R").Value
EBody = "<HTML><BODY>"
EBody = EBody & "Dear " & Cells(lRow, "F").Value & vbCrLf
EBody = EBody & "Text" & Cells(lRow, "C").Value & vbCrLf
EBody = EBody & "Text" & vbCrLf
EBody = EBody & "Link to the Document:"
EBody = EBody & "<A href='Link to Document'>Text </A>"
EBody = EBody & "</BODY></HTML>"
Cells(lRow, "W") = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column W"
MailData msgSubject:=eSubject, msgBody:=EBody, Sendto:=toList
End If
Next lRow
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function MailData(msgSubject As String, msgBody As String, Sendto As String, _
Optional CCto As String, Optional BCCto As String, Optional fAttach As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)
With Itm
.Subject = msgSubject
.To = Sendto
If Not IsMissing(CCto) Then .Cc = CCto
If Len(Trim(BCCto)) > 0 Then
.Bcc = BCCto
End If
.HTMLBody = msgBody
.BodyFormat = 2 '1=Plain text, 2=HTML 3=RichText -- ISSUE: this does not keep HTML formatting -- converts all text
'On Error Resume Next
If Len(Trim(fAttach)) > 0 Then .Attachments.Add (fAttach) ' Must be complete path'and filename if you require an attachment to be included
'Err.Clear
'On Error GoTo 0
.Save ' This property is used when you want to saves mail to the Concept folder
.Display ' This property is used when you want to display before sending
'.Send ' This property is used if you want to send without verification
End With
Set app = Nothing
Set Itm = Nothing
End Function
Here is the error I receive:
Try to format the value of column R as Date before assigning to toDate. try this line of code:
toDate = CDate(Cells(lRow, "R").Value)
Also, Have you checked for the data when Cells(lRow, "R").Value returns null or empty value. This can also be the reason for the error.
Related
I'm attempting to send an email for each attendance event that is being displayed within the Pivot Table. Though it will recognize the count of rows, only the 1st row is being sent in email up to as many emails as there are rows of data.
I believe I need my offset parameters to change so it's changing by row & cell. Any suggestions?
enter image description here
Sub EmailBody()
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
'Tells it to re-run every x hours and min.
Application.OnTime Now + TimeValue("1:00"), "EmailBody"
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim arrHolidays As Variant, iDay As Variant
arrHolidays = Application.Transpose(Worksheets("Hold").Range("a:a").Value) 'Add all your holidays on Holidays worksheet
For Each iDay In arrHolidays
If Date = iDay Then Exit Sub 'exit this sub if date is a holiday
Next
On Error Resume Next
ThisWorkbook.RefreshAll
Worksheets("Sheet1").Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id.
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range
Set rng = Range("B2:B" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("b2:b100")
MailBody = "Please see the following attendance event logged in SharePoint for " & i.Offset(0, -1) & "." & vbCr & vbCr & "Date of Absence " & " : " & i.Offset(0, 2) & vbCr & "Reason for Absence " & " : " & i.Offset(0, 3) & vbCr & "Ticket Entered on" & " : " & i.Offset(0, 4) & vbCr & "Created By" & " : " & i.Offset(0, 5) & vbCr & "Notes" & " : " & i.Offset(0, 6) & vbCr & vbCr & "Please reach out to DLWESTCCWALKERRETENTIONREPORTING#charter.com, if you have any questions."
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2 & ";" & Range(cell.Address).Offset(0, 1).Value2
Subj = "Attendance Callout Event Notification"
Msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = Msg
.Subject = Subj
.Display '
.Send
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next
End Sub
So I built a code that works for mailing 1 list (in Column A): Cell A1 has a region, Cells A2 though last row have an email address that needs that email. This code works fine for column A. But if a made a list in Columns B-#( however many number of columns), could i add onto this code and make it create as many emails as there are columns, and send them to the list of people below row 2.
In other words, can we make this say for Each column with a value in the first row create and email and send it to everyone else below it?
thanks
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
LastRow = Range("A" & rows.Count).End(xlUp).Row
'email recipients are in row 2 to the last row
For i = 2 To LastRow
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
Next
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Range("A1").Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Range("A1").Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
End Sub
I would make your existing routine accept a column number so you can pass any column to it, and then it will work for that column e.g.
Sub emailfromcolumns(COL As Long)
So then you can just call emailfromcolumns(1) to email for column A, emailfromcolumns(2) to email for column B etc.
Then you can create a second sub routine that finds out how many columns there are and just loops through them all, calling your existing routine:
Sub loopit()
Dim lastColumn As Long
Dim x As Long
lastColumn = Sheets("Recipients").Cells(1, Sheets("Recipients").Columns.Count).End(xlToLeft).Column
For x = 1 To lastColumn
emailfromcolumns (x)
Next x
End Sub
This means all you have to do to your existing code is replace any reference to column "A" with the variable COL - there are four lines:
change
LastRow = Range("A" & rows.Count).End(xlUp).Row
to
LastRow = Cells(Rows.Count, COL).End(xlUp).Row
change
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
to
If Cells(2, COL).Value2 <> "" Then
Namelist = Namelist & ";" & Cells(i, COL).Value2
End If
and the last two lines are within the e-mail bit:
.Subject = Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
On top of this, your code has some risky sections where you're just referring to Range without declaring which sheet the range is on... below is full version tidied up with comments on the differences:
Sub emailfromcolumns(COL As Long)
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
Dim WS As Worksheet ' Declare a worksheet object
Set WS = ThisWorkbook.Worksheets("Recipients") ' set the worksheet object WS to "Recipients" for easy reference
LastRow = WS.Cells(WS.Rows.Count, COL).End(xlUp).Row ' last row now definitely referencing "Recipients" thanks to WS
'email recipients are in row 2 to the last row
' changed your "A2" check to outside the loop, don't need to check it each time
If WS.Cells(2, COL).Value2 <> "" Then
For i = 2 To LastRow
Namelist = Namelist & ";" & WS.Cells(i, COL).Value2
Next i
End If
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject(Class:="outlook.application")
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = WS.Cells(1, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & WS.Cells(1, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True ' You didn't have anywhere that says Application.ScreenUpdating = False ?
End Sub
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim z As Long
Dim LastRow As Long
Dim Namelist As String
Dim colCount As Long
'How Many Columns?
colCount = 4
'Loop through columns
For z = 1 To colCount
'email recipients are in row 2 to the last row
Namelist = vbNullString
With Worksheets("Recipients")
LastRow = .Cells(.Rows.Count, z).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, z).Value <> "" Then
Namelist = Namelist & ";" & .Cells(i, z).Value
End If
Next
End With
'Only create message if emails exist?
If Len(Namelist) > 0 Then
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br> " _
& "<br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Sheets("Recipients").Cells(1, z).Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(1, z).Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
End If
Next z
Application.ScreenUpdating = True
End Sub
I finally made it happen that my macro at least works 90%. Every time I open my Excel file, automatic e-mails are sent out to the right people.
However, I have one issue, which I cannot solve: I was hoping to implement a status, sent vs not sent, which triggers whether another e-Mail should be sent the next day.
Unfortunately, the status never updates.
I would be very happy if you can have a look at it:
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim FormulaCell As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim Deadline As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
Deadline = Date
Set FormulaRange = Me.Range("S2:S64")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If .Value < Deadline Then
MyMsg = NotSentMsg
If .Offset(0, 3).Value = NotSentMsg Then
Call Mail_with_outlook1(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 3).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
Sub Mail_with_outlook1(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(FormulaCell.Row, "T").Value
strcc = Cells(FormulaCell.Row, "U").Value
strbcc = ""
strsub = "Notice Period in 6 Months"
strbody = "Hi " & Cells(FormulaCell.Row, "D").Value & _
vbNewLine & vbNewLine & "The notice period for your customer " & Cells(FormulaCell.Row, "A").Value & " is in 180 days." & _
vbNewLine & vbNewLine & "Thank you very much and feel free to reach out to me in case of any question." & _
vbNewLine & vbNewLine & "Best regards, Marius"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Answer on comment.
Thanks Roland,
Based on your comment and the fresh mindset of the next day I finally figured it out.
I have to move the line after the first if statement 'MyMsg = NotMsgSent' to after the second if statement, Then it works perfectly fine. Thank you!
I have this code to send mail to multiple recipients using Lotus Notes. Right now I need to mention the entire file path for the attachments. My requirement is to use FileSearch method - mention any part of the name of the attachment within * * - so that the files get attached.
Sub Send()
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim Var As Variant
Dim flag As Boolean
Dim cell As Range
Dim r As Excel.Range
Dim Name As String
Dim Annex As String
Dim recp As Variant
Dim cc As Variant
Dim Resp As Long
Resp = MsgBox(prompt:="Do you wish to send to the mail?", Buttons:=vbYesNo + vbInformation + vbDefaultButton2, Title:=AppHeader)
If Resp = vbYes Then
Sheets("Sheet2").Activate
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" Then
Set oSess = CreateObject("Notes.NotesSession")
Set oDB = oSess.GETDATABASE("", "")
Call oDB.OPENMAIL
flag = True
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")
If Not flag Then
MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FILEPATH
GoTo exit_SendAttachment
End If
On Error GoTo err_handler
'Building Message
recp = Cells(cell.Row, "B").Value
cc = Cells(cell.Row, "C").Value
Set oDoc = oDB.CREATEDOCUMENT
Set oItem = oDoc.CREATERICHTEXTITEM("BODY")
oDoc.Form = "Memo"
oDoc.Subject = "HI" & "-" & Cells(cell.Row, "D").Value
oDoc.sendto = Split(recp, ",")
oDoc.copyto = Split(cc, ",")
oDoc.body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please find attached "
oDoc.postdate = Date
oDoc.SaveMessageOnSend = True
Name = Cells(cell.Row, "F").Value
Annex = Cells(cell.Row, "G").Value
Call oItem.EmbedObject(1454, "", Name)
Call oItem.EmbedObject(1454, "", Annex)
oDoc.Send False
End If
Next cell
MsgBox prompt:="Mail Sent", Buttons:=vbOKOnly + vbInformation, Title:=AppHeader
Exit Sub
'Attaching DATABASE
For Each r In Range("Fpath") '// Change to suit
If r.Value <> vbNullString Then
Call Send
End If
Next
oDoc.visable = True
'Sending Message
exit_SendAttachment:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
'Done
err_handler:
If Err.Number = 7225 Then
MsgBox "File doesn't exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
On Error GoTo exit_SendAttachment
Else
Sheets("Sheet1").Activate
End If
End Sub
Any thoughts will be highly appreciated.
It's been years since I have worked with Lotus notes. The last question that I answered on Lotus notes was way back in July 26, 2011 So be gentle on me if I miss any syntax. :p
Application.FileSearch method is no longer supported from XL2007+
Reference: Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"
In case the above link dies, here is the screenshot.
As mentioned in that link You can use the FileSystemObject object to recursively search directories and to find specific files. Here is how we do that
In case the above link dies, here is the code from that link.
'~~> COURTESY: http://support.microsoft.com/kb/185601
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "vb.ini")
MousePointer = vbHourglass
Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
Once you are able to select the files you can use the below code in a loop to add the attachments
stAttachment = "Blah Blah.Txt"
Set obAttachment = oDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
My workbook has 5 different sheets and I need to copy the five sheets and paste it into 5 different mails. Preferably as HTML.
The below written code only attaches the different sheets to outlook. I need the HTML below the body of the email. Please note that my range in the sheets varies from workbook to workbook but the sheet names remain the same.
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String
ThisFolder = BrowseForFolder()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name
If wsName <> "Data" Then
Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"
ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If
Next ws
End Sub
Sub EmailWorkbooks(RecipName, NameOfFile)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(0)
Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"
Subj = "XYZ Report" & " " & Period
On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0
End Sub
U can use Add method of PublishObjects collection, short example:
Sub InsertSheetContent()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ThisWorkbook.Worksheets
htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=htmlFile, _
Sheet:=oneSheet.Name, _
Source:=oneSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic, _
DivID:=oneSheet.Name)
onePublishObject.Publish Create:=True
Set textStream = scriptingObject.OpenTextFile(htmlFile)
htmlBody = textStream.ReadAll
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.htmlBody = htmlBody
.Display
End With
Next oneSheet
End Sub