VBA Code: Text is wrapping in body of email. Can this be prevented?

[strangejosh]

Hello,

I was hoping someone could help me with my code. Thank you for the user @Sequoyah for helping with the original code. That was very helpul.

So basically the code loops through an excel spreadsheet, looks for unique vendors and sends their past due orders to them in the body of an email. It works fine however some of the columns are wrapped while others aren't. Also all of the headers are also wrapped. Is there a way to prevent that from happening for columns / rows?

See below of what the spreadsheet that is to have the code run on it.

Then see what gets returned. Not sure why those 2 columns specifically get wrapped?

Also, is there a way for the code to allow a filter to by applied and then run as normal? Column A Buyer Code may have multiple diferent buyers and say I only want to send emails for specific buyer codes can I filter and just have those send?

See code below.

Sub mailstrangejosh()



Dim OutApp As Object, OutMail As Object

Dim myRng As Range, v As Variant

Dim j As Long, lastRow As Long

Dim strbody As String



Application.ScreenUpdating = False



lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

v = Range("A1:V" & lastRow).Value



Set OutApp = CreateObject("Outlook.Application")

With CreateObject("scripting.dictionary")

For j = 2 To UBound(v)

If Not .exists(v(j, 2)) Then

.Add v(j, 2), Nothing



strbody = "Hello " & v(j, 20) & “,” & "<br>" & _

"<br>" & _

"Please see below past due order(s) balances and provide a status update when you can. Thank you" & "<br/><br>"



With ActiveSheet

.Range("A1").AutoFilter 2, v(j, 2)

Set myRng = .Range("A1:X" & lastRow).SpecialCells(xlCellTypeVisible)



Set OutMail = OutApp.CreateItem(0)

With OutMail

.To = v(j, 21)

.Subject = v(j, 17) & " – PO Balance(s)"

.HTMLBody = strbody & RangetoHTML(myRng)

.display 'to show

'.Send 'to send

End With

End With

End If

Next j



End With



Range("A1").AutoFilter



Application.ScreenUpdating = True

End Sub



Function RangetoHTML(myRng As Range)

Dim fso As Object

Dim ts As Object

Dim TempFile As String

Dim TempWB As Workbook

Dim i As Integer



TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"



myRng.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

Cells.EntireRow.AutoFit

Cells.EntireColumn.AutoFit

Application.CutCopyMode = False

On Error Resume Next

.DrawingObjects.Visible = True

.DrawingObjects.Delete

On Error GoTo 0

For i = 7 To 12

With .UsedRange.Borders(i)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlMedium

End With

Next i

End With



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=")

RangetoHTML = Replace(RangetoHTML, "display:none", "")



TempWB.Close savechanges:=False



Kill TempFile



Set ts = Nothing

Set fso = Nothing

Set TempWB = Nothing



End Function

 

[HongRu]

Try.

Add the code somewhere of your VBA macro to prevent the wrapped.

Cells.EntireColumn.AutoFit

 

[strangejosh]

Try.

Add the code somewhere of your VBA macro to prevent the wrapped.

Cells.EntireColumn.AutoFit

Thank you for that but it's already in the code. See image.

 

[HongRu]

Thank you for that but it's already in the code. See image.

Maybe you should put at the last section in the macro.

 

[strangejosh]

Maybe you should put at the last section in the macro.

I have tried multiple locations as per your suggestions but doesn't change the end result. Not sure why though.

 

[HongRu]

You should not put that in a Function.
I suggest put that code in your sub just before your "Sub End" or "Application.ScreenUpdating = True".

 

[strangejosh]

You should not put that in a Function.
I suggest put that code in your sub just before your "Sub End" or "Application.ScreenUpdating = True".

Yeah it's weird. That is not working either. Before or after. It's driving me crazy. Think it has something to do with Outlook? Feels like I have tried everything.

 

[strangejosh]

Bump.

 

[daverunt]

I use the following code

    ActiveSheet.UsedRange.EntireColumn.AutoFit
    ActiveSheet.UsedRange.EntireRow.AutoFit

I can't see the original code but any autofit needs to be done prior to creating the email as RangetoHTML will copy as "seen"

Also you could step through the code using F8 to see if any autofitting is actually done or being undone by another step.

 

[strangejosh]

I use the following code

    ActiveSheet.UsedRange.EntireColumn.AutoFit
    ActiveSheet.UsedRange.EntireRow.AutoFit

I can't see the original code but any autofit needs to be done prior to creating the email as RangetoHTML will copy as "seen"

Also you could step through the code using F8 to see if any autofitting is actually done or being undone by another step.

So that still didn't work for me and I couldn't figure out why even stepping into. Thank you for helping though.

What was a work around was changing the font size from 11 to 8 and that prevented the columns / cell text from wrapping.

The one thing left I can't figure out is how to run the script when filtered by buyer code in column A. It will run but it will send emails to all of the vendors even the ones filtered out. The ones filtered out just have no data except column headers. See screenshot.

Any ideas here?

Sub mailstrangejosh()



Dim OutApp As Object, OutMail As Object

Dim myRng As Range, v As Variant

Dim j As Long, lastRow As Long

Dim strbody As String



Application.ScreenUpdating = False



lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

v = Range("A1:U" & lastRow).Value



Set OutApp = CreateObject("Outlook.Application")

With CreateObject("scripting.dictionary")

For j = 2 To UBound(v)

If Not .exists(v(j, 2)) Then

.Add v(j, 2), Nothing



strbody = " <BODY style=font-size:12pt>Hello " & v(j, 19) & “,” & "<br>" & _

"<br>" & _

"Please see below past due order(s) balances and provide a status update when you can. Thank you" & "<br/><br>"



With ActiveSheet

.Range("A1").AutoFilter 2, v(j, 2)

Set myRng = .Range("A1:U" & lastRow).SpecialCells(xlCellTypeVisible)



Set OutMail = OutApp.CreateItem(0)

With OutMail

.To = v(j, 20)

.Subject = v(j, 2) & " – PO Balance(s)"

.HTMLBody = strbody & RangetoHTML(myRng)

.display 'to show

'.Send 'to send

End With

End With

End If

Next j



End With



Range("A1").AutoFilter



Application.ScreenUpdating = True

End Sub



Function RangetoHTML(myRng As Range)

Dim fso As Object

Dim ts As Object

Dim TempFile As String

Dim TempWB As Workbook

Dim i As Integer



TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"



myRng.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

Cells.HorizontalAlignment = xlLeft

Application.CutCopyMode = False

On Error Resume Next

.DrawingObjects.Visible = True

.DrawingObjects.Delete

On Error GoTo 0

For i = 7 To 12

With .UsedRange.Borders(i)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlMedium

End With

Next i

End With



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=")

RangetoHTML = Replace(RangetoHTML, "display:none", "")



TempWB.Close savechanges:=False



Kill TempFile



Set ts = Nothing

Set fso = Nothing

Set TempWB = Nothing



End Function