VB ADO Query Result Set

[Bedsingar]

Hello,



I am trying to create a VB script to automate a mailing based on several query result sets from access. I have gotten to the stage that the output is correct but have a problem with the 5th and 6th record set query as they only return one record (When in fact there should be at least two for each).

I don't really understand why this is happeneing as the SQL is exactly the same as in the 2nd record set - which works perfectly. Also I've tested the SQL directly in an access query & there are no errors in the formatting that I can see... correct number of records returned.

I'd appreciate any help you could offer.

Thanks

Josh

Public emailaddress, ccaddress, Subject, body1 As String
Public baserow, toprow, countnumberofrows, emails As Integer
Public tempdir, projectlistdir, WBPATH As String
Option Compare Database
Option Explicit

'  This module requires references to the
'  following object libraries:
'
'  1. Microsoft Excel X.X Object Library,
'    where X.X is the Excel Version Number.
'
'  2. One of the following:
'
'    For mdb files:
'      Microsoft DAO 3.6 Object Library
'      (DAO360.DLL)
'    For ACCDB files (Access 2007):
'      Microsoft Office 12 Access Database Engine Objects
'      (ACEDAO.DLL)
'      This reference should be set already.
'
'  To set the reference, in the VBA editor:
'    Tools > References.

Private Sub SaveRecordsetToExcelRange()
  '  Excel constants:
  Const strcXLPath As String = "C:\Josh\My Docs\Project List Data\OUTPUT\AG_ACCRUALS_TEMPLATE.xls"
  Const strcWorksheetName As String = "Sheet1"
  Const strcCellAddress As String = "A3"
  
  '  Access constants:
  Const strcQueryName As String = "QRY018_PROJECT_WITH_AG_ACCRUALS"
  Const strcQueryName2 As String = "QRY016_AG_ACC_S1"
  Const strcQueryName3 As String = "TBL012_PROJECT_ALLOCATION"
  Const strcQueryName4 As String = "TBL011_PROJECT_CONTACTS"
  Const strcQueryName5 As String = "TBL013_AG_EMAIL_DETAIL"
  Const strcQueryName6 As String = "QRY020_PORTFOLIO_ALLOCATION_INC_DETAILS"
  
  '  Excel Objects:
  Dim objXL As Excel.Application
  Dim objWBK As Excel.Workbook
  Dim objWS As Excel.Worksheet
  Dim objRNG As Excel.Range
  
  ' Excel Varaiables:
  
  Dim RW, x As Integer
  Dim AC As String
  Dim sendmail As Integer
  
  sendmail = MsgBox("Should Emails Actually be Sent?", vbYesNo, "Send Mail")
    
  
  '  DAO objects:
  Dim objDB As DAO.Database
  Dim objQDF As DAO.QueryDef
  Dim objRS1, objRS2, objRS3, objRS4, objRS5, objRS6 As DAO.Recordset
  Dim rscount As Integer
  
  'SQL statements:
  Dim SSQL As String
  Dim intcolindex As Integer
  
  'find body text
  
  SSQL = "SELECT * FROM " & strcQueryName5
  
      '  Open a DAO recordset 5 on the query:
  Set objRS5 = CurrentDb.OpenRecordset(SSQL)
  
  Subject = objRS5.Fields("Subj").Value
  body1 = objRS5.Fields("Body").Value
  
  objRS5.Close
  
  'Rescord Set Criterion:
  
  Dim projno As String
  
  
  'On Error GoTo Error_Exit_SaveRecordsetToExcelRange
  
  'get all of the project numbers
  SSQL = "SELECT * FROM " & strcQueryName
    
    '  Open a DAO recordset 1 on the query:
  Set objRS1 = CurrentDb.OpenRecordset(SSQL)
  'objRS1.Close
  
    'use each of these project numbers to subquery the accruals
  
  Set objXL = New Excel.Application
  objXL.Visible = True
  
 Do Until objRS1.EOF
 
 projno = objRS1.Fields("PNO")
 
 'now loop through and collate the next dataset
 
 '_________________________________________________________________________________
 
 SSQL = "SELECT * FROM " & strcQueryName2 & " WHERE (" & strcQueryName2 & ".ProjectNumber = '" & projno & "')"
 Set objRS2 = CurrentDb.OpenRecordset(SSQL)
 
 '  Open Excel and point to the cell where
  '  the recordset is to be inserted:
 
  Set objWBK = objXL.Workbooks.Open(strcXLPath)
  Set objWS = objWBK.Worksheets(strcWorksheetName)
  Set objRNG = objWS.Range(strcCellAddress)
  objRNG.CopyFromRecordset objRS2
  
  'format the file
  
 
 'set the amount to be a formula
 objWS.Range("G3").Select
  RW = 3
 AC = "G" & RW
 Do Until objWS.Range(AC).Value = ""
 
 objWS.Range(AC).Formula = "=round(P" & RW & "*Q" & RW & ",2)"
    
 RW = RW + 1
 AC = "G" & RW
 Loop
 
 'put in column heads
 
 AC = "A2"
 For intcolindex = 0 To objRS2.Fields.Count - 1
 
   objWS.Range(AC).Offset(0, intcolindex).Value = objRS2.Fields(intcolindex).Name
    
 Next
 'put in instructions
 
 objWS.Range("A1").Value = "Please check that the nominal codes are correct and update the number of days to accrue. The formulas will calculate the correct acrrual value."
 objWS.Range("A1:M1").Interior.ColorIndex = 45
 
 'Highlight nominal and days
 
    objWS.Range("E3:E" & objRS2.RecordCount + 3).Interior.ColorIndex = 45
    objWS.Range("L3:M" & objRS2.RecordCount + 3).Interior.ColorIndex = 45
    objWS.Range("P3:P" & objRS2.RecordCount + 3).Interior.ColorIndex = 45
 
 'save file
  
  WBPATH = "C:\Josh\My Docs\Month End Journal Log\Period " & objWS.Range("U3").Value & "\AG ACCRUALS " & projno & ".xls"
  
  
  objWBK.SaveAs (WBPATH)
  objWBK.Close
  
