Count iterations performed in SQL recordset loop (1 Viewer)

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Hi,

I run the following code which loops through a recordset and performs a file copy based on a value in each record of the recordset. Given the value is a URL file link address its quite likely that the target file could get moved, deleted or changed which then creates an error, the code breaks and gives the user a warning.

In order to identify the source of the error quicker it would be useful to know how many iterations were successfully performed up until the break and include this info in the error MsgBox. Does anyone know how you can count the iterations and display the value in a MsgBox?

Thanks

Code:
Private Sub cmdCreateDatasheetsFolder_Click()

On Error GoTo ErrorHandler

Dim strSQL As String
Dim fsObject As Object
Dim rs As DAO.Recordset
Dim Cancel As Integer
Dim intStyle As String
Dim strTitle As String
Dim strMsg As String
Dim FoldernameDestROOT As String
Dim FoldernameDestFIRE As String
Dim FoldernameDestINTRUDER As String
Dim FoldernameDestACCESS As String
Dim FoldernameDestCCTV As String
Dim FoldernameDestOTHER As String
Dim createpath As String
Dim x, I As Integer

'Set folderpath for destinations of datasheet files
FoldernameDestROOT = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\"
FoldernameDestFIRE = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\DATASHEETS\FIRE\"
FoldernameDestINTRUDER = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\DATASHEETS\INTRUDER\"
FoldernameDestACCESS = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\DATASHEETS\ACCESS\"
FoldernameDestCCTV = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\DATASHEETS\CCTV\"
FoldernameDestOTHER = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\DATASHEETS\OTHER\"

strSQL = " SELECT [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)) AS Filename, Quotations.OrderNumber, Quotations.Discipline " & _
" FROM ([Quote Details] LEFT JOIN Products ON [Quote Details].ProductID = Products.ProductID) LEFT JOIN Quotations ON [Quote Details].QuoteID = Quotations.QuoteID " & _
" GROUP BY [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)), Quotations.OrderNumber, Quotations.Discipline " & _
" HAVING (((Quotations.OrderNumber)='" & Me.txtOrderNumber & "')) " & _
" ORDER BY (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100));"

    'Set the recordset and then loop through each product in returned recordset and copy each file at a time
    Set rs = CurrentDb.OpenRecordset(strSQL)
    Set fsObject = CreateObject("Scripting.FileSystemObject")

    With rs
    
        If Not .BOF And Not .EOF Then
        
            .MoveLast
            .MoveFirst
        
            While (Not .EOF)
            
            'rs.Edit
            'rs!DatasheetPath = "2"
            'rs.Update
            
            If IsNull(rs!DatasheetPath) Or rs!DatasheetPath = "" Then
            .MoveNext
            ElseIf rs!Discipline = 1 Then 'FIRE
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestFIRE
            .MoveNext
            ElseIf rs!Discipline = 2 Then 'EVC
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestFIRE
            .MoveNext
            ElseIf rs!Discipline = 3 Then 'SUPPRESSION
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestFIRE
            .MoveNext
            ElseIf rs!Discipline = 4 Then 'EXTINGUISHERS
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            ElseIf rs!Discipline = 5 Then 'E LIGHTS
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            ElseIf rs!Discipline = 6 Then 'N CALL
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            ElseIf rs!Discipline = 7 Then 'FRA
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            ElseIf rs!Discipline = 8 Then 'INTRUDER
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestINTRUDER
            .MoveNext
            ElseIf rs!Discipline = 9 Then 'ACCESS
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestACCESS
            .MoveNext
            ElseIf rs!Discipline = 10 Then 'CCTV
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestCCTV
            .MoveNext
            ElseIf rs!Discipline = 11 Then 'MONITORING
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            ElseIf rs!Discipline = 12 Then 'REMEDIALS
            fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
            .MoveNext
            End If

            Wend
      
            Else
            .Close
            MsgBox ("There are no quotes or products linked to this job")
            GoTo ExitSub
      
        End If
    
    .Close

    End With
    
    Set fsObject = Nothing
    Set rs = Nothing
    
    Shell "C:\WINDOWS\explorer.exe """ & FoldernameDestFIRE & "", vbNormalFocus
    MsgBox ("All datasheets copied to projects folder")

