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

strangejosh

New Member
Joined
Jul 30, 2022
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
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.

VBA Code:
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
 

Attachments

  • 666.jpg
    666.jpg
    79.8 KB · Views: 15
  • 777.jpg
    777.jpg
    108.3 KB · Views: 16

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Try.

Add the code somewhere of your VBA macro to prevent the wrapped.
VBA Code:
Cells.EntireColumn.AutoFit
 
Upvote 0
Try.

Add the code somewhere of your VBA macro to prevent the wrapped.
VBA Code:
Cells.EntireColumn.AutoFit
Thank you for that but it's already in the code. See image.
 

Attachments

  • 888.jpg
    888.jpg
    27.1 KB · Views: 9
Upvote 0
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".
 
Upvote 0
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.
 
Upvote 0
I use the following code

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.
 
Upvote 0
I use the following code

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?

VBA Code:
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
 

Attachments

  • 999.jpg
    999.jpg
    36.2 KB · Views: 7
Upvote 0

Forum statistics

Threads
1,223,243
Messages
6,170,967
Members
452,371
Latest member
Frana

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top