Sending emailswith CDO
 

The following code below uses Outlook and I get that popup
saying A program is sending email on your behalf. Is
there anyway to convert the following code to do exactly
what it does now, just send using CDO where that message
does not pop up? Thank you.

Private Sub CommandButton2_Click()
Dim ol As New Outlook.Application
Dim olmail As MailItem
Dim cell As Range, cell2 As Range
Dim shRng As Range
Dim sh As Worksheet, sharr() As String
Dim wb As Workbook
Dim i As Integer

Set sh = ThisWorkbook.Sheets("Team Management Database")
i = 1
Set ol = New Outlook.Application

For Each cell In sh.Range("a3", Range("a3").End(xlDown))
Set shRng = cell.Offset(0, 9)
ReDim sharr(1 To shRng.Offset(0, 50).End
(xlToLeft).Column - _
shRng.Column + 1)

For Each cell2 In sh.Range(shRng, shRng.Offset(0,
50).End(xlToLeft))
sharr(i) = cell2.Value
i = i + 1
Next cell2

ThisWorkbook.Sheets(sharr).Copy
Set wb = ActiveWorkbook
wb.SaveAs Filename:="C:\Sheets.xls"

Set olmail = ol.CreateItem(olMailItem)
With olmail
.To = cell.Offset(0, 2).Value
.Subject = "Your Stats"
.Body = "Here are your stats, " & cell.Offset(0,
1).Value
.Attachments.Add wb.Path & "\" & wb.Name
.Display
.Send
End With

wb.Close savechanges:=False
i = 1
Kill "c:\sheets.xls"
Next cell
End Sub