VBA - Copy Cell from Sheet into Outlook email - excel

I am new to VBA and have created the following code that sends an email.
My question is how do i copy some cells from my excel sheet that I am currently using to be pasted inside the excel file?
Thanks,
Sub CIR_Save_Email()
Dim objoutlook As Object
Set objoutlook = CreateObject("outlook.application")
Dim objemail As Object
Set objemail = objoutlook.createitem(olmailitem)
Const olFormatHTML As Long = 2
emailbodymessage = "<HTML><BODY>Hi Team," & _
"<br><br>Attached is the Display's CIR for today<br><br>" & _
"<b>Brief overview of CIR</b><br><br>" & _
"<b>Purpose:</b> To get a snapshot of what your current inventory levels by SKU are every day." & _
"<ul style=""list-style-type:circle"">" & _
"<li><b>Unrestricted QTY</b> The total inventory at that DC (i.e.Deliveries Created + Available Qty)</li>" & _
"<li><b>Deliveries Created:</b> Orders that are being processing at that DC (i.e. they will NOT be included in Available Inventory)</li>" & _
"<li><b>Available:</b> How many cases are available to use at that DC </li>" & _
"<li><b>Avail DOS:</b> How many DOS the available cases equate to</li>" & _
"<li><b>IT QTY:</b> How man cases are in transit</li>" & _
"<li><b>Avail +IT DOS:</b> How many DOS the available cases equate to</li>" & _
"</ul> </body> </html>"
emailbodymessage2 = "<html><body><ul style=""list-style-type:circle"">" & _
"<li><b>Future Available:</b> The total DOS of cases Avail + IT</li>" & _
"<li><b>QI QTY:</b> How many cases are on Qualitiy (ie Non-Conformance)</li>" & _
"<li><b>Blocked QTY:</b> How many cases are blocked from ordering due to damages, short dating, expired, etc." & _
"<li><b>CM- months:</b> The forecasts of the months past (CM-1=July)</li>" & _
"<li><b>% to Fcst:</b> How much of your projected forecast has shipped this month</li>" & _
"<li><b>Current SNAP Fcst:</b> This month's projected forecast</li>" & _
"<li><b>CM+ months:</b> The forecasts of the months moving forward (CM+1= September)</li>" & _
"</ul> </body></html>"
With objemail
.To = emaillist
.cc = ""
.Subject = "Display's CIR " & Date
.BodyFormat = olFormatHTML '// 2
.HTMLBody = emailbodymessage & emailbodymessage2
.display
End With
End Sub