If sendmail = vbNo Then GoTo nextrecord ' comment out when testing
  'find reciepiants____________________________________________________________________
  
  SSQL = "SELECT " & strcQueryName3 & ".Allocated_to FROM " & strcQueryName3 & " WHERE (" & strcQueryName3 & ".Project_Number = '" & projno & "')"
    Set objRS3 = CurrentDb.OpenRecordset(SSQL)
rscount = objRS3.RecordCount
    
    emailaddress = ""
    
For x = 0 To objRS3.RecordCount - 1
   
    SSQL = "SELECT * FROM " & strcQueryName4 & " WHERE (" & strcQueryName4 & ".Emp_Number = '" & objRS3.Allocated_to & "')"
    Set objRS4 = CurrentDb.OpenRecordset(SSQL)
          
    If emailaddress = "" Then emailaddress = objRS4.Fields("Email_Address") Else emailaddress = emailaddress & "; " & objRS4.Fields("Email_Address")
        
Next x
    
  'find cc_______________________________________________________________________________
  
   SSQL = "SELECT * FROM " & strcQueryName6 & " WHERE (" & strcQueryName6 & ".Project_Number = '" & projno & "')"
    Set objRS6 = CurrentDb.OpenRecordset(SSQL)
    rscount = objRS6.RecordCount
    
   ccaddress = ""
    
 For x = 0 To objRS6.RecordCount - 1
 If ccaddress = "" Then ccaddress = objRS6.Fields("Email_Address") Else ccaddress = ccaddress & "; " & objRS6.Fields("Email_Address")
        
 Next x
  
  
 'call email
    
  If sendmail = vbYes Then Email_AG_Accruals
      
    
 '__________________________________________________________________________________
 
nextrecord:
 objRS1.MoveNext
 Loop
 
Exit_SaveRecordsetToExcelRange:
CleanUp:
  '  Destroy Excel objects:
  Set objRNG = Nothing
  Set objWS = Nothing
  Set objWBK = Nothing
  Set objXL = Nothing
  
  '  Destroy DAO objects:
  If Not objRS2 Is Nothing Then
    objRS2.Close
    Set objRS2 = Nothing
  End If
  Set objQDF = Nothing
  Set objDB = Nothing
  
GoTo Closeses
    
Error_Exit_SaveRecordsetToExcelRange:
  MsgBox "Error " & Err.Number _
    & vbNewLine & vbNewLine _
    & Err.Description, _
    vbExclamation + vbOKOnly, _
    "Error Information"
    
  GoSub CleanUp
  Resume Exit_SaveRecordsetToExcelRange
MsgBox ("Job Complete")
Closeses:
End Sub
 
Sub Email_AG_Accruals()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = emailaddress
.CC = ccaddress
.BCC = ""
.Subject = Subject
.Body = body1
.Attachments.Add WBPATH
'.send  'or use
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

[orange]

I have not tried to study the logic of your script. But I saw this an must comment

Dim objRS1, objRS2, objRS3, objRS4, objRS5, objRS6 As DAO.Recordset

This does not do what you think. You must Dim variables explicitly.
You can do
Dim objRS1 As DAO.Recordset, objRS2 As DAO.Recordset, objRS3 As DAO.Recordset, objRS4 As DAO.Recordset, objRS5 As DAO.Recordset, objRS6 As DAO.Recordset

OR
Dim objRS1 As DAO.Recordset
Dim objRS2 As DAO.Recordset
Dim objRS3 As DAO.Recordset
Dim objRS4 As DAO.Recordset
Dim objRS5 As DAO.Recordset
Dim objRS6 As DAO.Recordset

In your statement, objRS1, objRS2, objRS3, objRS4, objRS5 will be dimmed as Variant( the default).

This may have nothing to do with your error, but that's how DIM works.
This also applies to

Dim RW, x As Integer
Public emailaddress, ccaddress, Subject, body1 As String
Public baserow, toprow, countnumberofrows, emails As Integer
Public tempdir, projectlistdir, WBPATH As String


Your post title mentions ADO but yu are using DAO.... is there something we're not seeing?

[Bedsingar]

ooops .. sorry ADO was a typo.

I'll try sepperating out the DIM's and see if it makes a difference, thanks for the explaination.

Josh

[Bedsingar]

Unfortunately that hasn't solved the issue.

[orange]

You may want to insert a few debug.print statements in the code and see the values of some of the variables at different spots in the code. It may help identify an issue.

Good luck

[Bedsingar]

I've been using the locales window to watch the content of the variables, all of which give the expected result. - Just these two record sets acting funny!