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
Code:
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