email report based on unique ID

[klkropf]

I need to email reports based on the unique ID in the page header of the
report. I have written some code in VB and it's emailing the report but it's
emailing the entire report instead of just the one page unique to the
employee, it's also prompting me to enter the unique ID for each employee. I
just need it to cycle through the query and email the appropriate page to the
correct employee. Below is the code I'm using. "Pernr" is the unique ID and
the report name is "rptSI".

Any help would be very much appreciated. Thanks!



Private Sub cmdRunReports2_Click()

On Error GoTo PROC_ERR

' Declare variables
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strAcountStatus As String
Dim strEmail As String
Dim strUserID As String
Dim fOk As Boolean

' Build our SQL string
strSQL = "SELECT Pernr, email From [qrySI]"

' Set our database and recordset objects
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL)

' Open the report
DoCmd.OpenReport "rptSI", acPreview

' Turn the filter on
Reports![rptSI].FilterOn = True

' Loop the recordset
Do While Not rst.EOF

' Grab the Email string
strEmail = rst.Fields("email")

' Grab the UserID string
strUserID = rst.Fields("Pernr")

' Call the procedure used to filter the report based on the Current employee
Call FilterReport("rptSI", strUserID)

' Allow the report to refresh after filtering
DoEvents

' Send the snapshot of the report to the current employee
fOk = SendReportByEmail("rptSI", strEmail)

' Display message if failure
If Not fOk Then
MsgBox "Delivery Failure to the following email address: " & strEmail
End If

' Move and loop
rst.MoveNext
Loop

' Clean up
st.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox Err.Description
Resume PROC_EXIT
End Sub


Public Sub FilterReport(strReportName As String, strUserID As String)


' Comments: Filters Report based on UserID parameter
' Parameters: strUserID - employee's email UserID
' strReportName - report name
On Error GoTo PROC_ERR

' Declare variables
Dim strSQL As String

'Build SQL String
strSQL = "[UserID] " & " = '" & strUserID & "'"

' Filter the report
Reports(strReportName).Filter = strSQL

' Turn the filter on
Reports(strReportName).FilterOn = True

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox Err.Description
Resume PROC_EXIT
End Sub


Function SendReportByEmail(strReportName As String, strEmail As String) As
Boolean

' Comments: Sends an email using SendObject method
' Parameters: strEmail - employee's email address
' strReportName - report name
' Returns: True of False

On Error GoTo PROC_ERR

Dim strRecipient As String
Dim strSubject As String
Dim strMessageBody As String

'set the mail varaibles
strRecipient = strEmail
strSubject = Reports(strReportName).Caption
strMessageBody = "Your Special Incentive report is attached."

'send the report as a snapshot
DoCmd.SendObject acSendReport, strReportName, acFormatSNP, strRecipient,
, , strSubject, strMessageBody, False

SendReportByEmail = True

PROC_EXIT:
Exit Function

PROC_ERR:
SendReportByEmail = False
If Err.Number = 2501 Then
Call MsgBox( _
"The email was not sent for " & strEmail & ".", _
vbOKOnly + vbExclamation + vbDefaultButton1, _
"User Cancelled Operation")
Else
MsgBox Err.Description
End If
Resume PROC_EXIT


End Function