kmurraysa
03-07-2013, 12:16 AM
Hi
I am trying to send an email and attachment from Excel using Outlook using the below code. I cannot use TOOLS/ REFERENCES as this is not enable on my work PC. I know I have to change it too late binding but I am not a prgrammer so can't get this to work as it then gives Variable not defined error. Please help!
Option Explicit
Public strEmail As String
Sub BuildEmail()
Dim strEmailDist As String
Dim strSheetA As String
Dim strRange As Range
Dim strName As Variant
Dim sBody As Variant
Dim strDate As Date
Dim objOutlook As Outlook.Application
Dim objOutlookMail As MailItem
Dim strSubject As String
Set objOutlook = New Outlook.Application
Set objOutlookMail = objOutlook.CreateItem(olMailItem)
strDate = Sheets("REFERENCE SHEET").Cells(1, 2).Value
strSubject = Sheets("REFERENCE SHEET").Cells(1, 1).Value
strEmail = ""
strSheetA = "REFERENCE SHEET"
Application.Sheets(strSheetA).Select
For Each strName In Range(Cells(4, 2), Cells(4, 2).End(xlDown))
strEmail = strEmail & strName & ";"
Next
Sheets("Brokerage Report").Select
Set strRange = Nothing
Set strRange = Range(Cells(8, 2), Cells(1, 1).End(xlDown).Offset(28, 12))
With objOutlookMail
.Subject = strSubject
.BodyFormat = olFormatHTML
.to = strEmail
.HTMLBody = RangetoHTML(strRange)
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.Display
End With
Set objOutlook = Nothing
Set objOutlookMail = Nothing
End Sub
Function RangetoHTML(strRange As Range)
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"
strRange.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
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I am trying to send an email and attachment from Excel using Outlook using the below code. I cannot use TOOLS/ REFERENCES as this is not enable on my work PC. I know I have to change it too late binding but I am not a prgrammer so can't get this to work as it then gives Variable not defined error. Please help!
Option Explicit
Public strEmail As String
Sub BuildEmail()
Dim strEmailDist As String
Dim strSheetA As String
Dim strRange As Range
Dim strName As Variant
Dim sBody As Variant
Dim strDate As Date
Dim objOutlook As Outlook.Application
Dim objOutlookMail As MailItem
Dim strSubject As String
Set objOutlook = New Outlook.Application
Set objOutlookMail = objOutlook.CreateItem(olMailItem)
strDate = Sheets("REFERENCE SHEET").Cells(1, 2).Value
strSubject = Sheets("REFERENCE SHEET").Cells(1, 1).Value
strEmail = ""
strSheetA = "REFERENCE SHEET"
Application.Sheets(strSheetA).Select
For Each strName In Range(Cells(4, 2), Cells(4, 2).End(xlDown))
strEmail = strEmail & strName & ";"
Next
Sheets("Brokerage Report").Select
Set strRange = Nothing
Set strRange = Range(Cells(8, 2), Cells(1, 1).End(xlDown).Offset(28, 12))
With objOutlookMail
.Subject = strSubject
.BodyFormat = olFormatHTML
.to = strEmail
.HTMLBody = RangetoHTML(strRange)
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
.Display
End With
Set objOutlook = Nothing
Set objOutlookMail = Nothing
End Sub
Function RangetoHTML(strRange As Range)
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"
strRange.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
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function