Solved Iterate through a record-set Twice (1 Viewer)

jeran042

Registered User.
Local time
Today, 04:25
Joined
Jun 26, 2017
Messages
127
I am trying to iterate over the same recordset twice to generate 2 separate emails.
The first will attach a password protected email, and the second will be the password for said email.


The first loop works exactly as desired, its restarting the loop through the recordset that I am having an issue with. I did a search online and was able to find something, but I am not able to get it to work with my module. (as you will see below, I am a novice at best)

Here is what I have:
Code:
Private Sub Command143_Click()


''Confirm that user want to take this action
If MsgBox("This action will email ALL active department monthly reports, " & vbNewLine & _
                   "Do you want to continue? ", vbCritical + vbYesNo, " WARNING ") = vbYes Then
                      
'Error handling
    'On Error GoTo Error_Handler
    
'Turn off warnings
    DoCmd.SetWarnings False
    
    
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim iCost As Long
    Dim sDepartment As String
    Dim myFilePath As String
    Dim sMonthlyFileName As String
    Dim sEmail As String
    Dim sEmailCC As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim objOutlook As Object
    Dim objMailItem As Object
    
    strSQL = "SELECT * FROM qryADP_Distribution"
    Set rs = CurrentDb.OpenRecordset(strSQL)
    
    Const olMailItem As Integer = 0
    Set objOutlook = CreateObject("Outlook.Application")
        
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
        
        'Set Loop Variables
    sDepartment = rs.Fields("DEPARTMENT")
    myFilePath = "Y:\Budget process information\2020 Financial Activities\2021 Plan\Salary\zDistribution Salary Template\"
    sMonthlyFileName = myFilePath & rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
    sEmail = rs.Fields("ADP_EMAIL")
    sEmailCC = Nz(rs.Fields("ADP_EMAIL_CC"))
    iCost = Left(rs.Fields("DEPARTMENT"), InStr(rs.Fields("DEPARTMENT"), " ") - 1)
    
'############################################################################
' Test Variables - Uncomment to see variables
'        Debug.Print sDepartment
'        Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
'        Debug.Print sMonthlyFileName
'        Debug.Print iCost
'        Debug.Print sEmail
'        Debug.Print sEmailCC
'        Debug.Print vbCr & vbCr
'############################################################################
    
        
'Email Generation
'This email will be the initial correspondence
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Due no later than October 28th"
            .Body = "COPY EMAIL HERE!!"
            .ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
'           '.send
            .display
        End With
            Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
            rs.MoveNext
            
        Wend
    End If
    
    

'################################################################
' THIS IS THE PART I NEED ASSISTANCE WITH'
' Restart the loop
rs.MoveFirst
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)

'Email Generation
'This email will be the password email correspondence

        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Due no later than October 28th"
            .Body = Trim(iCost) & "*abcd"
            '.ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
'           '.send
            .display
        End With
            rs.MoveNext
        Wend
        
    End If
    rs.Close
    Set rs = Nothing


'################################################################
'
'Confirmation
     MsgBox "Success!  That's some good work, " & vbNewLine _
                & "Your emails have been sent to the corresponding departments! ", vbInformation, "GREAT JOB"

    
Else
    MsgBox " Check you Later!", vbInformation, "WHY YOU NO SAY YES?"
End If


Error_Handler_Exit:
    Exit Sub

Error_Handler:
    Select Case Err.NUMBER
        Case 94
            Err.Clear
            MsgBox "No file matching " & sMonthlyFileName & " found." & vbCrLf & _
                "Processing terminated."
            Resume Error_Handler_Exit
        Case Else
            MsgBox "Error No. " & Err.NUMBER & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
            Err.Clear
            Resume Error_Handler_Exit
    End Select

End Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 12:25
Joined
Sep 21, 2011
Messages
7,118
You should probably have copied the first loop and amended to suit.?

You need
Code:
 Set MailOutLook = appOutLook.CreateItem(olMailItem)
within the loop to create a new email each time.?
No need for the second test of BOF & EOF if the first loop worked?, just Movefirst

HTH
 

theDBguy

I’m here to help
Staff member
Local time
Today, 04:25
Joined
Oct 29, 2018
Messages
13,187
Hi. What exactly was your issue? Are you getting an error message?
 

jeran042

Registered User.
Local time
Today, 04:25
Joined
Jun 26, 2017
Messages
127
Hi. What exactly was your issue? Are you getting an error message?
No error message,
The code runs and generates the email and attaches the corresponding file, however it does not restart the list to generate the second password email.

