Array index out of bound - Error while sending mail through macro

[kamdardharmesh]

I was using following macro and was sending attachment through mail. but today, it has given following error


Array index out of bound - Run time error 440.


While deleting attachments of previous mail, it throws error.


Specific part of error is as under.


For x = 1 To .Item.Attachments.Count

.Item.Attachments(x).Delete


Next x


Pls help in resolving the same.


Entire code is as under.


Sub drkthree()

'

' dkthree Macro

'


'


Set fs = CreateObject("Scripting.FileSystemObject")

fs.DeleteFile "D:dataPortfolioMacroLostCustomers.xls", force

fs.DeleteFile "D:dataPortfolioMacroTopCustomers.xls", force


For i = 1 To 5

Range("P1") = i


Range("A6").Select

Range(Selection, Selection.End(xlToRight)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Workbooks.Add

ActiveSheet.Paste

Columns("K:K").Select

Selection.ColumnWidth = 22.71

Range("J:J,L:M").Select

Range("L1").Activate

Selection.ColumnWidth = 10.14

Selection.ColumnWidth = 11

Application.CutCopyMode = False

Selection.NumberFormat = "[$-409]d-mmm-yy;@"

ActiveWindow.DisplayGridlines = False

Range("A1").Select

Application.DisplayAlerts = False


Columns("A:Q").Select

Application.CutCopyMode = False

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("P11").Select

Application.CutCopyMode = False


Columns("A:Q").Select

Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False

Application.CutCopyMode = False


ActiveWorkbook.SaveAs Filename:= _

"D:dataPortfolioMacroLostCustomers.xls", FileFormat:= _

xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

, CreateBackup:=False


ActiveWindow.Close

Application.DisplayAlerts = True


'14Aug13

Range("A22").Select

Range(Selection, Selection.End(xlToRight)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Workbooks.Add

ActiveSheet.Paste

Columns("H:H").Select

Selection.ColumnWidth = 22.71

Range("G:G,I:J").Select

Range("I1").Activate

Selection.ColumnWidth = 10.14

Selection.ColumnWidth = 11

Application.CutCopyMode = False

Selection.NumberFormat = "[$-409]d-mmm-yy;@"

ActiveWindow.DisplayGridlines = False

Range("A1").Select

Application.DisplayAlerts = False


Columns("A:Q").Select

Application.CutCopyMode = False

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("P11").Select

Application.CutCopyMode = False

Columns("A:Q").Select

Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _

SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

ReplaceFormat:=False

Application.CutCopyMode = False

ActiveWorkbook.SaveAs Filename:= _

"D:dataPortfolioMacroTopCustomers.xls", FileFormat:= _

xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

, CreateBackup:=False


ActiveWindow.Close

Application.DisplayAlerts = True


'14 Aug 13


'End Sub


'Sub drktwo()

'

Dim AWorksheet As Worksheet

Dim Sendrng As Range

Dim rng As Range


On Error GoTo StopMacro


With Application

.ScreenUpdating = False

.EnableEvents = False

End With


'Fill in the Worksheet/range you want to mail

'Note: if you use one cell it will send the whole worksheet

Set Sendrng = Worksheets("Sheet4").Range("A1:N69")


'Remember the activesheet

Set AWorksheet = ActiveSheet


With Sendrng


' Select the worksheet with the range you want to send

.Parent.Select


'Remember the ActiveCell on that worksheet

Set rng = ActiveCell


'Select the range you want to mail

.Select


' Create the mail and send it

ActiveWorkbook.EnvelopeVisible = True

With .Parent.MailEnvelope


For x = 1 To .Item.Attachments.Count

.Item.Attachments(x).Delete


Next x


' Set the optional introduction field thats adds

' some header text to the email body.

'.Introduction = "This is test mail 2."


With .Item

.To = Range("R1")

.CC = Range("S1")

'.BCC = ""

.Subject = Range("Q2")

.Attachments.Add "D:dataPortfolioMacroLostCustomers.xls"

.Attachments.Add "D:dataPortfolioMacroTopCustomers.xls"

.Send

' Set fs = CreateObject("Scripting.FileSystemObject")

' fs.DeleteFile "C:Usersdharmesh4033DesktopPortfolioMacroCustomers.xls", force

End With


End With


'select the original ActiveCell

rng.Select

End With


'Activate the sheet that was active before you run the macro

AWorksheet.Select


StopMacro:

With Application

.ScreenUpdating = True

.EnableEvents = True

End With


ActiveWorkbook.EnvelopeVisible = False


Next i


End Sub

 

[lohithsriram]

Check if your previous email has got any attachments. If there are no attachments then the (.Item.Attachments.Count) will be 0 and your loop will fail if there are no attachments to delete.


For x = 1 To .Item.Attachments.Count

.Item.Attachments(x).Delete

Next x

 

[kamdardharmesh]

No. My previous email also had attachment

 

[lohithsriram]

Put a breakpoint and check the (.Item.Attachments.Count) value before the next statement gets executed. I guess, it is setting up this value to 0 in some form which is breaking this. Also set (X=0) before the for loop and try.

 

[kamdardharmesh]

Have tried, but nothing has worked.

 

[lohithsriram]

Not sure, if this affects any other part of your code but give a try. Check the number of attachments (.Item.Attachments.Count) before the loop and run it only if the attachment count is greater than 0.


If .Item.Attachments.Count >0 then

For x = 1 To .Item.Attachments.Count

.Item.Attachments(x).Delete

Next x

endif