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

jeran042

jeran042

Registered User.
Local time
Today, 06:46
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

Gasman

Enthusiastic Amateur
Local time
Today, 14:46
Joined
Sep 21, 2011
Messages
14,223
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

theDBguy

I’m here to help
Staff member
Local time
Today, 06:46
Joined
Oct 29, 2018
Messages
21,449
Hi. What exactly was your issue? Are you getting an error message?
 
jeran042

jeran042

Registered User.
Local time
Today, 06:46
Joined
Jun 26, 2017
Messages
127
theDBguy said:
Hi. What exactly was your issue? Are you getting an error message?
Click to expand...
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

jeran042

Registered User.
Local time
Today, 06:46
Joined
Jun 26, 2017
Messages
127
Gasman said:
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
Click to expand...
Do I need to redeclare my variables in the next loop?
 
Gasman

Gasman

Enthusiastic Amateur
Local time
Today, 14:46
Joined
Sep 21, 2011
Messages
14,223
jeran042 said:
Do I need to redeclare my variables in the next loop?
Click to expand...
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

theDBguy

I’m here to help
Staff member
Local time
Today, 06:46
Joined
Oct 29, 2018
Messages
21,449
jeran042 said:
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.
Click to expand...
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

jeran042

Registered User.
Local time
Today, 06:46
Joined
Jun 26, 2017
Messages
127
theDBguy said:
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...
Click to expand...
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

theDBguy

I’m here to help
Staff member
Local time
Today, 06:46
Joined
Oct 29, 2018
Messages
21,449
jeran042 said:
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
Click to expand...
Hi. Glad to hear you got it sorted out. Good luck with your project.
 
You must log in or register to reply here.

Similar threads

B
Retrieve 6 numbers from string
Replies
2
Views
198
arnelgp
arnelgp
M
Multiple attachments and a report in the same email
Replies
15
Views
927
Marshall Brooks
M
N
Getting Opening Balance for a Ledger by using Open Record Set NOT Dsum
Replies
18
Views
867
Minty
Minty
G
email
2
Replies
34
Views
1,828
bastanu
bastanu
G
Email Gmail
Replies
1
Views
597
theDBguy
theDBguy

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Top Bottom