You can use the following function (internally uses exporting range into HTML) to convert excel range into html. Then resultant HTML should be included into your generated HTML body.
The function is exporting Range into HTML temporary created file and then strips content to only div (without surrounding HTML tags).
However, I'm not sure if formatting and other details will fit your requirements. Other solution is to construct HTML from cells manually, but it is much more work.
Usage: str = GetHtml("Sheet1","D4:E6")
Public Function GetHtml(ByVal sheetName As String, ByVal rangeName As String) As String
Dim fso As FileSystemObject
Dim fileName As String
Dim txtStream As TextStream
Dim html As String
Dim line As String
Dim readLines As Boolean
Set fso = New FileSystemObject
Dim rng As range
fileName = fso.GetSpecialFolder(2) & "\" & Replace(fso.GetTempName, ".tmp", ".html")
If fso.FileExists(fileName) Then
fso.DeleteFile fileName
End If
Set rng = Sheets(sheetName).range(rangeName)
ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, fileName:=fileName, Sheet:=rng.Worksheet.Name, Source:=rng.Address, HtmlType:=xlHtmlStatic).Publish
Set txtStream = fso.OpenTextFile(fileName, ForReading, False)
readLines = False
html = ""
Do While Not txtStream.AtEndOfStream
line = txtStream.ReadLine
If InStr(line, "<!--START OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then
readLines = True
End If
If readLines Then
html = html & vbCrLf & line
End If
If readLines And InStr(line, "<!--END OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then
readLines = False
End If
Loop
txtStream.Close
Set txtStream = Nothing
If fso.FileExists(fileName) Then
fso.DeleteFile fileName
End If
Set fso = Nothing
GetHtml = html
End Function

You said you want to 'copy some cells from my excel sheet that I am currently using to be pasted inside the excel file'. I think you man copy from Excel and paste into the body of an Email, right.
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
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
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Related

Intermittent failure of worksheet macro to populate outlook "To" field

I have a workbook with a summary tab, with one row per client, each row containing variables that populate an email to that client. Each row is mapped to a separate tab using excel formulas (which also refers to a lookups tab, where I can update client information such as emails and names). Each tab contains a worksheet macro to pull information into an outlook email (code below). This works fine most of the time, but often the final emails to generate fail to populate the email "To" field. This happens most after making changes to the workbook. If I save, close and reopen the workbook, most (if not all) of the email "To" fields populate correctly. The first emails to generate are always fine, but at some point while generating they stop populating "to", then every email to generate after that point does not have the "to" field. It ranges from 10% to 100% of the emails populating "to" correctly.
The code below is on each of the tabs (usually about 50 clients/tabs/emails run). Any ideas on why this could be, and how to make it always work 100%? It seems like I might just be asking too much of excel, having them all run at once, maybe they need to run in sequence, I'm not sure. Any help appreciated!
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Public Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("AA1"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Application.EnableEvents = False
On Error GoTo Handler
ListObjects("Table6").Range.AutoFilter Field:=1, Criteria1:= _
"<>"
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
On Error Resume Next
With xOutMail
.To = Range("H2")
.CC = "billing#example.com; name#example.com"
.BCC = ""
.Subject = Range("C2") & " - (ID: " & Range("I2") & ") - " & Range("B2") & " Lightning Docs Usage & Billing"
.HTMLBody = "<font size=-0> Hello " & Range("G2") & ",<br/><br/>" & vbNewLine & vbNewLine & _
"Please review the following list of loan documents that were produced through our online system from " & Range("B2") & ". <br/>Your total bill for this month's documents is " & FormatCurrency(Range("F2")) & " (" & Range("E2") & " x " & FormatCurrency(Range("D2")) & "):</font>" & vbNewLine & vbNewLine & _
RangetoHTML(Range("Table6")) & vbNewLine & vbNewLine & _
"<br/><font size=-0>Please let us know within two business days whether your records match ours. If we do not get a response within this time frame, we will invoice you shortly thereafter. If your credit card is on file and we have a pre-existing authorization, we will charge your card on file and provide you with a copy of your paid invoice." & vbNewLine & vbNewLine & _
"<br/><br/>Thank you!</font><br/>" & vbNewLine
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Handler:
Application.EnableEvents = True
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , SkipBlanks:=True, Transpose:=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
Private Sub Worksheet_Calculate()
Dim xI As Integer
Dim xRg As Range
Set xRg = Range("AA1")
On Error GoTo Err01
xI = Int(xRg.Value)
If xI = 1 Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub
First of all, you need to find what value the Range("H2") code returns. You can use Debug.Print statements to track what values are assigned to the To property.
Second, I'd suggest using the Recipients.Add method instead of relying to the To property.
Set myItem = Application.CreateItem(olMailItem)
Set myRecipient = myItem.Recipients.Add("Eugene Astafiev")
myRecipient.Resolve()
Read more about that in the How To: Fill TO,CC and BCC fields in Outlook programmatically article.

How to past data from array into part of html body

im trying to pass on element from array into to html body, so far i have:
Public example As String
then function that returns on element from array
Sub products()
Dim aArray() As String
For j = 2 To 2
If Cells(j, 1).Value <> "" Then
ReDim aArray(1 To 1) As String
For i = 1 To 10
If Cells(j, i).Value = "Yes" Then
aArray(UBound(aArray)) = Cells(1, i).Value
ReDim Preserve aArray(1 To UBound(aArray) + 1) As String
End If
Next i
example = Left(Join(aArray, " & "), Len(Join(aArray, " & ")) - 3) ''example is one of the product name
End If
Next j
Call mail
End Sub
and Ron Debruin email creator
Sub mail()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
body_of_email = example
product_name_1 = "very, very, very long product1 info"
product_name_2 = "very, very, very long product2 info"
product_name_3 = "very, very, very long product3 info"
product_name_4 = "very, very, very long product4 info"
On Error Resume Next
With OutMail
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng) & body_of_email
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
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
What should I change to make "body_of_email" returns one of the 'product info' into HTMLBody not the 'example' from array?
thanks for any help!
edit
when i changed this line
.HTMLBody = RangetoHTML(rng) & body_of_email
into this
Select Case wynik
Case Is = "product_name_1 "
.HTMLBody = RangetoHTML(rng) & product_name_1
Case Is = "product_name_2 "
.HTMLBody = RangetoHTML(rng) & product_name_2
Case Is = "product_name_3 "
.HTMLBody = RangetoHTML(rng) & product_name_3
Case Is = "product_name_4 "
.HTMLBody = RangetoHTML(rng) & product_name_4
End Select
it helped

Transfer Hyperlinks in Excel Range to Outlook Email

I am trying to create an email from excel ranges (rng 1 through 6) that have hyperlinks for each cell in Columns A and D. Here is an example of the code that creates the hyperlinks for these ranges. That all works just fine.
ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("A" & D2), _
Address:="some address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value
ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("D" & D2), _
Address:="some other address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value
I then have the below code that creates an email from the excel ranges (rng1 through 6). When the email is created the hyperlinks do not transfer to Outlook. The text is underlined as if there is a hyperlink but it is not clickable.
Sub Mail_Body()
Dim rng1 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim wb2 As Workbook
Dim MyDate, Weeknr, MyFileName, MyTime, MyMonth
Dim Mail1 As String
Dim Mail2 As String
Dim Subject As String
Dim Warr As String
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim Subject_email As String
Application.ScreenUpdating = False
Application.EnableEvents = False
nPath = Environ("temp") & "\" & ThisWorkbook.Sheets("Lists").Range("AA1").Value
Set wb2 = Workbooks.Open(nPath)
D2 = Sheets("Critical").Range("A1").Offset(Sheets("Critical").Rows.Count - 1, 0).End(xlUp).Row
D3 = Sheets("High").Range("A1").Offset(Sheets("High").Rows.Count - 1, 0).End(xlUp).Row
D4 = Sheets("Low").Range("A1").Offset(Sheets("Low").Rows.Count - 1, 0).End(xlUp).Row
D5 = Sheets("Other").Range("A1").Offset(Sheets("Other").Rows.Count - 1, 0).End(xlUp).Row
D6 = Sheets("Overdue").Range("A1").Offset(Sheets("Overdue").Rows.Count - 1, 0).End(xlUp).Row
Set rng = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Set rng5 = Nothing
Set rng6 = Nothing
Set rng2 = Sheets("Critical").Range("A1:J" & D2).SpecialCells(xlCellTypeVisible)
Set rng3 = Sheets("High").Range("A1:J" & D3).SpecialCells(xlCellTypeVisible)
Set rng4 = Sheets("Low").Range("A1:J" & D4).SpecialCells(xlCellTypeVisible)
Set rng5 = Sheets("Other").Range("A1:J" & D5).SpecialCells(xlCellTypeVisible)
Set rng6 = Sheets("Overdue").Range("A1:L" & D6).SpecialCells(xlCellTypeVisible)
Set OutMail = Nothing
Set OutApp = Nothing
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
'MsgBox OutApp
Set OutMail = OutApp.CreateItem(0)
Dim Session As Object
Set Session = OutApp.GetNamespace("MAPI")
Session.Logon
Create email
With OutMail
.To = Mail1
.CC = Mail2
.BCC = ""
.Subject = Subject_email
.HTMLBody = "Overview:" & "<br>" & RangetoHTML(rng1) _
& "<br>" & "<u>Critical</u>" & "<br>" & RangetoHTML(rng2) & "<br>" & "<u>High</u>" _
& "<br>" & RangetoHTML(rng3) & "<br>" & "<u>Low</u>" & "<br>" & RangetoHTML(rng4) _
& "<br>" & "<u>Other</u>" & "<br>" & RangetoHTML(rng5) _
& "<br>" & "<u>Overdue</u>" & "<br>" & RangetoHTML(rng6)
.Attachments.Add nPath '.FullName
.Recipients.ResolveAll
.Display '.Send
End With
I'm unable to share the output of this code, but what happens, as explained above, is the hyperlinks from the Excel sheet do not transfer to the Outlook email. They are blue and underlined but there is no hyperlink.
How do I carry over the active hyperlinks from excel to outlook? I've been unable to find a pre-existing solution that fits my specific needs.
I found a solution to the issue: https://www.mrexcel.com/forum/excel-questions/560111-retain-hyperlinks-after-rangetohtml-paste-outlook.html
In the RangetoHTML function, change the .pastevalues to .pasteall and the hyperlinks will be copied over.
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteAll, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteRowHeights
.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

Reply the email in PST outlook that have same value in Excel file [ Same Value is Service Tag ]

I want to create automail that will reply the email in Outlook where located in PST file that have same subject in Excel.
Below is my excel file. I want to search email with same service tag #Column D
And reply with custom HTML body.
my problem now I cannot display my desired email and reply it.
Hope you all can help me.
Here is my code that I try.
Sub AutoMail()
'Find OOW_Request
Dim OOW As Workbook
Dim s As Workbook
For Each s In Workbooks
If Left(s.Name, 11) = "OOW Request" Then
Set OOW = Workbooks(s.Name)
End If
Next s
Dim rng As Range
Dim rngTilte As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim eBodyLast As String
Dim olNs As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim olReply As Object ' Reply
Dim olRecip As Recipient ' Add Recipient
OOW.Sheets("OOW_REQUEST").Select
lRow = OOW.Sheets("OOW_REQUEST").Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
If OOW.Sheets("OOW_REQUEST").Range("L" & i) = "" Then
Set rng = Nothing
Set rngTilte = Nothing
On Error Resume Next
Set rngTilte = OOW.Sheets("OOW_REQUEST").Range("D1:M1").SpecialCells(xlCellTypeVisible)
Set rng = OOW.Sheets("OOW_REQUEST").Range("D" & i & ":" & "M" & i). _
SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set olNs = OutApp.GetNamespace("MAPI")
olNs.AddStore ("C:\Users\Ruzaini_Subri\Documents\Outlook Files\OOW.pst")
Set myTasks = olNs.Session.Folders.Item(2).items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, "Cells(i, 4)", vbTextCompare) > 0) Then
' toList = Cells(i, 8)
' eSubject = "yOOW part requestz|| Part: " & Cells(i, 5) & " || TAG: " & Cells(i, 4)
eBody = "<BODY style=font-size:10pt;font-family:Arial><p>Hi " & Cells(i, 8) & "</p>" & _
"Please advise if you can support this OOW request by replying this email." & "<br><br></BODY>"
eBodyLast = "<BODY style=font-size:9pt;font-family:Arial><br><br>" & "<p>Thank You.</p>" & _
"<strong>---------------------------------------------------------------------</strong><br>" & _
"<span style=""color: #333399;""><strong>Ruzaini Subri</strong></span></BODY>"
On Error Resume Next
Set olReply = olMail.ReplyAll
Set olRecip = olReply.Recipients.Add("& Cells(i, 8) &") ' Recipient Address
olRecip.Type = olTo
olReply.HTMLBody = eBody & RangetoHTML(rngTilte) & RangetoHTML(rng) & eBodyLast & vbCrLf & olReply.HTMLBody
olReply.Display
'olReply.Send
On Error GoTo 0
End If
Next olMail
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set olMail = Nothing
Set OutApp = Nothing
Cells(i, 12) = "TBU"
End If
Next i
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
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=")
RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]> <![endif]-->", "")
'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
I solve this problem after search in internet
You can mapping Outlook folder ID in excel and refer it to find desired email.
Find Folder ID in Outlook
Sub Test()
Dim app As Outlook.Application
Dim nms As Outlook.Namespace
Dim fld As Outlook.Folder
Set app = GetObject(, "Outlook.Application")
Set nms = app.GetNamespace("MAPI")
Set fld = nms.PickFolder
Debug.Print "StoreID: " & fld.StoreID
Debug.Print "EntryID: " & fld.EntryID
Sheets("MACRO").Range("N10") = fld.StoreID
Sheets("MACRO").Range("N11") = fld.EntryID
Call MessageBoxTimer
End Sub
Use it in your code
Dim StoreID As Variant
Dim EntryID As Variant
StoreID = ws.Range("N1").Value
EntryID = ws.Range("N2").Value
For i = 2 To lRow
If OOW.Sheets("WORKING FILE").Range("W" & i) = "YES" And _
OOW.Sheets("WORKING FILE").Range("B" & i) = "Ruz" And _
OOW.Sheets("WORKING FILE").Range("Y" & i) = "" Then
Set rng = Nothing
Set rngTilte = Nothing
On Error Resume Next
Set rngTilte = OOW.Sheets("WORKING FILE").Range("D1:X1").SpecialCells(xlCellTypeVisible)
Set rng = OOW.Sheets("WORKING FILE").Range("D" & i & ":" & "X" & i). _
SpecialCells(xlCellTypeVisible)
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set olNs = OutApp.GetNamespace("MAPI")
Set Fldr = olNs.GetFolderFromID(EntryID, StoreID)
Set myTasks = Fldr.items

