error in VBA that sends email using outlook

[Fadel Naeem]

hello everybody,
i have this code which works just fine it simply copy the needed sheet and attach it to an email and then sends it.
the problem is when i try to run the code again (in the same session) without restarting the outlook the following error pops up:

<code>runtime error,automation error, system call failed,

</code>and the debuger highlight this line of the code

<code>Set OutApp = CreateObject("Outlook.Application")

</code>and it says something about a blocked object.
can anyone help? all i need is to be able of running this multiple times without restarting outlook.

thanks alot


Set ActWks = ActiveSheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim Rng As Range
Dim iRange As Long
Dim SiteID As String
Dim OwnerName As String
Dim OwnerID As String
Dim PaymentBenficiary As String
Dim InitialRentAmount As String
Dim PaymentMethod As String
Dim DueDate As String
Dim City As String
Dim SubsecquentRentAmount As String
Dim RBSType As String
Dim WMfreeminutes As String
Dim NumberofSIMs As String
Dim MobileCommettment As String
Dim Comments As String
Dim WS As Worksheet
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

Start = Timer
counter = 1
counter1 = 2

Set WS = Sheets.Add
WS.Select
With WS.Tab
.Color = 255
.TintAndShade = 0
End With
Range("A1:N1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Columns("A:N").Select
Selection.ColumnWidth = 24
Columns("G:G").Select
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
Columns("E:E").Select
Selection.Style = "Comma"
Selection.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
Range("A:A,B:B,C:C,D:D,F:F,H:H,I:I,J:J,K:K,L:L,M:M,N:N").Select
Selection.NumberFormat = "@"
Range("A1") = "Site ID"
Range("B1") = "Owner Name as Contract"
Range("C1") = "Owner ID#"
Range("D1") = "Payment Benficiary"
Range("E1") = "Initial Rent Amount"
Range("F1") = "Payment Method"
Range("G1") = "Due Date"
Range("H1") = "City"
Range("I1") = "Subsecquent Rent Amount"
Range("J1") = "RBS Type"
Range("K1") = "WM free minutes"
Range("L1") = "Number of SIMs"
Range("M1") = "Mobile Commettment"
Range("N1") = "Comments"
Range("A1:N1").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select

Sheets("Sheet1").Select
Range("BN1:BN600").FormulaR1C1 = _
"=IFERROR(IF(MONTH(RC[-50])=MONTH(TODAY())+1,""OK"",""NO""),""NO"")"

Do

Sheets("Sheet1").Select
Range("BN" & counter).Select

If Range("BN" & counter) = "OK" Then

iRange = (ActiveCell.Row)
Let SiteID = "A" & iRange
Let OwnerName = "B" & iRange
Let OwnerID = "D" & iRange
Let PaymentBenficiary = "F" & iRange
Let InitialRentAmount = "K" & iRange
Let PaymentMethod = "Q" & iRange
Let DueDate = "P" & iRange
Let City = "H" & iRange
Let SubsecquentRentAmount = "L" & iRange
Let RBSType = "T" & iRange
Let WMfreeminutes = "U" & iRange
Let NumberofSIMs = "V" & iRange
Let MobileCommettment = "AO" & iRange
Let Comments = "AP" & iRange

Sheets("Sheet1").Select
Range(SiteID).Copy
WS.Select
Range("A" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(OwnerName).Copy
WS.Select
Range("B" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(OwnerID).Copy
WS.Select
Range("C" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(PaymentBenficiary).Copy
WS.Select
Range("D" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(InitialRentAmount).Copy
WS.Select
Range("E" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(PaymentMethod).Copy
WS.Select
Range("F" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(DueDate).Copy
WS.Select
Range("G" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(City).Copy
WS.Select
Range("H" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(SubsecquentRentAmount).Copy
WS.Select
Range("I" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(RBSType).Copy
WS.Select
Range("J" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(WMfreeminutes).Copy
WS.Select
Range("K" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(NumberofSIMs).Copy
WS.Select
Range("L" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(MobileCommettment).Copy
WS.Select
Range("M" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Sheet1").Select
Range(Comments).Copy
WS.Select
Range("N" & counter1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
counter1 = counter1 + 1

End If

counter = counter + 1
Sheets("Sheet1").Select
Range("BN" & counter).Select
Loop Until counter = 600

Sheets("Sheet1").Select
Range("BN1:BN600").ClearContents
Range("A1").Select

WS.Select
Range("A1").Select

Set Sourcewb = ActiveWorkbook

ActiveSheet.Copy

Set Destwb = ActiveWorkbook

If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If

TempFilePath = Environ("temp") & "\"
TempFileName = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy ss")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)

With Destwb
On Error Resume Next
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
If Err.Number <> 0 Then MsgBox "FileName Taken!"
With OutMail
.To = "whatever@whatever"
.CC = ""
.BCC = ""
.Subject = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy")
.Body = "FYI"
.Attachments.Add Destwb.FullName
.Send
End With
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr
OutMail.Quit

Set OutMail = Nothing
Set OutApp = Nothing
WS.Delete

ActWks.Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Set ActWks = Nothing

Sheets("Sheet1").Select
Range("A1").Select
MsgBox "Fadel AbdulRahman: Done successfully in " & Round((Timer - Start), 2) & " Seconds", vbInformation


End Sub

 

[VBA Geek]

Try:

On error resume next
[COLOR=#333333][FONT=monospace]Set OutApp = GetObject(,"Outlook.Application")
if outapp is nothing then [/FONT][/COLOR][COLOR=#333333][FONT=monospace]Set OutApp = CreateObject("Outlook.Application")
on error goto 0
[/FONT][/COLOR]

 

[Fadel Naeem]

thanks alot man this worked perfectly