M
Matt
I have borrowed this code from a web site which I can not remember at the
minute. I have four problems with it.
1 A messages pops up informing me that another program is trying to send
email. I do not want this message to pop up.
2 Sometimes the email I am sending ends up in the Outbox with it not being
sent.
3. After selecting and running the macro several times and then bringing up
Task Manager there seems to be many instances of OUTLOOK running.
4 It seems to send two messages for every selection I made instead of the
one email which I want.
Any ideas on how to overcome these problems would be greatly appreciated.
'Using HTML in Message Body
Sub RangeInBody()
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = "(e-mail address removed)"
.Subject = "This is the Subject"
.HTMLBody = RangetoHTML(Selection)
.Send
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
Dim wb As Workbook
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim i As Long
Dim Rng2 As Range
Dim DelCol1 As String
Dim DelCol2 As String
Randomize
TempFile = Rng.Parent.Parent.Path & "\TmpHTML" & Int(Rnd() * 10) &
".htm"
'Copy the sheet to a new workbook and copy the cells to avoid the
'255 character limit when copying sheets
Rng.Parent.Copy
Rng.Parent.Cells.Copy ActiveSheet.Cells
Set wb = ActiveWorkbook
Set Rng2 = wb.Sheets(1).Range(Rng.Address)
'Convert to values
Rng2.Copy
Rng2.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete rows below
Rng2.Parent.Rows(Rng2.Rows(Rng2.Rows.Count).Row + 1 & ":65536").Delete
'Delete columns to right
DelCol2 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns _
(Rng2.Columns.Count).Column + 1).Column)
Rng2.Parent.Columns(DelCol2 & ":IV").Delete
'Delete rows above
If Rng2.Rows(1).Row > 1 Then
Rng2.Parent.Rows("1:" & Rng2.Rows(1).Row - 1).Delete
End If
'Delete columns to left
If Rng2.Columns(1).Column > 1 Then
DelCol1 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns(1).Column -
1).Column)
Rng2.Parent.Columns("A:" & DelCol1).Delete
End If
wb.SaveAs TempFile, xlHtml
wb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function
minute. I have four problems with it.
1 A messages pops up informing me that another program is trying to send
email. I do not want this message to pop up.
2 Sometimes the email I am sending ends up in the Outbox with it not being
sent.
3. After selecting and running the macro several times and then bringing up
Task Manager there seems to be many instances of OUTLOOK running.
4 It seems to send two messages for every selection I made instead of the
one email which I want.
Any ideas on how to overcome these problems would be greatly appreciated.
'Using HTML in Message Body
Sub RangeInBody()
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = "(e-mail address removed)"
.Subject = "This is the Subject"
.HTMLBody = RangetoHTML(Selection)
.Send
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
Dim wb As Workbook
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim i As Long
Dim Rng2 As Range
Dim DelCol1 As String
Dim DelCol2 As String
Randomize
TempFile = Rng.Parent.Parent.Path & "\TmpHTML" & Int(Rnd() * 10) &
".htm"
'Copy the sheet to a new workbook and copy the cells to avoid the
'255 character limit when copying sheets
Rng.Parent.Copy
Rng.Parent.Cells.Copy ActiveSheet.Cells
Set wb = ActiveWorkbook
Set Rng2 = wb.Sheets(1).Range(Rng.Address)
'Convert to values
Rng2.Copy
Rng2.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete rows below
Rng2.Parent.Rows(Rng2.Rows(Rng2.Rows.Count).Row + 1 & ":65536").Delete
'Delete columns to right
DelCol2 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns _
(Rng2.Columns.Count).Column + 1).Column)
Rng2.Parent.Columns(DelCol2 & ":IV").Delete
'Delete rows above
If Rng2.Rows(1).Row > 1 Then
Rng2.Parent.Rows("1:" & Rng2.Rows(1).Row - 1).Delete
End If
'Delete columns to left
If Rng2.Columns(1).Column > 1 Then
DelCol1 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns(1).Column -
1).Column)
Rng2.Parent.Columns("A:" & DelCol1).Delete
End If
wb.SaveAs TempFile, xlHtml
wb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function