Solved

VBA DAO Query Result Set

Posted on 2011-09-11
6
974 Views
Last Modified: 2012-05-12
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 As DAO.Recordset, objRS2 As DAO.Recordset, objRS3 As DAO.Recordset, objRS4 As DAO.Recordset, objRS5 As DAO.Recordset, 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

Open in new window

0
Comment
Question by:bedsingar
  • 2
  • 2
  • 2
6 Comments
 
LVL 61

Accepted Solution

by:
mbizup earned 500 total points
ID: 36519689
<as they only return one record (When in fact there should be at least two for each).>

Are you basing this ("one record") on the RecordCount property?

This is inaccurate, because the RecordCount property is always 1 or zero when the recordset is initially opened.  It is zero if there are no records; 1 if there are records.  It will display the correct "total records" if you use a moveLast statement.

In general, don't use RecordCount to determine the endpoint of your recordset loops.  Do something like this instead:

Do Until objRS6.EOF
     If ccaddress = "" Then ccaddress = objRS6.Fields("Email_Address") Else ccaddress = ccaddress & "; " & objRS6.Fields("Email_Address")
     objRS6.MoveNext        
Loop


This applies to any recordset loop you are currently using RecordCount as criteria for ending.
0
 
LVL 75
ID: 36519739
If a table is local (as opposed to Linked) ... and you need the RecordCount, that fastest, most efficient way is:

Dim lCnt As Long
lCnt = CurrentDB.TableDefs("YourTableName").RecordCount

mx
0
 

Author Comment

by:bedsingar
ID: 36519826
@ DatabaseMX thanks for the tip i'll give it a go.

@ mbizup thanks for your advice - this makes sense and is more than likely the issue. However switching  to the code you suggest has resulted in a "loop without a do" error ... Although there is a Do for Each loop. Quick google shows that the error is usually because of open If /Else statements. So I commented them all out & still no luck ...

Is there a limit to the number of nested loops you can have within a loop?

Thanks

Josh
0
Complete VMware vSphere® ESX(i) & Hyper-V Backup

Capture your entire system, including the host, with patented disk imaging integrated with VMware VADP / Microsoft VSS and RCT. RTOs is as low as 15 seconds with Acronis Active Restore™. You can enjoy unlimited P2V/V2V migrations from any source (even from a different hypervisor)

 

Author Comment

by:bedsingar
ID: 36519874
Ignore that - I commented a Next out by mistake. Resolved - Thanks for your help!
0
 
LVL 75
ID: 36519876
I think mbizup meant this:

Do Until objRS6.EOF
    If ccaddress = "" Then
             ccaddress = objRS6.Fields("Email_Address")
    Else  
             ccaddress = ccaddress & "; " & objRS6.Fields("Email_Address")
   End If
   objRS6.MoveNext        
Loop

MX
0
 
LVL 61

Expert Comment

by:mbizup
ID: 36520213
Glad that worked out.

<I think mbizup meant this...>


That was actually a direct copy/paste from bedsingar's code, and should work as-is.  Since it was written as a single line of code instead of as a block, the End If is not needed.
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

Suggested Solutions

I see at least one EE question a week that pertains to using temporary tables in MS Access.  But surprisingly, I was unable to find a single article devoted solely to this topic. I don’t intend to describe all of the uses of temporary tables in t…
Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now