Looping not working

D

Dinger_80

Registered User.
Local time
Today, 00:59
Joined
Feb 28, 2013
Messages
109
I am working on setting up a loop that will get information from a query. I can handle the rest of the code once I get the primary piece of information. Which at this point I can not get. I am trying to get to the next record of my query. For some reason I am stuck on just the first record and it is repeated the exact number of times equal to the number of records in the query. Here is what I have so far.
Code: 
Dim FSO As Object
Dim FromPath As String
Dim FromPathCheck As String
Dim ToPath As String
Dim FinalDestination As String
Dim TRNumber As String
Dim TRNYear As String
Dim rs As DAO.Recordset
FromPath = DLookup("InitialServerDestination", "ServerDestinationQuery")
ToPath = DLookup("COmpletedServerDestination", "ServerDestinationQuery")
Set rs = CurrentDb.OpenRecordset("CompletedFolderMoveQuery")
With rs
    If .EOF And .BOF Then
        MsgBox "There are no folders to move at this time.", vbInformation
    Else
        Do Until .EOF
        FromPathCheck = FromPath & DLookup("TRNumber", "CompletedFolderMoveQuery")
        Debug.Print FromPathCheck
        
        'some more code in here
        rs.MoveNext
        Loop
    End If
End With

Yes I do know that I am doubled up on the
Code: 
rs.MoveNext
The reason is because with out this added rs it goes into an infinite loop. Any help in generating each value in the TRNumber field in the query I have would be appreciated.
 
You forgot the criteria for the DLookup statement?
 
Pr2-eugin,
Would I need the criteria if the query automatically gives me all of the results that I am looking for? The query is just two fields one that is the autonumber, the other is a number that I use here. The two bits of criteria I used in the query check if one field is true and anothe is false. So the query already returns all that I need. It is just that I can't seem to move on to the next record in the query.
 
