DoCmd.OpenReport "1", acViewPreview, , "[email] = " & Nz(lst.Column(1,
varItem))
Thanks!
--
Message posted via AccessMonster.com
http://www.accessmonster.com/Uwe/Forums.aspx/access-reports/200706/1
Add this function to your report module and change your code to this:
DoCmd.OpenReport "1", acViewPreview, , "[email] = in" &
getSelectedList(Me.lst)
'Returns a list of selected rows from a list box control. This list
will be evaluated by an "in" clause
Private Function getSelectedList(ctl As Control) As String
Dim currentRow As Integer
'Traverse through each code in the list to see if it is selected.
getSelectedList = "("
If ctl.ItemsSelected.Count > 0 Then
For currentRow = 0 To ctl.ListCount - 1
If ctl.Selected(currentRow) Then
If getSelectedList <> "(" Then getSelectedList =
getSelectedList & ", "
getSelectedList = getSelectedList & "'" &
ctl.Column(0, currentRow) & "'"
End If
Next currentRow
getSelectedList = getSelectedList & ")"
Else
getSelectedList = vbNullString
End If
End Function
-Kris
Set lst = Me![lstSelectContacts]
'Check that at least one contact has been selected
If lst.ItemsSelected.Count = 0 Then
MsgBox "Please select at least one contact"
lst.SetFocus
GoTo ErrorHandlerExit
End If
For Each varItem In lst.ItemsSelected
'Check for email address
strEMailRecipient = Nz(lst.Column(1, varItem))
Debug.Print "EMail address: " & strEMailRecipient
If strEMailRecipient = "" Then
GoTo NextContact
End If
DoCmd.OpenReport "1", acViewPreview
Set rpt = Reports("1")
'---------- set report filter and turn it on
rpt.FilterOn = True
'rpt.FilterOn = IIf(Len(pFilter) > 0, True, False)
'---------- save and close the changed report
DoCmd.Save acReport, "1"
DoCmd.Close acReport, "1"
DoCmd.SendObject acReport, 1, _
OutputFormat:=acFormatRTF, To:=strEMailRecipient, _
Subject:=strSubject, EditMessage:=False
NextContact:
Next varItem
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End Sub
--
Message posted via http://www.accessmonster.com
Public Function BuildWhereCondition(ctl As Control) As String
'Set up the WhereCondition Argument for the reports
Dim varItem As Variant
Dim strWhere As String
On Error GoTo BuildWhereCondition_Error
Select Case ctl.ItemsSelected.Count
Case 0 'Include All
strWhere = ""
Case 1 'Only One Selected
strWhere = "= '" & _
ctl.ItemData(ctl.ItemsSelected(0)) & "'"
Case Else 'Multiple Selection
strWhere = " IN ("
With ctl
For Each varItem In .ItemsSelected
strWhere = strWhere & "'" & .ItemData(varItem) & "', "
Next varItem
End With
strWhere = Left(strWhere, Len(strWhere) - 2) & ")"
End Select
BuildWhereCondition = strWhere
BuildWhereCondition_Exit:
On Error GoTo 0
Exit Function
BuildWhereCondition_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & _
") in procedure BuildWhereCondition of Module modUtilities"
GoTo BuildWhereCondition_Exit
End Function
Call it with the control and it will create the right side of the Where
condition. You just have to add the object you want to compare to:
strWhere = BuildWhereCondition(me.lstBox)
DoCmd.OpenReport "1", acViewPreview, , "[email] = " & strWhere
--
Dave Hargis, Microsoft Access MVP
What your code is trying to do is to modify the report and save the
filter prior to sending an email. I'm not too familiar with saving a
filter within a report and don't know if this approach will work.
What is your e-mail program? If you are using Outlook, I'll give you
the code I use to:
1. Loop through a list of recipients
2. Export a filtered report
3. Create and send an outlook message with the exported file as an
attachment
I don't mess with trying to save the filter as all my databases are
multi-user.
-Kris
--
'The calling function will be different depending on your application
'It will look something like this
'Place this in a standard module and modify it for your application.
You may want to add a parameter for the report.
public function EmailReportHelper()
'Setup
Dim rst as new adodb.recordset
Dim strSql as string
strSql = "select vendor, email " _
& "from vendorContact "
'Fetch
rst.open strsql, currentproject.connection, adopenforwardonly,
adlockreadonly
'Iterate through vendors - call the email function for each separate
criteria desired
'The "DoEvents" may not be necessary - I like having it for good
measure.
while not rst.eof
emailreport "Your Report Name", "Vendor = '" & rst(0) & "'", rst(1)
doevents
rst.movenext
wend
'Cleanup
if not rst is nothing then
if rst.state = adstateopen then rst.close
set rst = nothing
end if
end function
'Use with a report that has a filter-examining output criteria (see
later)
'Place this in a standard module. You will probably need to add a
reference to the
'Outlook Object Library. You can also modify this code to use late
binding and get around having to
'set the reference.
Public Function emailReport(strReportName As String, _
strFilter As String, _
Optional strTo As String, _
Optional strSubject As String) As Boolean
On Error GoTo emailReport_Err
'Declarations
Dim objOutlook As Outlook.Application, objOutlookMsg As
Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient, objOutlookAttach As
Outlook.Attachment
'Delete old outputfile
deleteEmailFile
'Open report - must be one that examines the Email = Email filter to
output to the getEmailFile() path
'Why do I do this? Seems strange to express TRUE as 'Email' = 'Email'
- this allows me to use the same report
'in multiple areas. In my application, the user selects the type of
output (preview, print, email, fax, etc.)
DoCmd.OpenReport strReportName, acViewPreview, , "'Email' = 'Email'" &
iif(strFilter <> "", " and ", "") & strFilter
DoCmd.Close acReport, strReportName, False
'Email file has been created, now create the outlook file
' Create the Outlook session and message
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipients to the e-mail message.
If strTo <> vbNullString Then
Set objOutlookRecip = .Recipients.Add(strTo)
objOutlookRecip.Type = olTo
End If
' Set the Subject, the Body, and the Importance of the e-mail
message.
.Subject = strSubject
.Body = "See Attached."
.Importance = olImportanceNormal
'Attach the report to the e-mail message.
Set objOutlookAttach = .Attachments.Add(getEmailFile())
' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
'Display the message
.Display
End With
emailReport = True
emailReport_Exit:
On Error Resume Next
deleteEmailFile
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Exit Function
emailReport_Err:
emailReport = False
Select Case Err.number
Case -2079129595 'Insufficient privilage - Outlook is not open
MsgBox "You must have Outlook open to send this email.",
vbExclamation, "Outlook Is Not Open"
Resume emailReport_Exit
Case 287 'User canceled send
Resume emailReport_Exit
Case Else
logError Err.number, "emailReport", "Report: " &
strReportName & " Filter: " & strFilter
MsgBox "Unhandled error #" & Err.number & vbCrLf &
Err.Description, vbCritical, "ERROR"
Resume emailReport_Exit
End Select
End Function
'This goes in the report module.
'If opening with the view set as email, the filter will
'contain True as expressed by 'Email' = 'Email'. This is an indicator
'that the report must be exported as a snapshot file to the
'getEmailFile() location. The static variable ensures no duplicates
when pages are reformatted.
Private Sub Report_Page()
If Me.Filter Like "*'Email' = 'Email'*" Then
Static PRINTED As Boolean
If PRINTED = False Then
PRINTED = True
DoCmd.OutputTo acOutputReport, , acFormatSNP, getEmailFile(),
False
End If
End If
End Sub
'These last two helper functions are useful, but not required. I
always export email files to the same location.
Public Function getEmailFile() As String
getEmailFile = CurrentProject.Path & "\EmailOutputFile.snp"
End Function
Public Sub deleteEmailFile()
On Error Resume Next
If Dir(getEmailFile()) <> vbNullString Then Kill getEmailFile()
End Sub
Have fun with that one!
-Kris
--