It will generate 1 password email because (I think) that is the next block of code and then finishes running.
 

jeran042

Registered User.
Local time
Today, 04:25
Joined
Jun 26, 2017
Messages
127
You should probably have copied the first loop and amended to suit.?

You need
Code:
Set MailOutLook = appOutLook.CreateItem(olMailItem)
within the loop to create a new email each time.?
No need for the second test of BOF & EOF if the first loop worked?, just Movefirst

HTH
Do I need to redeclare my variables in the next loop?
 

Gasman

Enthusiastic Amateur
Local time
Today, 12:25
Joined
Sep 21, 2011
Messages
7,118
Do I need to redeclare my variables in the next loop?
No, you declare them once, but if you want another email you have to create it, just as you did in the first loop?
If you follow the code in the debug window, it will process the recordset a second time, but as you are not creating an email at that time, nothing else much happens.

Also you only need to create the Outlook App once, not within the loop.
I also set the object to Nothing at the end as well?
 

theDBguy

I’m here to help
Staff member
Local time
Today, 04:25
Joined
Oct 29, 2018
Messages
13,187
No error message,
The code runs and generates the email and attaches the corresponding file, however it does not restart the list to generate the second password email.

It will generate 1 password email because (I think) that is the next block of code and then finishes running.
Hi. Thanks for the clarification. Have you tried stepping through the code? Also, do you know if you could generate two emails (the first one and the second one) within the same loop, so you don't have to loop twice? Just curious...
 

jeran042

Registered User.
Local time
Today, 04:25
Joined
Jun 26, 2017
Messages
127
Hi. Thanks for the clarification. Have you tried stepping through the code? Also, do you know if you could generate two emails (the first one and the second one) within the same loop, so you don't have to loop twice? Just curious...
GREAT IDEA! THANK YOU!
Good thought, why iterate over the list again in the first place??
Here is what I ended up with. I would love any feedback on improving.


Code:
Private Sub Command142_Click()


''Confirm that user want to take this action
If MsgBox("This action will email ALL active department monthly reports, " & vbNewLine & _
                   "Do you want to continue? ", vbCritical + vbYesNo, " WARNING ") = vbYes Then
                      
'Error handling
    On Error GoTo Error_Handler
    
'Turn off warnings
    DoCmd.SetWarnings False
    
    
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim iCost As Long
    Dim sDepartment As String
    Dim myFilePath As String
    Dim sMonthlyFileName As String
    Dim sEmail As String
    Dim sEmailCC As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim objOutlook As Object
    Dim objMailItem As Object
    
    strSQL = "SELECT * FROM qryADP_Distribution"
    Set rs = CurrentDb.OpenRecordset(strSQL)
    
    Const olMailItem As Integer = 0
    Set objOutlook = CreateObject("Outlook.Application")
        
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
        
'Set Loop Variables
    sDepartment = rs.Fields("DEPARTMENT")
    myFilePath = "Y:\Budget process information\2020 Financial Activities\2021 Plan\Salary\zDistribution Salary Template\"
    sMonthlyFileName = myFilePath & rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
    sEmail = rs.Fields("ADP_EMAIL")
    sEmailCC = Nz(rs.Fields("ADP_EMAIL_CC"))
    iCost = Left(rs.Fields("DEPARTMENT"), InStr(rs.Fields("DEPARTMENT"), " ") - 1)
    
'############################################################################
' Test Variables - Uncomment to see variables
'        Debug.Print sDepartment
'        Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
'        Debug.Print sMonthlyFileName
'        Debug.Print iCost
'        Debug.Print sEmail
'        Debug.Print sEmailCC
'        Debug.Print vbCr & vbCr
'############################################################################
    
        
'Email Generation
'This email will be the initial correspondence
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Due no later than October 28th"
            .Body = "COPY EMAIL HERE!!"
            .ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
            '.send
            .display
        
        End With
        


'Email Generation
'This email will be the password email correspondence

        Set MailOutLook = appOutLook.CreateItem(olMailItem)
        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Password"
            .Body = Trim(iCost) & "*knights"
            '.ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
'           '.send
            .display
        End With
            Debug.Print Trim(iCost) & "*knights"
            Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
            rs.MoveNext
            
        Wend
    End If
    
        
    rs.Close
    Set rs = Nothing
    
'Confirmation
     MsgBox "Success!  That's some good work, " & vbNewLine _
                & "Your emails have been sent to the corresponding departments! ", vbInformation, "GREAT JOB"

    
Else
    MsgBox " Check you Later!", vbInformation, "WHY YOU NO SAY YES?"
End If

