Queries, Reports 1

[geaker]

I have the following code working, probably not the best but my first time in VB. This runs a query, makes a table, writes the report to disk, opens the table and checks for up to 5 eamil addresses, then emails the report as an attachment. This worked fine until the user decided they didn't want to have to type in the ServiceCenter, we have 62 Service Centers, number and wanted the button to create the reports for each service center and email them to up to 5 people without having to type the ServiceCenter number in. Is there a way to clean up my code and/or create a table sorted by ServiceCenter and loop through this code to create and email the individual Service Center reports. Or some way to dynamically create the reports and email by ServiceCenter without human intervention?

Help Please,
Gerald

The code I have now:

Private Sub CheckRegisterByDR_Click()
On Error GoTo Err_CheckRegisterByDR_Click

Dim stDocName As String, stPath As String
Dim strEmail As String
Dim dbs As Database, rs As Recordset
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem

Set appOutLook = CreateObject("Outlook.Application&quot
Set MailOutLook = appOutLook.CreateItem(olMailItem)
stDocName = "CheckRegisterbyDateRangeforEmail"
stPath = "C:\ImportDataforZurich\CheckRegisterEmail.RTF"

'Run Query

DoCmd.OpenQuery stDocName, acNormal, acEdit

'Save Report to Disk

DoCmd.OutputTo ObjectType:=acOutputReport, _
objectName:=stDocName, _
OutputFormat:=acFormatRTF, _
OutputFile:=stPath, _
AutoStart:=False

'Setup String for Email Addresses
Set rs = dbs.OpenRecordset("CheckRegisterEmail", dbOpenDynaset)
rs.MoveFirst

If Not IsNull(rs!Email1) Then
strEmail = strEmail & rs!Email1
End If
If Not IsNull(rs!Email2) Then
strEmail = strEmail & ";" & rs!Email2
End If
If Not IsNull(rs!Email3) Then
strEmail = strEmail & ";" & rs!Email3
End If
If Not IsNull(rs!Email4) Then
strEmail = strEmail & ";" & rs!Email4
End If
If Not IsNull(rs!Email5) Then
strEmail = strEmail & ";" & rs!Email5
End If

'Email Reports

With MailOutLook
.To = strEmail
.Subject = "Check Register Report for " & rs!ServiceCenter & " on " & Date
.Body = "Attached is the Check Register Report for your Service Center." _
& (Chr$(13)) & (Chr$(10)) & (Chr$(13)) & (Chr$(10)) & (Chr$(13)) & (Chr$(10)) _
& "Thank you," & (Chr$(13)) & (Chr$(10)) & "Robin"
.Attachments.Add stPath
.Send

End With

rs.Close
Set rs = Nothing
Set dbs = Nothing
Set MailOutLook = Nothing
appOutLook.Quit

Exit_CheckRegisterByDR_Click:
Exit Sub

Err_CheckRegisterByDR_Click:
MsgBox Err.Description
Resume Exit_CheckRegisterByDR_Click

End Sub



The SQL for the query is:

SELECT Payment.*, ServiceCenters.Email1, ServiceCenters.Email2, ServiceCenters.Email3, ServiceCenters.Email4, ServiceCenters.Email5 INTO CheckRegisterEmail
FROM Payment LEFT JOIN ServiceCenters ON Payment.ServiceCenter = ServiceCenters.ServiceCenter
WHERE (((Payment.ServiceCenter)=[Enter Service Center Number]) AND ((Payment.PostDate) Between [Start Post Date] And [End Post Date]))
ORDER BY Payment.ServiceCenter, Payment.CheckNumber, Payment.InvoiceKey;

 

[JoyInOK]

I think your code looks pretty good, first time or no!

You've already created a recordset with the service center numbers in it, so yeah, we can loop through them. Do you want to create a new form where the user can put the start and end dates in textboxes, then press a button to loop through, creating each reportand emailing it?
If the start and end dates are standard, like the first and last day of last month, or the first day of the quarter to the last day of last month, we can do away with the textboxes and let Access figure out the appropriate dates.

 

[geaker]

Joy,
I have a form that the user uses which has the command button to email the reports. All of the Vb code above executes on the 'on click' event. I want the user in input the start and end date once on the form if possible and then loop through the table to create and email each service center report.

Thanks,
Gerald

 

[JoyInOK]

Okay, just thought if it was a standard period, we could fill in the default time period (first day of last month for Start Period and last day of last month for End Period, for example). The user could then modify the dates if needed.
I will post some code for you soon.

 

[JoyInOK]

Try this out:
Private Sub CheckRegisterByDR_Click()
On Error GoTo Err_CheckRegisterByDR_Click

Dim stDocName As String, stPath As String
Dim strEmail As String
Dim dbs As Database, rs As DAO.Recordset
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem

Set appOutLook = CreateObject("Outlook.Application&quot
Set MailOutLook = appOutLook.CreateItem(olMailItem)
stDocName = "CheckRegisterbyDateRangeforEmail"

stPath = "C:\ImportDataforZurich\CheckRegisterEmail.RTF"

Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("CheckRegisterEmail&quot 'this query should be pre-set to show
'ALL service center numbers and their email addresses
'loop through the recordset, setting the query on which the report is based,
'creating the report, saving the report as an rtf file, then emailing it to each
'email listed for the given record
Dim intServiceCenterNo As Integer
Dim strStartDate As String
Dim strEndDate As String
'if text entered is valid date, assign that text to the variables
If IsDate(Me.StartDate) Then
strStartDate = Me.StartDate
Else
MsgBox "Start Date is not a valid date"
Me.StartDate.SetFocus
Exit Sub
End If
If IsDate(Me.EndDate) Then
strEndDate = Me.EndDate
Else
MsgBox "End Date is not a valid date"
Me.EndDate.SetFocus
Exit Sub
End If

'set the query with the given criteria
Dim strSQL As String 'holds the SQL for the query on which the report is based
Dim qdfQuery As QueryDef
Set qdfQuery = CurrentDb.QueryDefs(stDocName) 'the query on which the report is based
rs.MoveLast 'force Access to get an accurate recordcount
rs.MoveFirst
Dim i As Integer
For i = 1 To rs.RecordCount
intServiceCenterNo = rs.Fields("ServiceCenter&quot
'form the SQL statement with the criteria for this service center and the given dates
strSQL = "SELECT Payment.*, ServiceCenters.Email1, ServiceCenters.Email2, ServiceCenters.Email3, ServiceCenters.Email4, ServiceCenters.Email5 FROM Payment LEFT JOIN ServiceCenters ON Payment.ServiceCenter = ServiceCenters.ServiceCenter WHERE (((Payment.ServiceCenter)= " & intServiceCenterNo & &quot AND ((Payment.PostDate) Between #" & strStartDate & "# And #" & strEndDate & "#)) ORDER BY Payment.ServiceCenter, Payment.CheckNumber, Payment.InvoiceKey;"
'Set the query
qdfQuery.SQL = strSQL
qdfQuery.Close 'now the query the report is based on has the correct service center and dates
'Save Report to Disk

DoCmd.OutputTo ObjectType:=acOutputReport, _
objectName:=stDocName, _
OutputFormat:=acFormatRTF, _
OutputFile:=stPath, _
AutoStart:=False

'Setup String for Email Addresses


If Not IsNull(rs!Email1) Then
strEmail = strEmail & rs!Email1
End If
If Not IsNull(rs!Email2) Then
strEmail = strEmail & "; " & rs!Email2
End If
If Not IsNull(rs!Email3) Then
strEmail = strEmail & "; " & rs!Email3
End If
If Not IsNull(rs!Email4) Then
strEmail = strEmail & "; " & rs!Email4
End If
If Not IsNull(rs!Email5) Then
strEmail = strEmail & "; " & rs!Email5
End If

'Email Reports

Set MailOutLook = appOutLook.CreateItem(olMailItem)

With MailOutLook
.To = strEmail
.Subject = "Check Register Report for " & intServiceCenterNo & " on " & Date
.Body = "Attached is the Check Register Report for your Service Center." _
& (Chr$(13)) & (Chr$(10)) & (Chr$(13)) & (Chr$(10)) & (Chr$(13)) & (Chr$(10)) _
& "Thank you," & (Chr$(13)) & (Chr$(10)) & "Robin"
.Attachments.Add stPath
.Send
strEmail = vbNullString
End With
rs.MoveNext
Next i
rs.Close
Set rs = Nothing
Set dbs = Nothing
Set qdfQuery = Nothing
Set MailOutLook = Nothing
appOutLook.Quit


Exit_CheckRegisterByDR_Click:
Exit Sub

Err_CheckRegisterByDR_Click:
MsgBox Err.Description
Resume Exit_CheckRegisterByDR_Click

End Sub