Ok so I got it working once than I added in an extra SQL statement and it stopped working again. Not sure why it wont go to the next record when I use .MoveNext. Here is my code as it is.
Code: 
Dim FSO As Object
Dim FromPath As String
Dim FromPathCheck As String
Dim ToPath As String
Dim FinalDestination As String
Dim FinalHyper As String
Dim TRNumber As String
Dim TestNumber As String
Dim TRNYear As String
Dim rs As DAO.Recordset
Dim StrSQL, StrSQL2 As String
Dim Super As String
Dim Engineer As String
Dim CDO_Mail_Object As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String
FromPath = DLookup("InitialServerDestination", "ServerDestinationQuery")
ToPath = DLookup("CompletedServerDestination", "ServerDestinationQuery")
Super = DLookup("EmailAddress", "SupervisorEmailQuery")
Set rs = CurrentDb.OpenRecordset("CompletedFolderMoveQuery")
With rs
    If .EOF And .BOF Then
        MsgBox "There are no folders to move at this time.", vbInformation
    Else
        Do Until .EOF
        TRNumber = DLookup("TRNumber", "CompletedFolderMoveQuery")
        TestNumber = DLookup("TestRequestNumber", "CompletedFolderMoveQuery")
        TRNYear = Left(TRNumber, 4)
        FromPathCheck = FromPath & TRNumber
        FinalDestination = ToPath & "\" & TRNYear & "\"
        FinalHyper = ToPath & "\" & TRNYear & "\" & TRNumber
        StrSQL = "UPDATE TestRequestTable " & _
                 "SET TestRequestTable.FolderMoved = True & TestRequestTable.FolderHyperlink =" & "'" & "'" & _
                 "WHERE TestRequestTable.TestRequestNumber =" & TestNumber
        StrSQL2 = "UPDATE TestRequestTable " & _
                 "SET TestRequestTable.FolderHyperlink = '" & FinalHyper & "'" & _
                 "WHERE TestRequestTable.TestRequestNumber =" & TestNumber
                 
        Engineer = DLookup("EmailAddress", "CompletedFolderMoveQuery")
        Tech = DLookup("EmailAddress", "SuperCompletedLoopTechEmailQuery", [TestRequestNumber] = TestNumber)
        Debug.Print TestNumber
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(FinalDestination) Then
            Set FSO = CreateObject("Scripting.FileSystemObject")
            If FSO.FolderExists(FromPathCheck) Then
                Set FSO = CreateObject("scripting.filesystemobject")
                FSO.MoveFolder Source:=FromPathCheck, Destination:=FinalDestination & "\" & TRNumber
                DoCmd.SetWarnings False
                DoCmd.RunSQL StrSQL
                DoCmd.RunSQL StrSQL2
                DoCmd.SetWarnings True
                
                Email_Subject = "Test Request Number" & TRNumber
                Email_Send_From = Super
                Email_Send_To = Engineer & ";" & Tech
                Email_Cc = ""
                Email_Body = "Test Request Number " & TRNumber & " has been completed. The folder has been moved to " & FinalHyper
                Set CDO_Mail_Object = CreateObject("CDO.Message")
                
                Set CDO_Config = CreateObject("CDO.Configuration")
                CDO_Config.Load -1
                Set SMTP_Config = CDO_Config.Fields
                With SMTP_Config
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
                'please put your server name below
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "mail.etn.com"
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
                .Update
                End With
                With CDO_Mail_Object
                Set .Configuration = CDO_Config
                End With
                CDO_Mail_Object.Subject = Email_Subject
                CDO_Mail_Object.From = Email_Send_From
                CDO_Mail_Object.To = Email_Send_To
                CDO_Mail_Object.TextBody = Email_Body
                CDO_Mail_Object.CC = Email_Cc 'Use if needed
                CDO_Mail_Object.BCC = Email_Bcc 'Use if needed
                'CDO_Mail_Object.AddAttachment FileToAttach 'Use if needed
                CDO_Mail_Object.Send
            Else
                MsgBox "This test request isn't in the usual location. It will be marked as the folder having " & _
                        "been moved. Please verify this or manually move the folder later.", vbExclamation
                DoCmd.SetWarnings False
                DoCmd.RunSQL StrSQL
                DoCmd.RunSQL StrSQL2
                DoCmd.SetWarnings True
            End If
        Else
            Set FSO = CreateObject("scripting.filesystemobject")
            FSO.CreateFolder (FinalDestination)
                        
            If FSO.FolderExists(FinalDestination) Then
                Set FSO = CreateObject("Scripting.FileSystemObject")
                If FSO.FolderExists(FromPathCheck) Then
                    Set FSO = CreateObject("scripting.filesystemobject")
                    FSO.MoveFolder Source:=FromPathCheck, Destination:=FinalDestination & "\" & TRNumber
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL StrSQL
                    DoCmd.RunSQL StrSQL2
                    DoCmd.SetWarnings True
                    
                    Email_Subject = "Test Request Number" & TRNumber
                    Email_Send_From = Super
                    Email_Send_To = Engineer & ";" & Tech
                    Email_Cc = ""
                    Email_Body = "Test Request Number " & TRNumber & " has been completed. The folder has been moved to " & FinalHyper
                    Set CDO_Mail_Object = CreateObject("CDO.Message")
                    
                    Set CDO_Config = CreateObject("CDO.Configuration")
                    CDO_Config.Load -1
                    Set SMTP_Config = CDO_Config.Fields
                    With SMTP_Config
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
                    'please put your server name below
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "mail.etn.com"
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
                    .Update
                    End With
                    With CDO_Mail_Object
                    Set .Configuration = CDO_Config
                    End With
                    CDO_Mail_Object.Subject = Email_Subject
                    CDO_Mail_Object.From = Email_Send_From
                    CDO_Mail_Object.To = Email_Send_To
                    CDO_Mail_Object.TextBody = Email_Body
                    CDO_Mail_Object.CC = Email_Cc 'Use if needed
                    CDO_Mail_Object.BCC = Email_Bcc 'Use if needed
                    'CDO_Mail_Object.AddAttachment FileToAttach 'Use if needed
                    CDO_Mail_Object.Send
                Else
                    MsgBox "This test request isn't in the usual location. It will be marked as the folder having " & _
                            "been moved. Please verify this or manually move the folder later.", vbExclamation
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL StrSQL
                    DoCmd.RunSQL StrSQL2
                    DoCmd.SetWarnings True
                End If
            End If
        End If
        
    rs.MoveNext
    Loop
    End If
End With
End Sub

Any advice on how to advance to the next record in my query is appreciated.
 