VBA-Trouble with attaching cells into body of email(Outlook)

I am using excel 2003 and I am having trouble attaching cells onto the body of an email. I got some of the code off http://www.rondebruin.nl/mail/folder3/mail4.htm but it does not work for me. What happens to me is that a spreadsheet would pop up that has Not Peer Review on it and an error message saying "runtime error '1004' PasteSpecial method of Range class failed". Please provide assistance.
Below is the code (the code in bold is the error):
'' Creates Email
Sub Email_Click()
Dim sDate As Date
sDate = ThisWorkbook.Sheets("SheetA").Range("H4").Value
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim tmp
Set olApp = New Outlook.Application
'' Location of email template
Set olMail = olApp.CreateItem(olMailItem)
ThisWorkbook.Worksheets("SheetB").Activate
Application.ActiveSheet.Columns("A:E").AutoFit
Dim totalRows As Integer
totalRows = Application.ActiveSheet.UsedRange.Rows.count
With olMail
'' Subject
.Subject = "Email"
.BodyFormat = olFormatHTML
.To = "emailsheet#gmail.com"
'' Body
.HTMLBody = RangetoHTML(Application.ActiveSheet.Range("A1:E" & totalRows))
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
ThisWorkbook.Worksheets("Base Sheet").Activate
End Sub
Function RangetoHTML(rng As Range)
'' Changed by Ron de Bruin 28-Oct-2006
'' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
''Copy the range and create a new workbook to past the data in
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
Replace the erronous line
.Cells(1).PasteSpecial Paste:=8
with
.Cells(1).PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False
Another possibility would be to write your own code generating the html, it's quite easy:
Public Sub
Dim crtRow as Integer
Dim crtCol as Integer
Dim tempBody as String
tempBody = "<table>" & vbNewline
For crtRow = 0 To maxRow
tempBody = tempBody & " <tr>" & vbNewline
For crtCol = 0 To maxCol
tempBody = tempBody & " <td>" & yourWorksheet.Cells(maxRow, maxCol).Value & "</td>" & vbNewline
Next crtCol
tempBody = tempBody & " </tr>" & vbNewline
Next crtRow
tempBody = "</table>" & vbNewline
yourEmail.HTMLBody = tempBody
End Sub
Sure, the format isn't copied this way. You would have to add it yourself though. And the rest of your email-message needs to be constructed as well.
hope that helps a bit out
regards
How about:
s = RangetoHTML(Application.ActiveSheet.Name & "$" & "A1:E" & totalRows)
Function RangetoHTML(rng As String)
''Reference: Microsoft ActiveX Data Objects x.x Library
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
strFile = Workbooks(1).FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
cn.Open strCon
rs.Open "SELECT * FROM [" & rng & "]", cn
s = "<table border=""1"" width=""100%""><tr><td>"
s = s & rs.GetString(, , "</td><td>", "</td></tr><tr><td>", " ")
s = s & "</td></tr></table>"
RangetoHTML = s
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Function

Resources