GoTo ExitSub

ExitSub:
    Set rs = Nothing
    Set fsObject = Nothing
    
    Exit Sub

ErrorHandler:
MsgBox "An ERROR has occured, it could be a product with incorrect datasheet link. The copy in alpabetical order, check to see which product was the last" _
& "succesfully copied and then check the datasheet link in the next item in the product test list"
Resume ExitSub

End Sub
 

theDBguy

I’m here to help
Staff member
Local time
Today, 13:04
Joined
Oct 29, 2018
Messages
21,358
Hi. You could declare a variable and increment at the beginning of the loop. For example,

Dim lngCounter As Long

While Not .EOF

lngCounter = lngCounter + 1
 

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Hi. You could declare a variable and increment at the beginning of the loop. For example,

Dim lngCounter As Long

While Not .EOF

lngCounter = lngCounter + 1
Thanks for this appreciated. Do I insert this in between my existing While statement or do I need to create another separate one?
Also how do I add this to a msg box?
 

Gasman

Enthusiastic Amateur
Local time
Today, 20:04
Joined
Sep 21, 2011
Messages
14,047
Personally I would not like having to count perhaps 56 files just to get to the one that has an incorrect link.? Why not display the errant link in your MsgBox?
Perhaps even store the last successful copy and show that even.?

Also you can't just count within the loop as you are processing NULL and empty file path records? Why not ignore them in the SQL in the first place.?
 

theDBguy

I’m here to help
Staff member
Local time
Today, 13:04
Joined
Oct 29, 2018
Messages
21,358
Thanks for this appreciated. Do I insert this in between my existing While statement or do I need to create another separate one?
Also how do I add this to a msg box?
Hi. I agree with @Gasman; but to answer your question, the While Not .EOF in my post was the same line in your code. I was trying to show you to declare a variable before your loop and then count the iteration at the beginning of the loop. As for adding it to the MsgBox, you can concatenate it with your message. For example:

MsgBox "Your message here " & lngCounter

Hope that helps...
 

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Personally I would not like having to count perhaps 56 files just to get to the one that has an incorrect link.? Why not display the errant link in your MsgBox?
Perhaps even store the last successful copy and show that even.?

Also you can't just count within the loop as you are processing NULL and empty file path records? Why not ignore them in the SQL in the first place.?

Yer fair point you are right on that. Ignoring the Null values seems sensible and straight forward enough in the SQL which I can do.

I’m fairly new to VBA bad learning fast so not heard of Errant link before but sounds interesting and like the idea of displaying the last successful file copy too.

Are you able to offer and code/examples and assistance in how I would be able to build this into my code?

Thanks for your advice, appreciated.
 

Gasman

