Please answer questions when I pose them - so I have a better understanding of what needs to be done.
One more: is the priority supposed to be saved to the table or just passed to the report/email?
Gotta run now...
Please answer questions when I pose them - so I have a better understanding of what needs to be done.
One more: is the priority supposed to be saved to the table or just passed to the report/email?
Gotta run now...
Both.
The PDF report attachment has code looking to the main table to set up a title banner. The email header uses it as all the selected should have the same priority and HR. The email subject uses Priority and HR, The naming convention of the report uses Priority and HR, and the Email Body Text uses Priority in each selected CR.
Saving it in the main table also allows a way to track what was an OOB item throughout the exercise at a later date.
I modified the code to update the fields "Priority" and "Hr" in table "tblChangeRequest".
For the code to work, you MUST change the name of the "Priority" combo box to "cboPrty" and the name of the "Hours" comb box to "cboHrs".
(blue & green lines are the lines I added)
Code:Public Sub SelectedOOBChanges_Click() Dim sSQL As String Dim dCRNO As Double Dim sngSubNo As Single On Error GoTo Broke Set objOutlook = CreateObject("Outlook.Application") Set objOutlookMsg = objOutlook.CreateItem(olMailItem) Set ctl = Me.SelectedOOBNumber ' If ctl.ItemsSelected.Count = 0 Then MsgBox "Nothing was selected" Else For Each varItem In ctl.ItemsSelected StrWhere = StrWhere & "'" & ctl.ItemData(varItem) & "'," StrWhere2 = StrWhere2 & " " & ctl.ItemData(varItem) & "," 'now update tblChangeRequest with Priority and Hr 'have to split SelectedOOBNumber back into CRNO and SubNo 'CRNO dCRNO = Int(ctl.ItemData(varItem)) 'SubNo sngSubNo = (ctl.ItemData(varItem) - Int(ctl.ItemData(varItem))) * 100 ' update sSQL = "UPDATE tblChangeRequest SET tblChangeRequest.Priority = '" & Me.cboPrty & "', tblChangeRequest.Hr = " & Me.cboHrs sSQL = sSQL & " WHERE (((tblChangeRequest.CRNo)=" & dCRNO & ") AND ((tblChangeRequest.SubNo)=" & sngSubNo & "));" ' Debug.Print sSQL CurrentDb.Execute sSQL Next varItem 'remove the last comma StrWhere = Left(StrWhere, Len(StrWhere) - 1) StrWhere2 = Left(StrWhere2, Len(StrWhere2) - 1) Set rs = CurrentDb.OpenRecordset("qRecSourceOOBChanges") If IsNull(Me.OOBNumber) Then '?????? MsgBox "There are no OOB CRs or no CR was selected." TempVars.RemoveAll Call subCreateQuery(1) DoCmd.Close acForm, "frmEmailAORB" DoCmd.OpenForm "frmStart" Else DoCmd.OpenReport "rptOOB", acViewReport, , "OOBNumber IN(" & StrWhere & ")" StrHdrMail = "This is a follow-on action from the AORB/CCB/TEWG discussion on CR(S)" & StrWhere2 & ". If needed, please back-brief your higher for SA, " _ & "and let us know if there are any issues or concerns. The Change Request priority is " & Priority & " with " & Hr & " hours until " _ & "CR(S)" & StrWhere2 & " is automatically approved (GO OOB Excepted). Please provide your votes NLT " & DTG & "." & vbCrLf & vbCrLf If rs.BOF And rs.EOF Then rs.Close Else rs.MoveLast rs.MoveFirst Do While Not rs.EOF For Each varItem In ctl.ItemsSelected If rs!OOBNumber = CDbl(ctl.ItemData(varItem)) Then strBdyMail = strBdyMail & "Date Issue Identified:" & Chr(9) & Chr(9) & rs!Dates & Chr(9) & Chr(9) & "Days Open:" & Chr(9) & rs!DaysOpen & vbCrLf _ & "Priority: " & Chr(9) & Chr(9) & Chr(9) & rs!Priority & vbCrLf _ & "CR Number: " & Chr(9) & Chr(9) & Chr(9) & rs!OOBNumber & vbCrLf & vbCrLf _ & "AO Recommendation: " & Chr(9) & Chr(9) & rs!AOVote & vbCrLf _ & "O6 Recommendation: " & Chr(9) & Chr(9) & rs!O6Vote & vbCrLf & vbCrLf _ & "Change Requested: " & Chr(9) & Chr(9) & rs![ChangeRequested] & vbCrLf & vbCrLf _ & "Unit & Section: " & Chr(9) & rs!Unitss & vbCrLf _ & "MTOE Para & Bumper: " & Chr(9) & Chr(9) & rs![MTOEParass] & vbCrLf & vbCrLf _ & "Rationale: " & rs!Rationale & vbCrLf & vbCrLf _ & "Notes: " & rs!NOTES & vbCrLf _ & "Action Items: " & rs!ActionItems & vbCrLf _ & "__________________________________________________________________________" & vbCrLf & vbCrLf End If Next rs.MoveNext Loop With objOutlookMsg .Subject = NIE & " - " & Label & " " & StrWhere2 & " - " & Tod .Body = StrHdrMail & strBdyMail & SigBlock DoCmd.OutputTo 3, "rptOOB", acFormatPDF, "C:\Temp\" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf", , 0 .Attachments.Add ("C:\Temp\" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf") .To = "" .Display Kill "C:\Temp\" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf" DoCmd.Close acForm, "frmOOBChangeSelect" DoCmd.Close acReport, "rptOOB" DoCmd.OpenForm "frmStart" End With End If 'If rs.BOF And rs.EOF Then End If 'IsNull(Me.OOBNumber) End If 'ctl.ItemsSelected.Count = 0 Broke_Exit: On Error Resume Next Set ctl = Nothing Set objOutlookMsg = Nothing Set objOutlook = Nothing Set objOutlookAttach = Nothing Set rs = Nothing Exit Sub Broke: If Err.Number = "287" Then MsgBox "You selected No to the Outlook security warning. Rerun the procedure and click Yes to access e-mail addresses to send your message." Else MsgBox Err.Number & " " & Err.Description End If Resume Broke_Exit: End Sub
Some notes that you may find repeated as comments in my code version. Format: your code > my comment.
Set rs = CurrentDb.OpenRecordset("qRecSourceOOBChanges") > there is already a useable recordset belonging to the form.
If IsNull(Me.OOBNumber) Then > if there is anything in the listbox at all, this will never be null. If there is nothing in the listbox, the first check on this that I added will cause the procedure to exit.
If rs.BOF And rs.EOF Then > this recordset is the same as the one that the form is predicated on, which is also the same source as the listbox, so there no need to check this condition since if it is true, there was nothing in the listbox to select in the first place.
Do While Not rs.EOF > again, the recordset you create is based on the same as the form recordset, so there is no need to recreate what you already have. If the values are in the listbox, they are also part of the form's recordset. The count of listbox items and the count of form records would not only be the same, any given field would have the same value.
Set objOutlookAttach > this is declared, but never set to anything
It's not a great idea to declare all of your variables at the module level like you have done. If you add another procedure later and out of habit reuse one (e.g. sql as string) you can get wonky results.
I closed the rs before setting to nothing
You MIGHT want to change rs.Fields(#) to the actual name of the field. If you ever re-arrange the query field order in such a way that causes these fields to be out of sync, errors will occur.
****begin code, which seems to work for me****
Code:Public Sub SelectedOOBChanges_Click() Dim sql As String On Error GoTo Broke Set rs = Me.Recordset 'form is based on a query - same one for the listbox and rs you were creating. Let's use that. If rs.RecordCount = 0 Then MsgBox "There are no OOB CRs." TempVars.RemoveAll Call subCreateQuery(1) DoCmd.Close acForm, "frmEmailAORB" DoCmd.OpenForm "frmStart" End If 'not sure if the count is 0 that the previous should happen, then be followed by the rest of the code Set ctl = Me.SelectedOOBNumber 'if the above OK, then create the ctl object If ctl.ItemsSelected.Count = 0 Then MsgBox "Nothing was selected" Exit Sub End If 'if there is at least 1 record and at least 1 listbox item selected, then create more objects Set objOutlook = CreateObject("Outlook.Application") Set objOutlookMsg = objOutlook.CreateItem(olMailItem) rs.MoveFirst 'ensure we're at the first record of form recordset For Each varItem In ctl.ItemsSelected 'by your design, this count and the values are the same in the form and listbox If rs.Fields(0) = CDbl(ctl.ItemData(varItem)) Then sql = "UPDATE tblChangeRequest SET tblChangeRequest.Priority = '" & Me.Prty & "' WHERE [CRID] = " & rs.Fields(2) CurrentDb.Execute sql, dbFailOnError strBdyMail = strBdyMail & "Date Issue Identified:" & Chr(9) & Chr(9) & rs!Dates & Chr(9) & Chr(9) & "Days Open:" & Chr(9) & rs!DaysOpen & vbCrLf _ & "Priority: " & Chr(9) & Chr(9) & Chr(9) & rs!Priority & vbCrLf _ & "CR Number: " & Chr(9) & Chr(9) & Chr(9) & rs!OOBNumber & vbCrLf & vbCrLf _ & "AO Recommendation: " & Chr(9) & Chr(9) & rs!AOVote & vbCrLf _ & "O6 Recommendation: " & Chr(9) & Chr(9) & rs!O6Vote & vbCrLf & vbCrLf _ & "Change Requested: " & Chr(9) & Chr(9) & rs![ChangeRequested] & vbCrLf & vbCrLf _ & "Unit & Section: " & Chr(9) & rs!Unitss & vbCrLf _ & "MTOE Para & Bumper: " & Chr(9) & Chr(9) & rs![MTOEParass] & vbCrLf & vbCrLf _ & "Rationale: " & rs!Rationale & vbCrLf & vbCrLf _ & "Notes: " & rs!NOTES & vbCrLf _ & "Action Items: " & rs!ActionItems & vbCrLf _ & "__________________________________________________________________________" & vbCrLf & vbCrLf StrWhere = StrWhere & "'" & ctl.ItemData(varItem) & "'," StrWhere2 = StrWhere2 & " " & ctl.ItemData(varItem) & "," End If rs.MoveNext Next varItem StrWhere = Left(StrWhere, Len(StrWhere) - 1) StrWhere2 = Left(StrWhere2, Len(StrWhere2) - 1) 'why open this report if no one gets a chance to look at it? DoCmd.OpenReport "rptOOB", acViewReport, , "OOBNumber IN(" & StrWhere & ")" StrHdrMail = "This is a follow-on action from the AORB/CCB/TEWG discussion on CR(S)" & StrWhere2 & ". If needed, please back-brief your higher for SA, " _ & "and let us know if there are any issues or concerns. The Change Request priority is " & Priority & " with " & Hr & " hours until " _ & "CR(S)" & StrWhere2 & " is automatically approved (GO OOB Excepted). Please provide your votes NLT " & DTG & "." & vbCrLf & vbCrLf With objOutlookMsg .Subject = NIE & " - " & Label & " " & StrWhere2 & " - " & Tod .Body = StrHdrMail & strBdyMail & SigBlock DoCmd.OutputTo 3, "rptOOB", acFormatPDF, "C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf", , 0 .Attachments.Add ("C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf") .To = "" .Display Kill "C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf" DoCmd.Close acForm, "frmOOBChangeSelect" DoCmd.Close acReport, "rptOOB" DoCmd.OpenForm "frmStart" End With Broke_Exit: On Error Resume Next Set ctl = Nothing Set objOutlookMsg = Nothing Set objOutlook = Nothing Set objOutlookAttach = Nothing 'this is never set, so why set to nothing? rs.Close Set rs = Nothing Exit Sub
The more we hear silence, the more we begin to think about our value in this universe.
Paraphrase of Professor Brian Cox.
Micron I run the following and it fails on DoCmd.OutputTo 3, "rptOOB", acFormatPDF, "C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf", , 0
Runtime Error code 2501. No records? if I put ' before it and the .attach, then the Email text and subject are fine.
Code:Public Sub SelectedOOBChanges_Click() Dim sql As String 'On Error GoTo Broke Set rs = Me.Recordset If rs.RecordCount = 0 Then MsgBox "There are no OOB CRs." TempVars.RemoveAll Call subCreateQuery(1) DoCmd.Close acForm, "frmEmailAORB" DoCmd.OpenForm "frmStart" End If Set ctl = Me.SelectedOOBNumber If ctl.ItemsSelected.Count = 0 Then MsgBox "Nothing was selected" Exit Sub End If Set objOutlook = CreateObject("Outlook.Application") Set objOutlookMsg = objOutlook.CreateItem(olMailItem) rs.MoveFirst For Each varItem In ctl.ItemsSelected If rs.Fields(0) = CDbl(ctl.ItemData(varItem)) Then sql = "UPDATE tblChangeRequest SET tblChangeRequest.Priority = '" & Me.cboPrty & "' WHERE [CRID] = " & rs.Fields(2) CurrentDb.Execute sql, dbFailOnError strBdyMail = strBdyMail & "Date Issue Identified:" & Chr(9) & Chr(9) & rs!Dates & Chr(9) & Chr(9) & "Days Open:" & Chr(9) & rs!DaysOpen & vbCrLf _ & "Priority: " & Chr(9) & Chr(9) & Chr(9) & rs!Priority & vbCrLf _ & "CR Number: " & Chr(9) & Chr(9) & Chr(9) & rs!OOBNumber & vbCrLf & vbCrLf _ & "AO Recommendation: " & Chr(9) & Chr(9) & rs!AOVote & vbCrLf _ & "O6 Recommendation: " & Chr(9) & Chr(9) & rs!O6Vote & vbCrLf & vbCrLf _ & "Change Requested: " & Chr(9) & Chr(9) & rs![ChangeRequested] & vbCrLf & vbCrLf _ & "Unit & Section: " & Chr(9) & rs!Unitss & vbCrLf _ & "MTOE Para & Bumper: " & Chr(9) & Chr(9) & rs![MTOEParass] & vbCrLf & vbCrLf _ & "Rationale: " & rs!Rationale & vbCrLf & vbCrLf _ & "Notes: " & rs!NOTES & vbCrLf _ & "Action Items: " & rs!ActionItems & vbCrLf _ & "__________________________________________________________________________" & vbCrLf & vbCrLf StrWhere = StrWhere & "'" & ctl.ItemData(varItem) & "'," StrWhere2 = StrWhere2 & " " & ctl.ItemData(varItem) & "," End If rs.MoveNext Next varItem StrWhere = Left(StrWhere, Len(StrWhere) - 1) StrWhere2 = Left(StrWhere2, Len(StrWhere2) - 1) StrHdrMail = "This is a follow-on action from the AORB/CCB/TEWG discussion on CR(S)" & StrWhere2 & ". If needed, please back-brief your higher for SA, " _ & "and let us know if there are any issues or concerns. The Change Request priority is " & Priority & " with " & Hr & " hours until " _ & "CR(S)" & StrWhere2 & " is automatically approved (GO OOB Excepted). Please provide your votes NLT " & DTG & "." & vbCrLf & vbCrLf With objOutlookMsg .Subject = NIE & " - " & Label & " " & StrWhere2 & " - " & Tod .Body = StrHdrMail & strBdyMail & SigBlock DoCmd.OutputTo 3, "rptOOB", acFormatPDF, "C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf", , 0 .Attachments.Add ("C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf") .To = "" .Display Kill "C:\Temp" & NIE & " - " & Label & " " & StrWhere2 & " - " & Tod & ".pdf" DoCmd.Close acForm, "frmOOBChangeSelect" DoCmd.Close acReport, "rptOOB" DoCmd.OpenForm "frmStart" End With Broke_Exit: On Error Resume Next Set ctl = Nothing Set objOutlookMsg = Nothing Set objOutlook = Nothing Set rs = Nothing Exit Sub Broke: If Err.Number = "287" Then MsgBox "You selected No to the Outlook security warning. Rerun the procedure and click Yes to access e-mail addresses to send your message." Else MsgBox Err.Number & " " & Err.Description End If Resume Broke_Exit: Exit Sub End Sub
The message means the open report action was cancelled. Not sure if I placed that line there in error with all the code pieces I moved around, or if you had it there. I suspect the former. The With block is one that you can do a bunch of stuff with on an object, and generally I don't include any code that doesn't relate to that object, so I'd say to open a report within a With block for an Outlook message is verboten. Try moving that line just before the With block code for the Outlook message.
I couldn't test it fully since I didn't have a similar path where you're creating a pdf.