Private Sub cmdRun_Click()
Dim strSQL As String
Dim strReportLocation As String
Dim qd As QueryDef
Dim db As Database
Dim rs As DAO.Recordset
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim xl As New Excel.Application
Dim wkbook As Workbook
Dim fileToOpen As String
 
 
On Error GoTo err_handler
 
User = CreateObject("wscript.Network").UserName
 
DoCmd.SetWarnings False
 
'Open the Email Distribution List
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT TAXID, EMAIL FROM LIST")
 
'Loop through distribution list and send member detail to excel file
 
If Not (rs.EOF And rs.BOF) Then
 
Do Until rs.EOF
     On Error Resume Next
     strSQL = "SELECT [MEMBER], [PAID], [email] FROM Rpt WHERE [TAXID] = " & rs![TAXID]
          Set qd = CurrentDb.CreateQueryDef("Email_Provider_Incentive", strSQL)
          strReportLocation = "C:\Users\" & User & "\Desktop\Provider_Incentive" & Format(Date, "mmddyy") & ".xls"
          DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Email_Provider_Incentive", strReportLocation, True
          CurrentDb.QueryDefs.Delete "Email_Provider_Incentive"
          xl.DisplayAlerts = False
          Set wkbook = xl.Workbooks.Open(strReportLocation)
          fileToSaveAs = "Provider_Incentive" & Format(Date, "mmddyy") & ".xls"
          ActiveWorkbook.SaveAs FileName:=fileToSaveAs, Password:="ANTHEM"
          ActiveWorkbook.Close
 
          xl.DisplayAlerts = True
    'Send email with attached excel workbook created above
 
        Set appOutLook = CreateObject("Outlook.Application")
        Set MailOutLook = appOutLook.CreateItem(olMailItem)
        With MailOutLook
            .BodyFormat = olFormatRichText
            .To = rs![email]
            .Subject = "[SECURE] Provider Incentive Auto email TEST"
            .HTMLBody = "This is a TEST of the Provider Incentive Auto Email"
            .Attachments.Add (strReportLocation)
            .Send
 
        End With
  rs.MoveNext
 'Move to the next TAXID
 Loop
 
Else
  MsgBox "There are no Records to process"
End If
 
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
Set xl = Nothing
Set wkbook = Nothing
DoCmd.SetWarnings True
MsgBox "The Automated Provider Email process has completed."
 
Exit Sub
 
err_handler:
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
Set xl = Nothing
Set wkbook = Nothing
DoCmd.SetWarnings True
MsgBox Err.Number & Err.Description
End Sub

With ActiveWorkbook
.SaveAs FileFormat:=xlNormal, Password:="YourPassword", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
.Close
End With

          wkbook.SaveAs FileName:=fileToSaveAs, FileFormat:=56, Password:="ANTHEM"
          wkbook.Close