'Turn on warnings
    DoCmd.SetWarnings True

Error_Handler_Exit:
    Exit Sub

Error_Handler:
    Select Case Err.NUMBER
        Case 94
            Err.Clear
            MsgBox "No file matching " & sMonthlyFileName & " found." & vbCrLf & _
                "Processing terminated."
            Resume Error_Handler_Exit
        Case Else
            MsgBox "Error No. " & Err.NUMBER & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
            Err.Clear
            Resume Error_Handler_Exit
    End Select

End Sub
 

theDBguy

I’m here to help
Staff member
Local time
Today, 04:25
Joined
Oct 29, 2018
Messages
13,187
GREAT IDEA! THANK YOU!
Good thought, why iterate over the list again in the first place??
Here is what I ended up with. I would love any feedback on improving.


Code:
Private Sub Command142_Click()


''Confirm that user want to take this action
If MsgBox("This action will email ALL active department monthly reports, " & vbNewLine & _
                   "Do you want to continue? ", vbCritical + vbYesNo, " WARNING ") = vbYes Then
                     
'Error handling
    On Error GoTo Error_Handler
   
'Turn off warnings
    DoCmd.SetWarnings False
   
   
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim iCost As Long
    Dim sDepartment As String
    Dim myFilePath As String
    Dim sMonthlyFileName As String
    Dim sEmail As String
    Dim sEmailCC As String
    Dim appOutLook As Object
    Dim MailOutLook As Object
    Dim objOutlook As Object
    Dim objMailItem As Object
   
    strSQL = "SELECT * FROM qryADP_Distribution"
    Set rs = CurrentDb.OpenRecordset(strSQL)
   
    Const olMailItem As Integer = 0
    Set objOutlook = CreateObject("Outlook.Application")
       
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
       
'Set Loop Variables
    sDepartment = rs.Fields("DEPARTMENT")
    myFilePath = "Y:\Budget process information\2020 Financial Activities\2021 Plan\Salary\zDistribution Salary Template\"
    sMonthlyFileName = myFilePath & rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
    sEmail = rs.Fields("ADP_EMAIL")
    sEmailCC = Nz(rs.Fields("ADP_EMAIL_CC"))
    iCost = Left(rs.Fields("DEPARTMENT"), InStr(rs.Fields("DEPARTMENT"), " ") - 1)
   
'############################################################################
' Test Variables - Uncomment to see variables
'        Debug.Print sDepartment
'        Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
'        Debug.Print sMonthlyFileName
'        Debug.Print iCost
'        Debug.Print sEmail
'        Debug.Print sEmailCC
'        Debug.Print vbCr & vbCr
'############################################################################
   
       
'Email Generation
'This email will be the initial correspondence
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Due no later than October 28th"
            .Body = "COPY EMAIL HERE!!"
            .ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
            '.send
            .display
       
        End With
       


'Email Generation
'This email will be the password email correspondence

        Set MailOutLook = appOutLook.CreateItem(olMailItem)
        With MailOutLook
            .To = sEmail
            .cc = sEmailCC
            .bcc = "joseph.rinaldi@kofc.org"
            .SUBJECT = "2021 Salary Template - Password"
            .Body = Trim(iCost) & "*knights"
            '.ATTACHMENTS.Add (sMonthlyFileName)
            '.ATTACHMENTS.Add (sDetailFileName)
'           '.send
            .display
        End With
            Debug.Print Trim(iCost) & "*knights"
            Debug.Print rs.Fields("DEPARTMENT") & "_2021_Salary_Plan.xlsx"
            rs.MoveNext
           
        Wend
    End If
   
       
    rs.Close
    Set rs = Nothing
   
'Confirmation
     MsgBox "Success!  That's some good work, " & vbNewLine _
                & "Your emails have been sent to the corresponding departments! ", vbInformation, "GREAT JOB"

   
Else
    MsgBox " Check you Later!", vbInformation, "WHY YOU NO SAY YES?"
End If

'Turn on warnings
    DoCmd.SetWarnings True

Error_Handler_Exit:
    Exit Sub

Error_Handler:
    Select Case Err.NUMBER
        Case 94
            Err.Clear
            MsgBox "No file matching " & sMonthlyFileName & " found." & vbCrLf & _
                "Processing terminated."
            Resume Error_Handler_Exit
        Case Else
            MsgBox "Error No. " & Err.NUMBER & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
            Err.Clear
            Resume Error_Handler_Exit
    End Select

End Sub
Hi. Glad to hear you got it sorted out. Good luck with your project.
 

Users who are viewing this thread

Top Bottom