Enthusiastic Amateur
Local time
Today, 20:04
Joined
Sep 21, 2011
Messages
14,047
Try something along these lines. I've also tried to simplify your code for easier maintenance.
However if the Case Else block of code runs it will report on the discipline whilst that filepath might also not exist.? If that could happen and is important, then you would probably have to set it in all the case statements except the else. :(

Should get you some way there anyway?

HTH
Code:
Private Sub cmdCreateDatasheetsFolder_Click()

On Error GoTo ErrorHandler

Dim strSQL As String
Dim fsObject As Object
Dim rs As DAO.Recordset
Dim Cancel As Integer
Dim intStyle As String
Dim strTitle As String
Dim strMsg As String
Dim FoldernameDestROOT As String
Dim FoldernameDestFIRE As String
Dim FoldernameDestINTRUDER As String
Dim FoldernameDestACCESS As String
Dim FoldernameDestCCTV As String
Dim FoldernameDestOTHER As String
Dim createpath As String
Dim x As Integer, I As Integer

Dim strLastFile As String, lngCounter as Long

'Set folderpath for destinations of datasheet files
FoldernameDestROOT = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\"
FoldernameDestFIRE = FoldernameDestROOT & "DATASHEETS\FIRE\"
FoldernameDestINTRUDER = FoldernameDestROOT & "DATASHEETS\INTRUDER\"
FoldernameDestACCESS = FoldernameDestROOT & "DATASHEETS\ACCESS\"
FoldernameDestCCTV = FoldernameDestROOT & "DATASHEETS\CCTV\"
FoldernameDestOTHER = FoldernameDestROOT & "DATASHEETS\OTHER\"

strSQL = " SELECT [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)) AS Filename, Quotations.OrderNumber, Quotations.Discipline " & _
" FROM ([Quote Details] LEFT JOIN Products ON [Quote Details].ProductID = Products.ProductID) LEFT JOIN Quotations ON [Quote Details].QuoteID = Quotations.QuoteID " & _
" GROUP BY [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)), Quotations.OrderNumber, Quotations.Discipline " & _
" HAVING (((Quotations.OrderNumber)='" & Me.txtOrderNumber & "')) " & _
" ORDER BY (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100));"

    'Set the recordset and then loop through each product in returned recordset and copy each file at a time
    Set rs = CurrentDb.OpenRecordset(strSQL)
    Set fsObject = CreateObject("Scripting.FileSystemObject")

    With rs
        If Not .BOF And Not .EOF Then
            .MoveFirst
            While (Not .EOF)
                Select Case rs!Discipline
                Case 1, 2, 3
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestFIRE
                Case 4, 5, 6, 7, 11, 12
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
                Case 8
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestINTRUDER
                Case 9
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestACCESS
                Case 10
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestCCTV
                Case Else
                    MsgBox "Discipline " & rs!Discipline & " for " & rs!DatasheetPath & " not catered for"
                End Select
                strLastFile = rs!DatasheetPath
                lngCounter = lngCounter + 1
                .MoveNext
            Wend
        Else
            .Close
            MsgBox ("There are no quotes or products linked to this job")
            GoTo ExitSub
        End If
    
        .Close

    End With
    
    Set fsObject = Nothing
    Set rs = Nothing
    
    Shell "C:\WINDOWS\explorer.exe """ & FoldernameDestFIRE & "", vbNormalFocus
    MsgBox ("All datasheets copied to projects folder")

GoTo ExitSub

ExitSub:
    Set rs = Nothing
    Set fsObject = Nothing
    
    Exit Sub

ErrorHandler:
MsgBox "An ERROR has occured, it could be a product with incorrect datasheet link. The copy is in alpabetical order, the last product " _
& "succesfully copied was " & strLastFile & " and the errant link is " & rs!DatasheetPath & " with " & lngCounter & " successful copies made."
Resume ExitSub


End Sub
 

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Wow, thanks so much for that. So interesting to see how you’ve managed to simplify the code, will be very helpful for other areas in my DB. Will try your input early eve tonight and feedback on results, thanks again.
 

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Try something along these lines. I've also tried to simplify your code for easier maintenance.
However if the Case Else block of code runs it will report on the discipline whilst that filepath might also not exist.? If that could happen and is important, then you would probably have to set it in all the case statements except the else. :(

Should get you some way there anyway?

HTH
Code:
Private Sub cmdCreateDatasheetsFolder_Click()

On Error GoTo ErrorHandler

Dim strSQL As String
Dim fsObject As Object
Dim rs As DAO.Recordset
Dim Cancel As Integer
Dim intStyle As String
Dim strTitle As String
Dim strMsg As String
Dim FoldernameDestROOT As String
Dim FoldernameDestFIRE As String
Dim FoldernameDestINTRUDER As String
Dim FoldernameDestACCESS As String
Dim FoldernameDestCCTV As String
Dim FoldernameDestOTHER As String
Dim createpath As String
Dim x As Integer, I As Integer

Dim strLastFile As String, lngCounter as Long

'Set folderpath for destinations of datasheet files
FoldernameDestROOT = "F:\SFA 20" & Right(Me.OrderDate, 2) & "\Running projects" & "\" & Me.CustomerID.Column(1) & "\J" & Me.OrderID & " " & Me.SiteName.Column(1) & "\OM MANUAL\"
FoldernameDestFIRE = FoldernameDestROOT & "DATASHEETS\FIRE\"
FoldernameDestINTRUDER = FoldernameDestROOT & "DATASHEETS\INTRUDER\"
FoldernameDestACCESS = FoldernameDestROOT & "DATASHEETS\ACCESS\"
FoldernameDestCCTV = FoldernameDestROOT & "DATASHEETS\CCTV\"
FoldernameDestOTHER = FoldernameDestROOT & "DATASHEETS\OTHER\"

strSQL = " SELECT [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)) AS Filename, Quotations.OrderNumber, Quotations.Discipline " & _
" FROM ([Quote Details] LEFT JOIN Products ON [Quote Details].ProductID = Products.ProductID) LEFT JOIN Quotations ON [Quote Details].QuoteID = Quotations.QuoteID " & _
" GROUP BY [Quote Details].QuoteID, [Quote Details].ProductID, Products.ProductName, Products.DatasheetPath, (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100)), Quotations.OrderNumber, Quotations.Discipline " & _
" HAVING (((Quotations.OrderNumber)='" & Me.txtOrderNumber & "')) " & _
" ORDER BY (Mid(Nz(Products.DatasheetPath,""""),(InStrRev(Nz(Products.DatasheetPath,""""),""\"")+1),100));"

    'Set the recordset and then loop through each product in returned recordset and copy each file at a time
    Set rs = CurrentDb.OpenRecordset(strSQL)
    Set fsObject = CreateObject("Scripting.FileSystemObject")

    With rs
        If Not .BOF And Not .EOF Then
            .MoveFirst
            While (Not .EOF)
                Select Case rs!Discipline
                Case 1, 2, 3
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestFIRE
                Case 4, 5, 6, 7, 11, 12
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestOTHER
                Case 8
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestINTRUDER
                Case 9
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestACCESS
                Case 10
                    fsObject.CopyFile rs!DatasheetPath, FoldernameDestCCTV
                Case Else
                    MsgBox "Discipline " & rs!Discipline & " for " & rs!DatasheetPath & " not catered for"
                End Select
                strLastFile = rs!DatasheetPath
                lngCounter = lngCounter + 1
                .MoveNext
            Wend
        Else
            .Close
            MsgBox ("There are no quotes or products linked to this job")
            GoTo ExitSub
        End If
   
        .Close

    End With
   
    Set fsObject = Nothing
    Set rs = Nothing
   
    Shell "C:\WINDOWS\explorer.exe """ & FoldernameDestFIRE & "", vbNormalFocus
    MsgBox ("All datasheets copied to projects folder")

