StevenAncel
New Member
- Joined
- Dec 9, 2015
- Messages
- 38
Im creating a macro for my work.
The oddest part of all this, is that the macro seems to run past the highlighted section.
It creates the email and puts the TO: CC: BCC: and copies over the content and everything.
It basically creates teh email just how i want, but gives an error ---- also doesnt 'close workbook' like ive stated in the code.
Please & Thank you for any assistance
The highlighted line is listed below
The oddest part of all this, is that the macro seems to run past the highlighted section.
It creates the email and puts the TO: CC: BCC: and copies over the content and everything.
It basically creates teh email just how i want, but gives an error ---- also doesnt 'close workbook' like ive stated in the code.
Please & Thank you for any assistance
Code:
Sub Email_Sender()'
'
Dim sh As Worksheet
Dim cell As Range
Dim strbody As String
Dim FileCell As Range
Dim att As Range
Dim rng As Range
Dim strPath As String
Dim wkbkSource As Workbook
Dim OutApp As Object
Dim OutMail As Object
strPath = "T:\Store your files\INSTALLATIONS REPORTS\Completion Reports\"
Set FileCell = Range("E2")
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
Set wkbkSource = Workbooks.Open(strPath & Range("E2").Value)
For Each cell In sh.Range("B2").Cells.SpecialCells(xlCellTypeConstants)
Set att = sh.Cells(cell.Row, 2).Range("E1:Z1")
Set rng = ActiveWorkbook.Sheets("Breakdown").Range("a2:i81").SpecialCells(xlCellTypeVisible)
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.cc = cell.Offset(0, 1).Value
.bcc = cell.Offset(0, 2).Value
.Subject = "COMPLETION REPORT " & cell.Offset(0, -1).Value
.HTMLBody = "Good Afternoon,
Please see the Completion Report for " & cell.Offset(0, -1).Value & RangetoHTML(rng)
If Trim(FileCell) <> "" Then
If Dir(strPath & FileCell.Value) <> "" Then
.Attachments.Add strPath & FileCell.Value
End If
End If
.Display 'Or use .Display to show the message before sending
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cell
'Closes Workbook
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Function RangetoHTML(rng 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"
'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 FunctionThe highlighted line is listed below
Code:
Set OutMail = OutApp.CreateItem(0)