This doesn't do what you think:
Code: 
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String

Access require EXPLICT dimensioning of variables

Dim Email_Subject as String
Dim Email_Send_From as String
or
Dim Email_Subject as String, Email_Send_From as String

Where exactly is this code? I don't see a Function or Sub reference..
 
in your original code you have this line, which does not reference your query.

FromPathCheck = FromPath & DLookup("TRNumber", "CompletedFolderMoveQuery")

I presume you want to pull some data out of the recordset. (TRNUMBER?)
so the syntax for that is either

rs!somefieldname OR
rs.fields("somefieldname"

eg rs!TRNUMBER
 
@JDRaw,
I thought that by having Email_Subject, Email_From as string made all variables strings. If that is not the case please let me know. I haven't run into any problems with that code yet and rather not run into any. I use it twice in with my email section inside of the loop.

@gemma-the-huskey
Thank you for that bit of imformation I will have to use that going forward. I am still going to work on reducing my coding method, for now I just needed to get this working. So I will change things when I get some time tomorrow.

Thank you both for your help. I got things up and running. Here is my final code.
Code: 
On Error GoTo errorhandler
Dim FSO As Object
Dim FromPath As String
Dim FromPathCheck As String
Dim ToPath As String
Dim FinalDestination As String
Dim FinalHyper As String
Dim TRNumber As String
Dim TestNumber As String
Dim TRNYear As String
Dim rs As DAO.Recordset
Dim StrSQL, StrSQL2 As String
Dim Super As String
Dim Engineer As String
[COLOR=red]Dim Tech As String
[/COLOR]Dim CDO_Mail_Object As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String
FromPath = DLookup("InitialServerDestination", "ServerDestinationQuery")
ToPath = DLookup("CompletedServerDestination", "ServerDestinationQuery")
Super = DLookup("EmailAddress", "SupervisorEmailQuery")
Set rs = CurrentDb.OpenRecordset("CompletedFolderMoveQuery")
With rs
    If .EOF And .BOF Then
        MsgBox "There are no folders to move at this time.", vbInformation
    Else
        Do Until .EOF
        TRNumber = DLookup("TRNumber", "CompletedFolderMoveQuery")
        TestNumber = DLookup("TestRequestNumber", "CompletedFolderMoveQuery")
        TRNYear = Left(TRNumber, 4)
        FromPathCheck = FromPath & TRNumber
        FinalDestination = ToPath & "\" & TRNYear
        FinalHyper = DLookup("CompletedServerHyperlink", "ServerDestinationQuery") & "\" & TRNumber
        StrSQL = "UPDATE TestRequestTable " & _
                 [COLOR=red]"SET TestRequestTable.FolderMoved = True," & _
                 "TestRequestTable.FolderHyperLink = " & " '" & "'" & _
[/COLOR]                 "WHERE TestRequestTable.TestRequestNumber =" & TestNumber
        StrSQL2 = "UPDATE TestRequestTable " & _
                 "SET TestRequestTable.FolderHyperlink = '" & FinalDestination & "\" & TRNumber & "'" & _
                 "WHERE TestRequestTable.TestRequestNumber =" & TestNumber
        Engineer = DLookup("EmailAddress", "CompletedFolderMoveQuery")
        [COLOR=red]Tech = DLookup("EmailAddress", "SuperCompletedLoopTechEmailQuery", "TestRequestNumber =" & TestNumber)
[/COLOR]                
        Set FSO = CreateObject("scripting.filesystemobject")
        If FSO.FolderExists(FinalDestination) Then
            If FSO.FolderExists(FromPathCheck) Then
                Set FSO = CreateObject("scripting.filesystemobject")
                FSO.MoveFolder Source:=FromPathCheck, Destination:=FinalDestination & "\" & TRNumber
                DoCmd.SetWarnings False
                DoCmd.RunSQL StrSQL
                DoCmd.RunSQL StrSQL2
                DoCmd.SetWarnings True
                
                Email_Subject = "Test Request Number" & TRNumber
                Email_Send_From = Super
                Email_Send_To = Engineer & ";" & Tech
                Email_Cc = ""
                Email_Body = "Test Request Number " & TRNumber & " has been completed. The folder has been moved to " & FinalHyper
                Set CDO_Mail_Object = CreateObject("CDO.Message")
                
                Set CDO_Config = CreateObject("CDO.Configuration")
                CDO_Config.Load -1
                Set SMTP_Config = CDO_Config.Fields
                With SMTP_Config
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
                'please put your server name below
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "mail.etn.com"
                .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
                .Update
                End With
                With CDO_Mail_Object
                Set .Configuration = CDO_Config
                End With
                CDO_Mail_Object.Subject = Email_Subject
                CDO_Mail_Object.From = Email_Send_From
                CDO_Mail_Object.To = Email_Send_To
                CDO_Mail_Object.TextBody = Email_Body
                CDO_Mail_Object.CC = Email_Cc 'Use if needed
                CDO_Mail_Object.BCC = Email_Bcc 'Use if needed
                'CDO_Mail_Object.AddAttachment FileToAttach 'Use if needed
                CDO_Mail_Object.Send
            Else
                MsgBox "This test request isn't in the usual location. It will be marked as the folder having " & _
                        "been moved. Please verify this or manually move the folder later.", vbExclamation
                DoCmd.SetWarnings False
                DoCmd.RunSQL StrSQL
                DoCmd.RunSQL StrSQL2
                DoCmd.SetWarnings True
            End If
        Else
            Set FSO = CreateObject("scripting.filesystemobject")
            FSO.CreateFolder (FinalDestination)
                        
            If FSO.FolderExists(FinalDestination) Then
                Set FSO = CreateObject("Scripting.FileSystemObject")
                If FSO.FolderExists(FromPathCheck) Then
                    Set FSO = CreateObject("scripting.filesystemobject")
                    FSO.MoveFolder Source:=FromPathCheck, Destination:=FinalDestination & "\" & TRNumber
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL StrSQL
                    DoCmd.RunSQL StrSQL2
                    DoCmd.SetWarnings True
                    
                    Email_Subject = "Test Request Number" & TRNumber
                    Email_Send_From = Super
                    Email_Send_To = Engineer & ";" & Tech
                    Email_Cc = ""
                    Email_Body = "Test Request Number " & TRNumber & " has been completed. The folder has been moved to " & FinalHyper
                    Set CDO_Mail_Object = CreateObject("CDO.Message")
                    
                    Set CDO_Config = CreateObject("CDO.Configuration")
                    CDO_Config.Load -1
                    Set SMTP_Config = CDO_Config.Fields
                    With SMTP_Config
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
                    'please put your server name below
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "mail.etn.com"
                    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserverport[/URL]") = 25
                    .Update
                    End With
                    With CDO_Mail_Object
                    Set .Configuration = CDO_Config
                    End With
                    CDO_Mail_Object.Subject = Email_Subject
                    CDO_Mail_Object.From = Email_Send_From
                    CDO_Mail_Object.To = Email_Send_To
                    CDO_Mail_Object.TextBody = Email_Body
                    CDO_Mail_Object.CC = Email_Cc 'Use if needed
                    CDO_Mail_Object.BCC = Email_Bcc 'Use if needed
                    'CDO_Mail_Object.AddAttachment FileToAttach 'Use if needed
                    CDO_Mail_Object.Send
                Else
                    MsgBox "This test request isn't in the usual location. It will be marked as the folder having " & _
                            "been moved. Please verify this or manually move the folder later.", vbExclamation
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL StrSQL
                    DoCmd.RunSQL StrSQL2
                    DoCmd.SetWarnings True
                End If
            End If
        End If
        
        .MoveNext
        Loop
    
    End If
End With
errorhandler:
    If Err.Number <> 0 Then
        Call ErrorEmail
    End If
    
End Sub

Put the notable changes in red. Thank you all for your help.
 
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body As String
will result in
Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc all being variant
Email_body will be string

Go to your Locals Window and see the details
 
You must log in or register to reply here.

Similar threads

L
Forms Substitution Within A Loop
Replies
11
Views
424
lhooker
L
T
Problem with NAME Statement
Replies
2
Views
205
Mark_
M
A
Send Report Through Access Form
Replies
10
Views
467
Gasman
Gasman
MajP
Randomize Not Working
2
Replies
25
Views
898
Pat Hartman
P
J
Using a variable in sql query
Replies
10
Views
880
ebs17
E

Users who are viewing this thread

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