Hi All,
Hoping someone can offer some assistance. Basic situation: I have an excel 2007 spreadsheet that myself and my team complete to lodge new files. Once finished they press a button and the macro kicks in and it generates one email in Outlook 2007 (in HTML form - cuts and pastes a table) to a particular group. I am trying to edit this spreadsheet so that a second email is generated to go to an Email to SMS service. I have been able to get it so the email comes up with the right information in the 'to' field and the right information in the body etc, but I can't seem to get it to send as a plain text, which it needs to or the SMS arrives as gibberish.
To clarify, I'm not a VBA expert and have largely created the macro using on code I've found online. I've spent two days googling and trying different options such as .TextBody, .BodyFormat, .olFormatPlain etc etc. None seem to work and I think its because of the code that I'm using to generate the email. I think I need to find the right combination but am struggling. The code I am using is:
Sub Save_and_Email()
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
Sheets("Email").Select
Cells(34, 2).Value = ""
Cells(34, 2).Value = Environ("Username")
'Columns("B:B").EntireColumn.AutoFit
Sheets("Form").Select
Set Rng = Sheets("Email").Range("A1:K24").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 = "abc@abc.net.au; abc@abc.net.au; abc@abc.net.au"
.CC = Sheets("Email").Range("B32").Value
.BCC = ""
.Subject = Sheets("Email").Range("B33").Value
.HTMLBody = RangetoHTML(Rng)
.Display 'or use .Send
End With
On Error GoTo 0
'2nd email
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim strbody As String
Dim cell As Range
strbody = Sheets("SMS").Range("A1").Value
With OutMail
.To = Sheets("SMS").Range("B9").Value & "@esendex.net"
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
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-2010
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
Any assistance would be greatly appreciated.
Many thanks
Trav
Bookmarks