Poundland
09-01-2015, 06:08 AM
Hi Guys, me again, sorry for pestering you all yet again...
I have taken some code of a Ron de Bruin website and attempted to adapt it for my means, the code works perfectly the first time through and sends the first email with no issues, where it fails is sending subsequent emails.
Basically it is designed to run through a Store List of 4 digit numbers, filter a list of products bespoke to that store number, copy the selection, raise an Outlook email, with the store number as the address and the product data as part of the email body.
As said, it worked perfectly for the first store in the list, of which there are 500+ stores, but does not send subsequent emails.
Some stores will not have any data to send and I think I have catered for this.
EDIT: For some reason the Code function on this site adds an email prefix to the email addresses in my code, these are not in the original code.
Full code below;
Sub emailer()
'Only working in Office 2007-2013
'Don't forget to set a reference to Outlook in the VBA editor
Application.ScreenUpdating = False
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String, AFRng As Range, AFData As Range, Reg As Worksheet, RngToCopy As Range, cll As Range
Dim strend As String
Dim rng As Range
Set Reg = Sheets("ASR Regular")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set AFRng = Intersect(Sheets("Skus").UsedRange, Sheets("Skus").Range("$B:$E"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
For Each cll In Reg.Range(Reg.Cells(4, 2), Reg.Cells(4, 2).End(xlToRight)).Cells
AFRng.AutoFilter Field:=1, Criteria1:=cll
Set RngToCopy = Nothing
On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not RngToCopy Is Nothing Then
strbody = "The ASR team have noticed that there have not been any sales on the below product or products in the last 4 weeks, and we would like to help you to maximise your sales on these." & "<br>" & "<br>" & _
"Can you please check in the first instance that you have the stock of each product, and if so is it being offered for sale to our customers?" & "<br>" & "<br>" & _
"If you do not have the stock, then can you please correct your Bookstock so that ASR can send you the correct stock that you need so we can sell these amazing products to our customers." & "<br>" & "<br>" & _
"Sku ------ Desc ------------------------------------------ Bookstock --- On Order" & "<br>"
strend = "<br>" & "Thank you" & "<br>" & _
"The ASR Team"
On Error Resume Next
With OutMail
.To = cll
.CC = "asr.helpdesk@poundland.co.uk"
.BCC = ""
.Subject = "No Sales Last 4 Weeks - Bookstock Check"
.HTMLBody = strbody & RangetoHTML(RngToCopy) & strend
.SentOnBehalfOfName = "ASR.helpdesk@poundland.co.uk"
'SendUsingAccount is new in Office 2007
'Change Item(1)to the account number that you want to use
'.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'.SentOnBehalfOfName = """SenderName"" <Reply@Address.com>"
.Send 'or use .Display or .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cll
'Set rng = Sheets("Sheet1").Range("D4:g6").SpecialCells(xlCellTypeVisible)
Application.ScreenUpdating = True
End Sub
And
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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
I have taken some code of a Ron de Bruin website and attempted to adapt it for my means, the code works perfectly the first time through and sends the first email with no issues, where it fails is sending subsequent emails.
Basically it is designed to run through a Store List of 4 digit numbers, filter a list of products bespoke to that store number, copy the selection, raise an Outlook email, with the store number as the address and the product data as part of the email body.
As said, it worked perfectly for the first store in the list, of which there are 500+ stores, but does not send subsequent emails.
Some stores will not have any data to send and I think I have catered for this.
EDIT: For some reason the Code function on this site adds an email prefix to the email addresses in my code, these are not in the original code.
Full code below;
Sub emailer()
'Only working in Office 2007-2013
'Don't forget to set a reference to Outlook in the VBA editor
Application.ScreenUpdating = False
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String, AFRng As Range, AFData As Range, Reg As Worksheet, RngToCopy As Range, cll As Range
Dim strend As String
Dim rng As Range
Set Reg = Sheets("ASR Regular")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set AFRng = Intersect(Sheets("Skus").UsedRange, Sheets("Skus").Range("$B:$E"))
Set AFData = AFRng.Resize(AFRng.Rows.Count - 1).Offset(1)
For Each cll In Reg.Range(Reg.Cells(4, 2), Reg.Cells(4, 2).End(xlToRight)).Cells
AFRng.AutoFilter Field:=1, Criteria1:=cll
Set RngToCopy = Nothing
On Error Resume Next
Set RngToCopy = AFData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not RngToCopy Is Nothing Then
strbody = "The ASR team have noticed that there have not been any sales on the below product or products in the last 4 weeks, and we would like to help you to maximise your sales on these." & "<br>" & "<br>" & _
"Can you please check in the first instance that you have the stock of each product, and if so is it being offered for sale to our customers?" & "<br>" & "<br>" & _
"If you do not have the stock, then can you please correct your Bookstock so that ASR can send you the correct stock that you need so we can sell these amazing products to our customers." & "<br>" & "<br>" & _
"Sku ------ Desc ------------------------------------------ Bookstock --- On Order" & "<br>"
strend = "<br>" & "Thank you" & "<br>" & _
"The ASR Team"
On Error Resume Next
With OutMail
.To = cll
.CC = "asr.helpdesk@poundland.co.uk"
.BCC = ""
.Subject = "No Sales Last 4 Weeks - Bookstock Check"
.HTMLBody = strbody & RangetoHTML(RngToCopy) & strend
.SentOnBehalfOfName = "ASR.helpdesk@poundland.co.uk"
'SendUsingAccount is new in Office 2007
'Change Item(1)to the account number that you want to use
'.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'.SentOnBehalfOfName = """SenderName"" <Reply@Address.com>"
.Send 'or use .Display or .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next cll
'Set rng = Sheets("Sheet1").Range("D4:g6").SpecialCells(xlCellTypeVisible)
Application.ScreenUpdating = True
End Sub
And
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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