I gather the data from different Excel sheets and paste the table and content in one sheet and then push that to html file to Outlook.
While pasting the data from the sheet to html file, it is calculating the number of columns in which the data is present.
For Example in one sheet I have pasted text which is around 500 characters on the very first row. On the next row I have pasted a 5*10 table. While copying data to html file it is calculating only 10 columns and copying the data which is in yellow in screenshot.
How do I copy all the data from Excel to html file.
If I use Sheet.UsedRange then on the basis of column it is copying data.
Code:
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim htmlContent
Dim RangetoHTML
Dim lastColumn
Dim lastRow
Dim LastCol
Dim TempFile As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name "Signature" And ws.Name "URL") Then
Set rng = Nothing
Set rng = ws.UsedRange
lastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
Set rng = Range(Cells(1, 1), Cells(lastRow, 20))
'Publish the sheet to a htm file
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ws.Name, _
Source:=ws.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=")
htmlContent = htmlContent & RangetoHTML
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
End If
Next ws
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "sagarwal4#dow.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = htmlContent
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Use something like this instead:
Dim lastCell As Excel.Range
Set lastCell = Cells.Find(What:="*", After:=Cells(1, 1), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False)
Range("A1", lastCell).Copy
'// Rest of code here ....
Related
I'm trying to retain hyperlinks in an email generated using VBA, using the RangetoHTML function from Rondebruin's website. The hyperlinks are all in a table column of a table that's shown in the email body.
Using the original Rondebruin code, I am able to paste all the correct values shown in the original table but the column with hyperlinks is only showing the values and not activated hyperlinks (cannot be clicked on).
I've also tried the solutions recommended in this thread but they aren't working for me: Retain hyperlinks after rangetohtml paste Outlook?.
I've also tried using .Cells(1).PasteSpecial xlPasteAll, , False, False but this messes up the AutoFilter component and does not send the correct rows to the correct recipient.
Can someone please help me with an amendment to the below code to get the hyperlinks activated within the table? Thank you!
Sub SendMultiplevFINAL()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim EmailStart As String
Dim EmailEnd As String
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = Sheets("Email Output")
'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:J" & Ash.Rows.Count)
FieldNum = 10 'Filter column = J because the filter range start in J
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Look for the mail address in the List worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("List").Range("A1:B" & _
Worksheets("List").Rows.Count), 2, False)
On Error GoTo 0
'Look for the greeting name in the List worksheet
GreetingName = ""
On Error Resume Next
GreetingName = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("List").Range("A1:C" & _
Worksheets("List").Rows.Count), 3, False)
On Error GoTo 0
EmailStart = "<p>" & "Hi " & GreetingName & _
If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
With .Resize(, .Columns.Count - 1)
Set rng = .SpecialCells(xlCellTypeVisible)
End With
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = mailAddress
.CC = Sheets("Email Details").Range("CC").Value
.Subject = Sheets("Email Details").Range("Subject").Value
.HTMLBody = EmailStart & _
"<p align='left'><table><tbody><tr><td>" & RangetoHTML(rng) & "</td></tr></tbody></table></p><br>"
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim Hlink As Hyperlink
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
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).PasteSpecial xlPasteFormulas, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
For Each Hlink In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
Address:=Hlink.Address, _
TextToDisplay:=Hlink.TextToDisplay
Next Hlink
' Publish the sheet to an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I had search all over of this question and still not get the exact codes for it.
I need to copy the color of the pivot table from excel to outlook body. When running the code i got the format but the only problem is the color of the table is turning into black and grey.
Please help me to figure it out how to put the exact color that i need.
This is my codes:
Sub AUTO_MAIL()
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range, sub1 As Range, sub2 As Range, sub3 As Range, sub4 As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("Data Entry").PivotTables(1).TableRange1
Set rng2 = Sheets("ACN Workflow").PivotTables(1).TableRange1
Set rng3 = Sheets("L'Oreal Workflow").PivotTables(1).TableRange1
Set rng4 = Sheets("MTD Volume").PivotTables(1).TableRange1
Set sub1 = Sheets("Data Entry").Range("A1:E1").SpecialCells(xlCellTypeVisible)
Set sub2 = Sheets("ACN Workflow").Range("A1:G1").SpecialCells(xlCellTypeVisible)
Set sub3 = Sheets("L'Oreal Workflow").Range("A1:G1").SpecialCells(xlCellTypeVisible)
Set sub4 = Sheets("MTD Volume").Range("A1:B1").SpecialCells(xlCellTypeVisible)
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 = ""
.CC = ""
.BCC = ""
.Subject = "Step+ Volume Tracker, Data Entry/Workflow Ageing Report and Rejection Report |"
.HTMLBody = "<b>Dear All,</b><br><br>" & "Please see below summary of invoices and links to the <b>Volume Tracker</b> and <b>Ageing Report</b> (Data Entry and Workflow).<br>" & RangetoHTML(sub4) & vbCrLf & RangetoHTML(rng4) & vbCrLf & RangetoHTML(sub3) & vbCrLf & RangetoHTML(rng3) & vbCrLf & RangetoHTML(sub2) & vbCrLf & RangetoHTML(rng2) & vbCrLf & RangetoHTML(sub1) & vbCrLf & RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.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-2013
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.SpecialCells(xlCellTypeVisible).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
You will have to tweak the code a bit which should look something like this:
Sub due()
Dim ol As Object 'Outlook.Application
Dim olEmail As Object 'Outlook.MailItem
Dim olInsp As Object 'Outlook.Inspector
Dim wd As Object 'Word.Document
Dim rCol As Collection, r As Range, i As Integer
'/* if outlook is running use GO, create otherwise */
Set ol = GetObject(Class:="Outlook.Application")
Set olEmail = ol.CreateItem(0) 'olMailItem
Set rCol = New Collection
With rCol
.Add Sheet1.Range("A1:B6") '/* add your ranges the same sequence */
.Add Sheet2.Range("A1:B6") '/* as you want them added in the body */
End With
With olEmail
.To = ""
'/* bonus basic html */
.HTMLBody = "<html><body style=""font-family:calibri"">" & _
"<p><b>Dear Deer,</b><br><br> She see seas." & _
"</p></body></html>"
Set olInsp = .GetInspector
If olInsp.EditorType = 4 Then 'olEditorWord
Set wd = olInsp.WordEditor
For i = 1 To rCol.Count '/* iterate all ranges */
Set r = rCol.Item(i): r.Copy
wd.Range.InsertParagraphAfter
wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
'16 - wdFormatOriginalFormatting
Next
End If
wd.Range.InsertParagraphAfter
wd.Paragraphs(wd.Paragraphs.Count).Range.Text = "Regards, Patricia"
wd.Paragraphs.Last.Range.Sentences.Last.Font.Bold = True
.Display
End With
End Sub
In case you want to do more, you will have to read more about Word VBA. This is just a sample on what you can do with Outlook's Word Editor.
I have a scrip to sent mail from excel via outlook .
Here i select a cell and copy it as html and sent to outlook .
but in hangs in method Function RangetoHTML(rng As Range) at line RangetoHTML = ts.readall when no. of row are upto 70 .
Can someone help.
Sub Mail_Selection_Range_Outlook_Body()
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 = "xxxxx#xxxxx.com"
.BCC = ""
.Subject = "Report" & Format(Now, "dd-MM-yyyy")
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Display .Send
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
Dim SignatureFilePath As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
SignatureFilePath = "Office.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 // hangs here
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
RangetoHTML = "<BODY style= color:black;font-size:11.0pt;font-weight:400;font-family:Consolas,monospace>Dear Chetan<p>Please find details<p> </BODY>" & RangetoHTML & "<br><br>" & GetSignature(SignatureFilePath)
'Close TempWB
TempWB.Close savechanges:=False
Debug.Print
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetSignature(fPath As String) As String
Dim fso As Object
Dim TSet As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.readall
TSet.Close
End Function
This will copy & paste the selection from Excel to the Outlook email body, preserving your default signature (if there is one). If you need to add some other signature from file location, you'd need some additional magic.
With OutMail
.To = "xxxxx#xxxxx.com"
.BCC = ""
.Subject = "Report" & Format(Now, "dd-MM-yyyy")
.Display 'or use .Display .Send
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
End With
Alternatively, copy the data to a new worksheet and send as attachment:
Sub SendAsAttachment()
Dim rng As Range
Dim newWB As Workbook
Dim newWS As Worksheet
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
Set newWB = Workbooks.Add
With newWB
Set newWS = .Sheets(1)
newWS.Name = rng.Parent.Name
rng.Copy newWS.Range("A1")
Do While .Worksheets.Count > 1
.Worksheets(.Count).Delete
Loop
.SendMail "david.zemens#jdpa.com", "subject", False
.Close False
End With
End Sub
The latter method does not include signature line in the email, though.
I'm fairly new to VBA.
I've figured a way to send a mail picking up content from the table and sending it to the desired recipient using a macro.
Now, I need to send mails with different content to multiple recipients, all the required data is present in the same table, with the recipient name being one of the columns. Any help would be greatly appreciated.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim LastRow As Long
StrBody = "Hi," & "<br>" & "<br>" & _
"The following Talents were last reporting to you and have now moved to bench. Please confirm the plans. " & "<br><br>"
With Worksheets("To-Bench")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set rng = Nothing
On Error Resume Next
'For Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'For fixed range
Set rng = Sheets("To-Bench").Range("A1:G2").SpecialCells(xlCellTypeVisible)
'Hardcoded the number of rows which is actually indefinite'
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
'Application.Goto ActiveWorkbook.Sheets("Sheet2").Cells(6, 5)
.To = ActiveSheet.Cells(2, 9).Text 'I've hardcoded the recipient as of now'
.CC = ""
.BCC = ""
.Subject = "Movement of " & Range("C2").Value & " Talents to Bench"
.HTMLBody = StrBody & rangetoHTML(rng)
.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-2013
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
Try this solution from Ron deBruin.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
If you need to merge several cells into a single cell, you can concatenate a range using the following method.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = ";")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
I the below VBA code which generates a mail from different cells in an excel spreadsheet. The problem is that when I use it to generate an email, the mails will not fit to automatically to the screen like a normal outlook mail does. So if I read it on a smartphone screen the text won't fit to the screen.
There's a macro that sends the mail and a function that selects the range.
Sub Mail_Sheet_Outlook_Body()
Dim rng As Range
Dim StrBody As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'add this for the text string
'StrBody = Sheets("Sheet2").Range("A1").Value & "<br>" & _
' Sheets("Sheet2").Range("A2").Value & "<br>" & _
' Sheets("Sheet2").Range("A3").Value & "<br><br><br>"
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "...." ' email adress here
' Worksheets("Sheet2").Range("A1:A18")
.cc = ""
.BCC = ""
.Subject = "The short update"
'.HTMLBody = StrBody & RangetoHTML(rng)
.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)
' Working in Office 2000-2013
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
For Each Row In rng
For Each Column In Row
StrBody = StrBody & " " & Column
Next
StrBody = StrBody & "<br>"
Next
You probably want something along the lines of the above code.
Even manually entered tables don't autofit.
If you're really trying to keep the format you might consider exporting the range to a shape and converting it to a picture. Good luck with that.