ThrottleWorks
Excel Ninja
Hi,
I am using below code to create e-mails. My problem, e-mail is not getting created properly.
There are 2/3 long sentences in Column A, say A3, A5 and A7.
Such as
Range A3 = Sentence one = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f sah dafh a had g f sh
Range A5 = Sentence two = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f
Range A7 = Sentence three = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f sah dafh a had g
But, when e-mail is drafted. Sentences are only partially captured.
Sentence one = sffGSGSGgSGghgda ga had
Sentence two = sffGSGSGgSGghgda ga had
Sentence three = sffGSGSGgSGghgda ga had
In excel file, these values are visible till column I (according to my column width).
I have selected range till column J. Do not know why this is happening.
In same e-mail, I have a table below, this is getting published correctly. But facing problem these long sentences.
Can anyone please help me in this.
I am using below code to create e-mails. My problem, e-mail is not getting created properly.
There are 2/3 long sentences in Column A, say A3, A5 and A7.
Such as
Range A3 = Sentence one = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f sah dafh a had g f sh
Range A5 = Sentence two = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f
Range A7 = Sentence three = sffGSGSGgSGghgda ga had sg SH A SD GA H G Dsh hgS HD sag sh da hg f sah dafh a had g
But, when e-mail is drafted. Sentences are only partially captured.
Sentence one = sffGSGSGgSGghgda ga had
Sentence two = sffGSGSGgSGghgda ga had
Sentence three = sffGSGSGgSGghgda ga had
In excel file, these values are visible till column I (according to my column width).
I have selected range till column J. Do not know why this is happening.
In same e-mail, I have a table below, this is getting published correctly. But facing problem these long sentences.
Can anyone please help me in this.
Code:
Option Explicit
Sub RangeToHML_Ron()
Dim EmailMapSht As Worksheet
Dim MyPath As Variant
Dim ToEmail As String
Dim CcEmail As String
Dim FromEmail As String
Set EmailMapSht = ThisWorkbook.Worksheets("Email Sheet")
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
Dim TempLr As Long
TempLr = Cells(Rows.Count, 8).End(xlUp).Row
Set rng = Range("H1:P" & TempLr)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
MyPath = ActiveWorkbook.FullName
FromEmail = ""
ToEmail = EmailMapSht.Range("C2").Value
CcEmail = EmailMapSht.Range("C3").Value
With OutMail
.To = ToEmail
.CC = CcEmail
'.BCC = EmailMapSht.Range("B1").Value
.Subject = ThisWorkbook.Worksheets("Mapping").Range("A4").Value
'.Attachments.Add MyPath
.HTMLBody = RangetoHTML(rng)
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
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"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteAll
Dim TempLr As Long
TempLr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A1:J" & TempLr)
rng.Select
'.Cells(1).Select
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
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
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function