GoTo ExitSub

ExitSub:
    Set rs = Nothing
    Set fsObject = Nothing
   
    Exit Sub

ErrorHandler:
MsgBox "An ERROR has occured, it could be a product with incorrect datasheet link. The copy is in alpabetical order, the last product " _
& "succesfully copied was " & strLastFile & " and the errant link is " & rs!DatasheetPath & " with " & lngCounter & " successful copies made."
Resume ExitSub


End Sub

Evening, thanks so so much for your help on this, your code worked first time faultlessly. It would have taken me hours of fiddling to achieve that and its so much more informative and user friendly than I would have been able to make it.

I have added a couple of bits using your examples including reporting the name and part code of the product where the error occurred and also reporting the total number of successful files copied when there are no errors.

So appreciated, thank you.

It was also really interesting to take a look at your code improvements which I will definitely take on board. One bit of code elsewhere that I feel is messy but couldn't think of another way to write is the following:

Code:
If FolderExists(FoldernameDestFIRE) = False Then
Call MakeDirectory(FoldernameDestFIRE)
End If
If FolderExists(FoldernameDestINTRUDER) = False Then
Call MakeDirectory(FoldernameDestINTRUDER)
End If
If FolderExists(FoldernameDestACCESS) = False Then
Call MakeDirectory(FoldernameDestACCESS)
End If
If FolderExists(FoldernameDestCCTV) = False Then
Call MakeDirectory(FoldernameDestCCTV)
End If
If FolderExists(FoldernameDestOTHER) = False Then
Call MakeDirectory(FoldernameDestOTHER)
End If

