ThrottleWorks
Excel Ninja
Hi,
I am creating email by below mentioned code. This code saves email as draft in outlook.
At a single run macro is supposed to save more than 250 emails. However somewhere around 50 emails.
I am facing below bug.
Out of memory or system resources. Close some windows or programs and try again
Can anyone please help me to resolve this.
Code used for creating e-mails.
I am creating email by below mentioned code. This code saves email as draft in outlook.
At a single run macro is supposed to save more than 250 emails. However somewhere around 50 emails.
I am facing below bug.
Out of memory or system resources. Close some windows or programs and try again
Can anyone please help me to resolve this.
Code used for creating e-mails.
Code:
Option Explicit
Sub Create_Email()
Dim EmailRng As Range
Dim OutApp As Object
Dim OutMail As Object
EmailSht.Range("B4") = Application.UserName
EmailSht.Range("B5").FormulaR1C1 = "=SEARCH("","",R[-1]C)+2"
EmailSht.Range("B6").FormulaR1C1 = "=SEARCH(""("",R[-2]C)"
EmailSht.Range("B7").FormulaR1C1 = "=R[-1]C-R[-2]C"
EmailSht.Range("B8").FormulaR1C1 = "=MID(R[-4]C,R[-3]C,R[-1]C)"
EmailSht.Range("B9").FormulaR1C1 = "=LEFT(R[-5]C,R[-4]C-3)"
EmailSht.Range("B10").FormulaR1C1 = "=R[-2]C&"" ""&R[-1]C"
EmailSht.Range("B5:B10").Value = EmailSht.Range("B5:B10").Value
Dim TempLr As Long
TempLr = EmailSht.Cells(EmailSht.Rows.Count, 5).End(xlUp).Row
Set EmailRng = EmailSht.Range("F1:F" & TempLr)
MacroBook.Activate
EmailSht.Select
EmailSht.Range("A1").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim MyPath As String
MyPath = ThisWorkbook.Worksheets("Mapping").Range("A2").Value
With OutMail
.To = EmailSht.Range("B1").Value
.CC = EmailSht.Range("B2").Value
'.BCC = EmailMapSht.Range("B1").Value
.Subject = EmailSht.Range("B3").Value
.Attachments.Add (MapSht.Range("A3").Value)
.HTMLBody = RangetoHTML(EmailRng)
.Display
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
Dim MacroBook As Workbook
Dim EmailSht As Worksheet
Set MacroBook = ThisWorkbook
Set EmailSht = MacroBook.Worksheets(Email_Body.Name)
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Dim TempLr As Long
Dim EmailRng As Range
TempLr = EmailSht.Cells(EmailSht.Rows.Count, 6).End(xlUp).Row
Set EmailRng = EmailSht.Range("F1:F" & TempLr)
EmailRng.Copy
Set TempWB = Workbooks.Add(1)
TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteFormats
Columns("A:A").ColumnWidth = 150
Cells.Font.Name = "Calibri"
Cells.Font.Size = 10
Cells.Font.Color = 8210719
Columns.AutoFit
With TempWB.Sheets(1)
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=")
RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]> <![endif]-->", "")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
