Macro not attaching the file specified

[Latha]

Team,

I have the below macro which I copied from Ron De Bruin's tutorial (Mail more then one sheet)
and edited it a bit to suit my requirement. But it is not attaching the file created at the temp location and just sending the emails.

Please help me please please...

Sub Send_Mail_Click()
Dim olapp As Outlook.Application
Dim olmail As Outlook.MailItem
Dim rng1 As Range
Dim rng2 As Range
Dim StrBody1 As String
Dim StrBody2 As String
Dim LResult As String
Dim i As Long
Dim SigString As String
Dim Signature As String
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 sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window

Application.EnableCancelKey = xlDisabled
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Altisource", "AspsByGroup")).Copy
End With

'Close temporary Window
TempWindow.Close

Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
'Change all cells in the worksheets to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Destwb.Worksheets(1).Select
Next

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "IncidentAgeingReport"

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False

For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
Set olapp = New Outlook.Application
Set rng1 = Sheets("AspsByGroup").Range("C1:I1").SpecialCells(xlCellTypeVisible)
Set rng2 = Sheets("AspsByGroup").Range(Cells(i, 3), Cells(i, 9)).SpecialCells(xlCellTypeVisible)
Set olmail = olapp.CreateItem(olMailItem)


SigString = Environ("appdata") & _
"\Microsoft\Signatures\Latha.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next
With olmail
.To = Cells(i, 1).Value
.CC = "Vikram.Poovanna@altisource.com;" & "Sunil.Kumar2@altisource.com;" & "Gaurav.Kansal@altisource.com"
.Subject = "Ageing and Open Tickets <" & Cells(i, 4).Value & "> Test_Email"

'Set body format to HTML

StrBody1 = "<P STYLE='font-family:Trebuchet MS (10) ;font-size:13'>Hi " & Sheets("AspsByGroup").Cells(i, 3).Value & "<p>" & _
"<P STYLE='font-family:Trebuchet MS (10) ;font-size:13'>Please find the details of tickets and the ageing as "

StrBody2 = Format(Now, "dd.mmm.yyyy") & " for the resolver group you own. We seek your support to reduce this to zero tickets over 10 days, and help to not beach SLA for any ticket. Providing this level of service, you will agree, will improve customer satisfaction and end user delight." & "<br><br>" & _
"<P STYLE='font-family:Trebuchet MS (10) ;font-size:13'>Please Note : Service desk will send this report to all of you for the next 2 weeks to enable you to track your progress. If you need our assistance, please do let us know." & "<p>"

.HTMLBody = StrBody1 & StrBody2 & RangetoHTML(rng1, rng2) & "<br>" & Signature
.Attachments.Add Destwb.FullName

.Send

End With
On Error GoTo 0

Set olmail = Nothing
Set olapp = Nothing
Next
ThisWorkbook.Save
End With
End Sub

 

[Comfy]

Destwb doesn't exist as you have closed it.

You should receive an error message but you have "On error resume next"

try this:

.Attachments.Add TempFilePath & TempFileName & FileExtStr

 

[Latha]

Thank you so much Comfy. that's great !

could you please help me to set up a condition as well with the above code like.. for each receipient Excel should check for cell value in column I and if it is greater than 10 then only it should send the email and should go to next receipient and do the same.

Thanks a lot for you help. if the above is done.. my project is 100% complete. please help.

 

[Comfy]

For i = 2 To AspsByGroup.Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i,9).Value > 10 Then
Set olapp = New Outlook.Application
Set rng1 = Sheets("AspsByGroup").Range("C1:I1").SpecialCells(xlCellTypeVisible)
Set rng2 = Sheets("AspsByGroup").Range(Cells(i, 3), Cells(i, 9)).SpecialCells(xlCellTypeVisible)
Set olmail = olapp.CreateItem(olMailItem)




SigString = Environ("appdata") & _
"\Microsoft\Signatures\Latha.htm"


If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If


On Error Resume Next
With olmail
.To = Cells(i, 1).Value
.CC = "Vikram.Poovanna@altisource.com;" & "Sunil.Kumar2@altisource.com;" & "Gaurav.Kansal@altisource.com"
.Subject = "Ageing and Open Tickets <" & Cells(i, 4).Value & "> Test_Email"


'Set body format to HTML


StrBody1 = "
Hi " & Sheets("AspsByGroup").Cells(i, 3).Value & "


" & _
"


Please find the details of tickets and the ageing as "


StrBody2 = Format(Now, "dd.mmm.yyyy") & " for the resolver group you own. We seek your support to reduce this to zero tickets over 10 days, and help to not beach SLA for any ticket. Providing this level of service, you will agree, will improve customer satisfaction and end user delight." & "


" & _
"


Please Note : Service desk will send this report to all of you for the next 2 weeks to enable you to track your progress. If you need our assistance, please do let us know." & "


"


.HTMLBody = StrBody1 & StrBody2 & RangetoHTML(rng1, rng2) & "
" & Signature
.Attachments.Add Destwb.FullName


.Send


End With
On Error GoTo 0


Set olmail = Nothing
Set olapp = Nothing
End if
Next

It appears as though you are sending the same file to everyone listed in column A.

Do you really need to use VBA? Can you make the message more generic and blind copy (bcc) everyone?

 

[Latha]

Yes I m sending the same file to everyone in column A.

But the mail body differs for everyone and everyone should get only their corresponding row in the body of the email. This is the intension of this.

Is there a possibility to copy data which are relevant to a person and attach all that into the email body?

For example : in column A there are email IDs of the managers
in column B there are group names

say for example im the manager for 4 groups. so instead of sending 4 separate emails to me, can excel find for my name and copy all the cells relevant to me and send it in one email?