Public Function exportClaimToExcel() As Boolean
';-----------------------------
';gemma-the-husky 2015
';www.access-programmers.co.uk
';
';process to populate a HMRC ods gift aid claim, from a source query
';
';'qdet - detailed donation query
'; qname - summary based on the above, to accumulate donations by donor
';
';I add a processed flag to the qdet query, so that if the claim exceeds 1000 lines, I can select the unprocessed lines only
';----------------------------
Const QDet = "the query with the detailed donation data"
Const QName = "the query with the summarised donation data based on qdet"
Const ExcelBase = 24 'the offset rows before we populate the spreadsheet. ie the spreadsheet starts at row 25
'I use a standard template, and copy this to a working template for each submission
Dim templatename As String
Dim templatepath As String
Dim destName As String
'variables to control excel
Dim xlApp As Object
Dim xlWB As Object
'processing variables to manage the recordset, and the excel sheet
Dim i As Long
Dim earliestdate As Date
Dim rst As Recordset
Dim excelrow As Long
Dim tclaim As Currency 'total claim value
Dim s As String
Dim counter As Long
On Error GoTo Err_exportClaimToExcel
'include code to select the ods file you wish to populate - templatename
'I have removed filepicker code I use here
templatename = "c:\mytemplate.ods"
destname = "c:\mytemplate_today.ods"
'i copy the template to a working version
On Error GoTo copyfail
FileCopy templatename, destName
On Error GoTo Err_exportToExcel
DoCmd.Hourglass True
earliestdate = DMin("PaymentDate", QDet, "[IRClaimAmount] > 0") 'evaluate the earliest claim date
'this goes in a cell on the ods file
On Error GoTo Err_exportClaimToExcel
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = False ' just update in background
Set xlWB = .Workbooks.Open(destName)
With xlWB
With .Sheets("desired sheet name")
.Cells(13, 4).value = earliestdate
counter = DCount("*", QName)
If counter > 1000 Then
MsgBox ("There are claims for " & counter & " Donors but HMRC only allows 1000 records per claim form. " & _
"1000 rows will be processed on this claim. , " & _
"You will then be able to prepare a further claim for " & _
"additional Donors. ")
counter = 1000
End If
SysCmd acSysCmdInitMeter, "Processing Items (" & counter & ")", counter
Set rst = CurrentDb.OpenRecordset(QName)
excelrow = 0
tclaim = 0
While Not rst.EOF
excelrow = excelrow + 1
SysCmd acSysCmdUpdateMeter, excelrow
.Cells(ExcelBase + excelrow, 3).value = rst![PersonTitle]
.Cells(ExcelBase + excelrow, 4).value = rst![PersonInitials]
.Cells(ExcelBase + excelrow, 5).value = rst![PersonSurname]
'determine whether address 1 starts with a house number, or not
If IsNumeric(Split(rst!Address1, " ")(0)) Then
.Cells(ExcelBase + excelrow, 6).value = Split(rst!PersonAddress1, " ")(0)
Else
.Cells(ExcelBase + excelrow, 6).value = rst!PersonAddress1
End If
.Cells(ExcelBase + excelrow, 7).value = rst![PersonPostCode]
.Cells(ExcelBase + excelrow, 8).value = Format(rst![PersonTotaldonation], "0.00")
.Cells(ExcelBase + excelrow, 9).value = rst![SponsoredEvent]
.Cells(ExcelBase + excelrow, 10).value = rst![PersonLatestDate]
.Cells(ExcelBase + excelrow, 11).value = Format(rst![PersonTotalclaim], "0.00")
tclaim = tclaim + rst!totalclaim
On Error GoTo upfail
s = "update " & qdet & " set IRClaimprocessed = " & True & " where PersonID = " & rst!PersonID
CurrentDb.Execute s
continue:
If excelrow = 1000 Then
MsgBox ("1000 rows have been processed, which is the maximum number permitted on a claim. " & _
"These rows will be now updated. You will then be able to prepare a further claim for " & _
"additional Donors. " & vbCrLf & vbCrLf & _
"The total claim for these items is: " & tclaim)
GoTo exitloop
End If
rst.MoveNext
Wend
exitloop:
rst.close
Set rst = Nothing
End With
'we opened the copy XL file, so just save it
.save
End With
SysCmd acSysCmdRemoveMeter
DoEvents
DoCmd.Hourglass False
.Visible = True 'make xl visible
Set xlWB = Nothing ' Clear reference to workbook
End With
Set xlApp = Nothing ' Clear reference to Excel
exportClaimToExcel = True
Exit_exportClaimToExcel:
MsgBox "The spreadsheet has been created. Please review the Excel spreadsheet to confirm it is correct. " & vbCrLf & vbCrLf & _
"The spreadsheet is: " & templatename & _
"The update process for this claim will now continue. "
'further processes are carried out on completion of the export process
Exit Function
Err_exportClaimToExcel:
MsgBox ("Error: " & err & " Desc: " & err.description)
Resume exitfail
copyfail:
MsgBox "Sorry. We were unable to copy the template to today's claim. Please ensure the template file is not open in Excel"
Exit Function
upfail:
Resume continue
exitfail:
On Error Resume Next
SysCmd acSysCmdRemoveMeter
xlApp.Visible = True
Set xlWB = Nothing
Set xlApp = Nothing
rst.close
Set rst = Nothing
DoCmd.Hourglass False
exportClaimToExcel = False
End Function