Is there any better way to do stuff like this as far as you can see?

Thanks again.
 

Gasman

Enthusiastic Amateur
Local time
Today, 20:04
Joined
Sep 21, 2011
Messages
14,047
Only if you put then in an array for that code?

The FolderExists function could have a second parameter to indicate if it does not exist create it.?
Then I might change it to a sub as it should always return True?

You could call the MakeDirectory from the FolderExists function ?

HTH

Edit: Re the Else part of the code, I thought of raising an error there, as that would skip the strLastFile assignment and should then show the correct filename.
Also if you put back .MoveLast, you could obtain the .RecordCount and include that in your message as
Code:
lngCount & " of " rs!RecordCount & " records."

or assign the RecordCount to another long variable.?
 

Oreynolds

Member
Local time
Today, 20:04
Joined
Apr 11, 2020
Messages
157
Only if you put then in an array for that code?

The FolderExists function could have a second parameter to indicate if it does not exist create it.?
Then I might change it to a sub as it should always return True?

You could call the MakeDirectory from the FolderExists function ?

HTH

Edit: Re the Else part of the code, I thought of raising an error there, as that would skip the strLastFile assignment and should then show the correct filename.
Also if you put back .MoveLast, you could obtain the .RecordCount and include that in your message as
Code:
lngCount & " of " rs!RecordCount & " records."

or assign the RecordCount to another long variable.?

Thanks for this another good idea! I have added the record count to the error hadndler MsgBox and also added it to the 'Success' message box although I had to move the position of this one from after the End With to before the .Close as that point the .RecordCount was not available once the rs had been closed as far as I could see - see new code below FYI:

I am not totally clear on what you mean by the error on the ELSE part? At the moment if it follows ELSE then you get a MsgBox effectively saying there is nothing in the RecordSet, do you see a wider problem here?

Thanks again for your help, I'd offer to buy you a beer if the pubs were open!!

Code:
strLastProductName = rs!ProductName
                'In the event of an error determine the total number of sucessful copies made
                lngCounter = lngCounter + 1
                .MoveNext
                
            Wend
        Else
            .Close
            MsgBox ("There are no quotes or products linked to this job")
            GoTo ExitSub
        End If
        
        MsgBox (lngCounter & " of " & rs.RecordCount & " Products with linked datasheets attached to this project have been successfully copied to the projects OM Manual\Datasheets folder")
        .Close

    End With
    
        Set fsObject = Nothing
    Set rs = Nothing
    
    Shell "C:\WINDOWS\explorer.exe """ & FoldernameDestROOT & "", vbNormalFocus
    'MsgBox (lngCounter & " Products with linked datasheets attached to this project have been successfully copied to the projects OM Manual\Datasheets folder")

GoTo ExitSub

ExitSub:
    Set rs = Nothing
    Set fsObject = Nothing
    
    Exit Sub

ErrorHandler:

MsgBox "An ERROR has occured, it is most likely there is a product with an incorrect datasheet link. Using the information below and comparing it to the View" & _
" Datasheet List table you should be able to identify the issue easily." & vbCrLf & vbCrLf & _
"The last product succesfully copied was:" & vbCrLf & _
"ProductID: " & strLastProductID & vbCrLf & _
"Product Name: " & strLastProductName & vbCrLf & vbCrLf & _
"The last file succesfully copied was:" & vbCrLf & _
strLastFile & vbCrLf & vbCrLf & _
"The datsheet link where the error occured is: " & _
rs!DatasheetPath & vbCrLf & vbCrLf & _
lngCounter & " of " & rs.RecordCount & " files were successfully copied."

Resume ExitSub

End Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 20:04
Joined
Sep 21, 2011
Messages
14,047
If you Err.Raise <your choice of number> then the code will not proceed to the line that assigns strLastFile, so you will still report on the last successful file copied.?
 

Users who are viewing this thread

Top Bottom