PDA

View Full Version : VBA Excel HTML e-mail?



jsabo
02-28-2013, 12:31 PM
I need to run a macro from a workbook which will automatically create an email with the workbook attached. Can someone please take the code as i have it below and change it to support HTML email format? I need to be able to format auto-populated body to include <b> for bold, etc... please help.

'begin email creation


'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String

'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = ""
Const MailCC = ""
Const MailBCC = ""
MailSub = "Code 2 and 3 Documents - Please Respond"
MailTxt = "Please see the attached which shows which documents are currently Code 2 or 3. The shaded items in column J are crucial as they have been with you for over 10 days. These need to be revised based on the comments you've received and returned ASAP. Thank you!"
'************************************************* ********

'Turns off screen updating
Application.ScreenUpdating = False

'Makes a copy of the active sheet and save it to
'a temporary file
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = "Code 2 and 3.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\jsabo\Desktop\" & FileName

'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.CC = MailCC
.BCC = MailBCC
.importance = 2
.FlagDueBy = DateAdd("d", 1, Now)
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With

'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False

'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing

'end email creation

jsabo
02-28-2013, 01:06 PM
here's an update, trying to edit ron de bruin's code. any suggestions? :

' Keyboard Shortcut: Ctrl+Shift+U
'
Sheets("summary").Select

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim WB As Workbook, FileName As String, MailSub As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = "Code 2 and 3.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\jsabo\Desktop\" & FileName


strbody = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"


On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody
.Attachments.Add WB.FullName
.Display
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing



End Sub

jsabo
02-28-2013, 01:41 PM
actually, the below code is working but is only saving the active sheet and not the entire workbook like i need it to. any help please?

Sub insertstats()
'
' insertstats Macro
' experiment to insert key stats into an email automatically
'
' Keyboard Shortcut: Ctrl+Shift+U
'
Sheets("summary").Select

Dim OutApp As Object, _
OutMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = "Code 2 and 3.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="C:\Users\jsabo\Desktop\" & FileName


strbody = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"


On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.importance = 2
.FlagDueBy = DateAdd("d", 1, Now)
.Subject = "This is the Subject line"
.HTMLBody = strbody
.Attachments.Add WB.FullName
.Display
End With

WB.Close SaveChanges:=False

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing



End Sub

Aussiebear
02-28-2013, 03:45 PM
Try the following
Sub insertstats()
'
' insertstats Macro
' experiment to insert key stats into an email automatically
'
' Keyboard Shortcut: Ctrl+Shift+U
'
Dim OutApp As Object, OutMail As Object, WB As Workbook, _
FileName As String, MailSub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set WB = ActiveWorkbook
ActiveWorkbook.Copy FileName = "Code 2 and 3.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error Goto 0
WB.SaveAs FileName:="C:\Users\jsabo\Desktop\" & FileName
strbody = "<H3><B>Dear Customer</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.importance = 2
.FlagDueBy = DateAdd("d", 1, Now)
.Subject = "This is the Subject line"
.HTMLBody = strbody
.Attachments.Add WB.FullName
.Display
End With
WB.Close SaveChanges:=False
On Error Goto 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

snb
03-01-2013, 03:13 AM
Sub M_send_complete_workbook()
With CreateObject("Outlook.Application").createitem(0)
.to = "snb@forums.eu"
.Subject = "example"
.attachments.Add ThisWorkbook.FullName
.Send
End With
End Sub