mattmickle
Board Regular
- Joined
- Nov 17, 2010
- Messages
- 81
I have a time-tested, tried and true VBA macro that has worked right up until the moment my company installed Office 365. Now, it only partially works. Based on Ron DeBruin's brilliant coding, my code takes a range of Store Numbers (the range is expressed as P1:P79 in cell R6 of my spreadsheet, which is dynamic based on the information i put in the sheet each week), populates a cell, creates a report of information, takes a "snapshot" of that information, opens and addresses an email, pastes that "snapshot" into the body of the email and sends, then moves onto the next. Each "snapshot" is unique to the store that it is being sent to. WHen it's done looping through the range of stores, it pops up a message box to tell me it's done.
For some reason, in Office 365, it will loop through the stores (i can see it working as it goes), but it stops sending the emails after approximately half of them are sent. At the end, it pops up the message box as if it's done. No errors, no debugging, just ignoring sending 30+ of the store numbers in my range. If I put an artificial break in between each of the reports (a message box displaying the count of reports it's creating and sending), it works fine, but this defeats the purpose of the macro.
I know this code works. I've even gone backwards to re-run it in Excel 2007. So, my assumption is that somewhere in Outlook 365 it's blocking the emails from being sent, either because it's seeing it as spam (?) or it's timing out or some other reason that I can't think of.
Here's the code:
Any help would be appreciated...
Matt
For some reason, in Office 365, it will loop through the stores (i can see it working as it goes), but it stops sending the emails after approximately half of them are sent. At the end, it pops up the message box as if it's done. No errors, no debugging, just ignoring sending 30+ of the store numbers in my range. If I put an artificial break in between each of the reports (a message box displaying the count of reports it's creating and sending), it works fine, but this defeats the purpose of the macro.
I know this code works. I've even gone backwards to re-run it in Excel 2007. So, my assumption is that somewhere in Outlook 365 it's blocking the emails from being sent, either because it's seeing it as spam (?) or it's timing out or some other reason that I can't think of.
Here's the code:
Code:
Sub Mail_Store()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim TBody As String
Dim UBody As String
'Page range for selection
Set prange = ActiveWorkbook.Worksheets("Data").Range("R9").Cells
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Sheets("Data").Range(prange).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
Set Srange = ActiveWorkbook.Worksheets("Email").Range("L5").Cells
TBody = Sheets("Email").Range("G2").Value & "
" & _
Sheets("Email").Range("G3").Value & Sheets("Email").Range("G4").Value & "
"
UBody = "
" & Sheets("Email").Range("H2").Value & "
" & _
Sheets("Email").Range("H3").Value & "
" & _
Sheets("Email").Range("H4").Value & "
" & _
Sheets("Email").Range("H5").Value & "
" & _
Sheets("Email").Range("H6").Value & "
" & _
Sheets("Email").Range("H7").Value & "
" & _
Sheets("Email").Range("H8").Value & "
" & _
Sheets("Email").Range("H9").Value & "
" & _
Sheets("Email").Range("H10").Value
For Each scount In ActiveWorkbook.Worksheets("Email").Range(Srange).Cells
With OutMail
.To = ActiveWorkbook.Worksheets("Email").Range("D" & scount).Cells
.CC = ActiveWorkbook.Worksheets("Email").Range("E" & scount).Cells
.Subject = ActiveWorkbook.Worksheets("Email").Range("F" & scount).Cells
.HTMLBody = TBody & RangetoHTML(rng) & "
" & UBody
.Attachments.Add ("[URL="file://\\golub.com\depts\HR-Share\Matt\CUSTOMERS\Jill"]\\golub.com\depts\HR-Share\Matt\CUSTOMERS\Jill[/URL] Valachovic\401k_Startup.doc")
.Send
End With
Next
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
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 FunctionAny help would be appreciated...
Matt
