I am running a report and cannot figure out where the output data is being sent to. The code for the report is below. (It is not going to "O:\My Documents\GRF Spreadsheet.xls")
Option Compare Database
Option Explicit
Const conSSName = "Uninsured Patient Activity Reporting Form.xls"
Const conSSNew = "O:\My Documents\GRF Spreadsheet.xls"
Dim objXLApp As Excel.Application
Dim objXLBook As Excel.Workbook
Dim objResultsSheet As Excel.Worksheet
Dim objXLRange As Excel.Range
Const conSheetCount = 4
Dim strSSMaster As String
Dim varSheet(conSheetCount, 5) As Variant
Dim strFromDate As String, strToDate As String, strQtr As String
Dim intFY As Integer, intMo As Integer, intQtr As Integer
Private Sub btnExit_Click()
' Forms!frmReports.Visible = True
DoCmd.Close acForm, Me.Name
End Sub
Private Sub btnFile_Click()
Dim strPath As String
Dim booCopy As Boolean
Dim fs, f, f1, fc, ba
Dim i As Integer
varSheet(1, 1) = "Age"
varSheet(2, 1) = "CPT codes"
varSheet(3, 1) = "ICD-9 codes"
varSheet(4, 1) = "Zip codes"
varSheet(1, 2) = ""
varSheet(2, 2) = ""
varSheet(3, 2) = ""
varSheet(4, 2) = ""
varSheet(1, 3) = 15
varSheet(2, 3) = 1
varSheet(3, 3) = 1
varSheet(4, 3) = 1
varSheet(1, 4) = "grfAgeSexSpread"
varSheet(2, 4) = "grfCPTTmp"
varSheet(3, 4) = "grfICDTmp"
varSheet(4, 4) = "grfZipTmp"
varSheet(1, 5) = "grfNoInsTmp"
varSheet(2, 5) = "grfNoInsTmp"
varSheet(3, 5) = "grfNoInsTmp"
varSheet(4, 5) = "grfNoInsTmp"
strSSMaster = DLookup("[txtItem1]", "tblSystem", "[SectionID]='spreadSheet' and [ItemID]='location'")
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(txtPath)
Set fc = f.Files
breakApart txtPath, ba, "\"
strPath = ""
For i = 1 To UBound(ba) - 1
strPath = strPath & ba(i) & "\"
Next i
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
For Each f1 In fc
If f1 = strPath & ba(UBound(ba)) Then
Kill strPath & ba(UBound(ba))
Exit For
End If
Next f1
FileCopy strSSMaster & conSSName, txtPath
If Err = 76 Then
MsgBox "A valid path or file name has not been specified", vbInformation, "Spread sheet export"
Else
strFromDate = Me![fldFromDate]
strToDate = Me![fldToDate]
intMo = Month(CDate(strFromDate))
intQtr = Switch(intMo = 7, 1, intMo = 8, 1, intMo = 9, 1, _
intMo = 10, 2, intMo = 11, 2, intMo = 12, 2, _
intMo = 1, 3, intMo = 2, 3, intMo = 3, 3, _
intMo = 4, 4, intMo = 5, 4, intMo = 6, 4)
strQtr = IIf(intQtr = 1, "1st", IIf(intQtr = 2, "2nd", IIf(intQtr = 3, "3rd", "4th")))
intFY = Year(CDate(strFromDate)) ' calculate fiscal year
If intMo >= 7 And intMo <= 12 Then intFY = intFY + 1
If exportToExcelSpreadsheet(strFromDate, strToDate, txtPath) Then
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "lclWhData", txtPath
MsgBox "The GRF Quarterly spreadsheet is " & txtPath, vbInformation, "Spread sheet export"
End If
End If
End Sub
Public Function exportToExcelSpreadsheet(strFromDate As String, strToDate As String, strDest As String) As Boolean
Const strChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
' Object variables for Automation stuff
' DAO and other variables
Dim dbThis As Database
Dim rstSheet As Recordset
Dim varResults As Variant
Dim arrPct(14) As Single
Dim intCount As Integer
Dim cXLSPath As String, cXLSName As String
Dim i, j, k, n As Integer
Dim strRow As String, strCol As String, strCell As String
Dim strQuery As String, strTitle As String
Dim qdf As QueryDef
Dim ba
Dim lngTotal As Long
Dim booPct As Boolean
Dim strLastCell As String, strTotalCell As String, strSumRange
Call dhParsePath(strDest, cXLSPath, cXLSName) ' break apart new spread sheet file into path and file name
Set objXLBook = GetObject(cXLSPath & "\" & cXLSName) ' Go ahead and create an object from the XLS file
Set objXLApp = objXLBook.Parent ' Workbook Parent property ispointer to Excel's Application object
Set dbThis = CurrentDb
For n = 1 To conSheetCount
Set objResultsSheet = objXLBook.Worksheets(varSheet(n, 1)) ' this is the worksheet name
objXLBook.Windows(1).Visible = True
Set qdf = dbThis.QueryDefs(varSheet(n, 5)) ' change date in selection query
breakApart qdf.SQL, ba, "#"
strQuery = ba(1) & "#" & strFromDate & "#" & ba(3) & "#" & strToDate & "#" & ba(5)
qdf.SQL = strQuery ' update dates in selection query
qdf.Close
Set rstSheet = dbThis.OpenRecordset(varSheet(n, 4), dbOpenSnapshot)
rstSheet.MoveLast
rstSheet.MoveFirst
varResults = rstSheet.GetRows(rstSheet.RecordCount)
rstSheet.Close
booPct = n > 1
For i = 0 To UBound(arrPct)
arrPct(i) = 0
Next i
On Error GoTo exportToExcelSpreadSheet_Error
For i = 0 To UBound(varResults, 2) ' ss row
If n = 1 Then
' Age (n=1)
For j = 0 To UBound(varResults, 1) ' ss column
If n = 1 And j = 2 Then Exit For
strRow = CStr(i + 1 + varSheet(n, 3))
strCol = GetColumnDesignation(j + 2)
strCell = strCol & strRow & ":" & strCol & strRow
Set objXLRange = objResultsSheet.Range(strCell)
varResults(j, i) = Nz(varResults(j, i), 0)
If varType(varResults(j, i)) = vbLong Then
varResults(j, i) = CStr(varResults(j, i))
End If
objXLRange.value = varResults(j, i)
Next j
Else
For j = 0 To UBound(varResults, 1) ' ss column
strRow = CStr(i + 1 + varSheet(n, 3))
strCol = GetColumnDesignation(j + 1)
strCell = strCol & strRow & ":" & strCol & strRow
Set objXLRange = objResultsSheet.Range(strCell)
If varType(varResults(j, i)) = vbLong Then
varResults(j, i) = CStr(varResults(j, i))
End If
objXLRange.value = varResults(j, i)
If booPct And j = 0 And IsNull(varResults(j, i)) Then objXLRange.value = "U"
If booPct And j = 1 And IsNull(varResults(j, i)) Then objXLRange.value = "Unknown"
Next j
End If
Next i
If booPct Then
' set up totals for last column
strLastCell = lastCell ' find last cell used
' k = CInt(Mid(strLastCell, InStr(2, strLastCell, "$") + 1)) ' last row
k = UBound(varResults, 2) + 1 + varSheet(n, 3) ' last data row on spreadsheet
If n < 4 Then
strTotalCell = "C" & CStr(k + 1) & ":C" & CStr(k + 1)
strSumRange = "C" & CStr(varSheet(n, 3) + 1) & ".C" & CStr(k)
Else
strTotalCell = "B" & CStr(k + 1) & ":B" & CStr(k + 1)
strSumRange = "B" & CStr(varSheet(n, 3) + 1) & ".B" & CStr(k)
End If
Set objXLRange = objResultsSheet.Range(strTotalCell)
objXLRange.value = "=SUM(" & strSumRange & ")"
End If
Next n
lngTotal = objXLRange.value
Set objResultsSheet = objXLBook.Worksheets(varSheet(1, 1)) ' this is the first worksheet (Age)
' set Age sheet titles (A3 and F10)
Set objXLRange = objResultsSheet.Range("A3")
objXLRange.value = "Capital Park Family Health Center (FY" & Right(CStr(intFY), 2) & " - " & strQtr & " Quarter)"
Set objXLRange = objResultsSheet.Range("F10")
objXLRange.value = "Date: " & CStr(date)
Set objXLRange = objResultsSheet.Range("F12")
objXLRange.value = CStr(lngTotal)
dbThis.Close
' Now lets save the workbook and shut down Excel when we're done
objXLBook.Save
objXLApp.Quit
exportToExcelSpreadSheet_Done:
exportToExcelSpreadsheet = True
' Let's clean up our act
Set objResultsSheet = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
exportToExcelSpreadSheet_Exit:
Exit Function
exportToExcelSpreadSheet_Error:
Select Case Err.Number
Case Else
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number
End Select
Resume exportToExcelSpreadSheet_Exit
End Function
Private Sub Form_Load()
Me![txtPath] = conSSNew
Me.Repaint
DoCmd.GoToControl ("fldFromDate")
End Sub
Public Function lastCell() As String
Dim R As Range
Set R = objResultsSheet.UsedRange
lastCell = R.Cells(R.Rows.Count, R.Columns.Count).Address
End Function
Private Sub form_Open(Cancel As Integer)
Dim booTF As Boolean
booTF = csvCenterForm(Me.Name)
End Sub
Option Compare Database
Option Explicit
Const conSSName = "Uninsured Patient Activity Reporting Form.xls"
Const conSSNew = "O:\My Documents\GRF Spreadsheet.xls"
Dim objXLApp As Excel.Application
Dim objXLBook As Excel.Workbook
Dim objResultsSheet As Excel.Worksheet
Dim objXLRange As Excel.Range
Const conSheetCount = 4
Dim strSSMaster As String
Dim varSheet(conSheetCount, 5) As Variant
Dim strFromDate As String, strToDate As String, strQtr As String
Dim intFY As Integer, intMo As Integer, intQtr As Integer
Private Sub btnExit_Click()
' Forms!frmReports.Visible = True
DoCmd.Close acForm, Me.Name
End Sub
Private Sub btnFile_Click()
Dim strPath As String
Dim booCopy As Boolean
Dim fs, f, f1, fc, ba
Dim i As Integer
varSheet(1, 1) = "Age"
varSheet(2, 1) = "CPT codes"
varSheet(3, 1) = "ICD-9 codes"
varSheet(4, 1) = "Zip codes"
varSheet(1, 2) = ""
varSheet(2, 2) = ""
varSheet(3, 2) = ""
varSheet(4, 2) = ""
varSheet(1, 3) = 15
varSheet(2, 3) = 1
varSheet(3, 3) = 1
varSheet(4, 3) = 1
varSheet(1, 4) = "grfAgeSexSpread"
varSheet(2, 4) = "grfCPTTmp"
varSheet(3, 4) = "grfICDTmp"
varSheet(4, 4) = "grfZipTmp"
varSheet(1, 5) = "grfNoInsTmp"
varSheet(2, 5) = "grfNoInsTmp"
varSheet(3, 5) = "grfNoInsTmp"
varSheet(4, 5) = "grfNoInsTmp"
strSSMaster = DLookup("[txtItem1]", "tblSystem", "[SectionID]='spreadSheet' and [ItemID]='location'")
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(txtPath)
Set fc = f.Files
breakApart txtPath, ba, "\"
strPath = ""
For i = 1 To UBound(ba) - 1
strPath = strPath & ba(i) & "\"
Next i
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPath)
Set fc = f.Files
For Each f1 In fc
If f1 = strPath & ba(UBound(ba)) Then
Kill strPath & ba(UBound(ba))
Exit For
End If
Next f1
FileCopy strSSMaster & conSSName, txtPath
If Err = 76 Then
MsgBox "A valid path or file name has not been specified", vbInformation, "Spread sheet export"
Else
strFromDate = Me![fldFromDate]
strToDate = Me![fldToDate]
intMo = Month(CDate(strFromDate))
intQtr = Switch(intMo = 7, 1, intMo = 8, 1, intMo = 9, 1, _
intMo = 10, 2, intMo = 11, 2, intMo = 12, 2, _
intMo = 1, 3, intMo = 2, 3, intMo = 3, 3, _
intMo = 4, 4, intMo = 5, 4, intMo = 6, 4)
strQtr = IIf(intQtr = 1, "1st", IIf(intQtr = 2, "2nd", IIf(intQtr = 3, "3rd", "4th")))
intFY = Year(CDate(strFromDate)) ' calculate fiscal year
If intMo >= 7 And intMo <= 12 Then intFY = intFY + 1
If exportToExcelSpreadsheet(strFromDate, strToDate, txtPath) Then
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, "lclWhData", txtPath
MsgBox "The GRF Quarterly spreadsheet is " & txtPath, vbInformation, "Spread sheet export"
End If
End If
End Sub
Public Function exportToExcelSpreadsheet(strFromDate As String, strToDate As String, strDest As String) As Boolean
Const strChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
' Object variables for Automation stuff
' DAO and other variables
Dim dbThis As Database
Dim rstSheet As Recordset
Dim varResults As Variant
Dim arrPct(14) As Single
Dim intCount As Integer
Dim cXLSPath As String, cXLSName As String
Dim i, j, k, n As Integer
Dim strRow As String, strCol As String, strCell As String
Dim strQuery As String, strTitle As String
Dim qdf As QueryDef
Dim ba
Dim lngTotal As Long
Dim booPct As Boolean
Dim strLastCell As String, strTotalCell As String, strSumRange
Call dhParsePath(strDest, cXLSPath, cXLSName) ' break apart new spread sheet file into path and file name
Set objXLBook = GetObject(cXLSPath & "\" & cXLSName) ' Go ahead and create an object from the XLS file
Set objXLApp = objXLBook.Parent ' Workbook Parent property ispointer to Excel's Application object
Set dbThis = CurrentDb
For n = 1 To conSheetCount
Set objResultsSheet = objXLBook.Worksheets(varSheet(n, 1)) ' this is the worksheet name
objXLBook.Windows(1).Visible = True
Set qdf = dbThis.QueryDefs(varSheet(n, 5)) ' change date in selection query
breakApart qdf.SQL, ba, "#"
strQuery = ba(1) & "#" & strFromDate & "#" & ba(3) & "#" & strToDate & "#" & ba(5)
qdf.SQL = strQuery ' update dates in selection query
qdf.Close
Set rstSheet = dbThis.OpenRecordset(varSheet(n, 4), dbOpenSnapshot)
rstSheet.MoveLast
rstSheet.MoveFirst
varResults = rstSheet.GetRows(rstSheet.RecordCount)
rstSheet.Close
booPct = n > 1
For i = 0 To UBound(arrPct)
arrPct(i) = 0
Next i
On Error GoTo exportToExcelSpreadSheet_Error
For i = 0 To UBound(varResults, 2) ' ss row
If n = 1 Then
' Age (n=1)
For j = 0 To UBound(varResults, 1) ' ss column
If n = 1 And j = 2 Then Exit For
strRow = CStr(i + 1 + varSheet(n, 3))
strCol = GetColumnDesignation(j + 2)
strCell = strCol & strRow & ":" & strCol & strRow
Set objXLRange = objResultsSheet.Range(strCell)
varResults(j, i) = Nz(varResults(j, i), 0)
If varType(varResults(j, i)) = vbLong Then
varResults(j, i) = CStr(varResults(j, i))
End If
objXLRange.value = varResults(j, i)
Next j
Else
For j = 0 To UBound(varResults, 1) ' ss column
strRow = CStr(i + 1 + varSheet(n, 3))
strCol = GetColumnDesignation(j + 1)
strCell = strCol & strRow & ":" & strCol & strRow
Set objXLRange = objResultsSheet.Range(strCell)
If varType(varResults(j, i)) = vbLong Then
varResults(j, i) = CStr(varResults(j, i))
End If
objXLRange.value = varResults(j, i)
If booPct And j = 0 And IsNull(varResults(j, i)) Then objXLRange.value = "U"
If booPct And j = 1 And IsNull(varResults(j, i)) Then objXLRange.value = "Unknown"
Next j
End If
Next i
If booPct Then
' set up totals for last column
strLastCell = lastCell ' find last cell used
' k = CInt(Mid(strLastCell, InStr(2, strLastCell, "$") + 1)) ' last row
k = UBound(varResults, 2) + 1 + varSheet(n, 3) ' last data row on spreadsheet
If n < 4 Then
strTotalCell = "C" & CStr(k + 1) & ":C" & CStr(k + 1)
strSumRange = "C" & CStr(varSheet(n, 3) + 1) & ".C" & CStr(k)
Else
strTotalCell = "B" & CStr(k + 1) & ":B" & CStr(k + 1)
strSumRange = "B" & CStr(varSheet(n, 3) + 1) & ".B" & CStr(k)
End If
Set objXLRange = objResultsSheet.Range(strTotalCell)
objXLRange.value = "=SUM(" & strSumRange & ")"
End If
Next n
lngTotal = objXLRange.value
Set objResultsSheet = objXLBook.Worksheets(varSheet(1, 1)) ' this is the first worksheet (Age)
' set Age sheet titles (A3 and F10)
Set objXLRange = objResultsSheet.Range("A3")
objXLRange.value = "Capital Park Family Health Center (FY" & Right(CStr(intFY), 2) & " - " & strQtr & " Quarter)"
Set objXLRange = objResultsSheet.Range("F10")
objXLRange.value = "Date: " & CStr(date)
Set objXLRange = objResultsSheet.Range("F12")
objXLRange.value = CStr(lngTotal)
dbThis.Close
' Now lets save the workbook and shut down Excel when we're done
objXLBook.Save
objXLApp.Quit
exportToExcelSpreadSheet_Done:
exportToExcelSpreadsheet = True
' Let's clean up our act
Set objResultsSheet = Nothing
Set objXLBook = Nothing
Set objXLApp = Nothing
exportToExcelSpreadSheet_Exit:
Exit Function
exportToExcelSpreadSheet_Error:
Select Case Err.Number
Case Else
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number
End Select
Resume exportToExcelSpreadSheet_Exit
End Function
Private Sub Form_Load()
Me![txtPath] = conSSNew
Me.Repaint
DoCmd.GoToControl ("fldFromDate")
End Sub
Public Function lastCell() As String
Dim R As Range
Set R = objResultsSheet.UsedRange
lastCell = R.Cells(R.Rows.Count, R.Columns.Count).Address
End Function
Private Sub form_Open(Cancel As Integer)
Dim booTF As Boolean
booTF = csvCenterForm(Me.Name)
End Sub
-DW