Elam, Debbie
DElam at jenkens.com
Thu May 17 10:00:04 CDT 2007
I found a bit of code that allows me to export to specific worksheets in
Excel. The intent being that I would have a 3 worksheet export of a report.
The code works very well except for one little snag at the end. I get a
runtime error 7952, you made an illegal function call, and the resulting
spreadsheet is the same size as the template. When I open the worksheet, it
actually opens 2 of them, one that has only the template info in it that has
the file name I designated, and a second underneath that is correct and
apparently not saved? I can save this but it generally will not save under
the filename I designated. I tried adding a save command to the end of the
code, but it simply says I already have a file with that name do I want to
replace. Clicking yes is ignored and it brings up a dialog to save it as
[filename]1.xls. Once again [filename].xls is blank except for template
included items and the [filename]1.xls comes out like I planned. This one
does not seem to have the full file hiding in it either. This is a lot
better than having the "good" file hide inside the blank one, but still not
really where I would like it to be for less tech savvy users.
Here is the code:
Public Function ExportRequestHardCode(strTemplate As String, strOutputFile
As String) As String
On Error GoTo err_Handler
' Excel object variables
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim sTemplate As String
Dim sTempFile As String
Dim sOutput As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim lRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer
Const cTabTwo As Byte = 2
Const cStartRow As Byte = 2
Const cStartColumn As Byte = 1
DoCmd.Hourglass True
' set to break on all errors
Application.SetOption "Error Trapping", 0
' start with a clean file built from the template file
sTemplate = CurrentProject.Path & strTemplate
sOutput = strOutputFile
'If Dir(sOutput) <> "" Then Kill sOutput
FileCopy strTemplate, sOutput
' Create the Excel Applicaiton, Workbook and Worksheet and Database
object
Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Open(sOutput)
StartofTab1:
Set wks = appExcel.Worksheets(1)
sSQL = "AAAllConsolidatedUnionOlderThan2K"
Set dbs = currentdb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
' For this template, the data must be placed on the 4th row, third
column.
' (these values are set to constants for easy future modifications)
iCol = 1
iRow = 2
If Not rst.BOF Then rst.MoveFirst
Do Until rst.EOF
iFld = 0
lRecords = lRecords + 1
'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
'Me.Repaint
For iCol = 1 To 1 + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = True
iFld = iFld + 1
Next
wks.Rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
'ExportRequest = "Total of " & lRecords & " rows processed."
'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
Set rst = Nothing
Set dbs = Nothing
StartofTab2:
Set wks = appExcel.Worksheets(2)
sSQL = "AAAllConsolidatedUnionBetween2Kand06"
Set dbs = currentdb
Set rst = dbs.OpenRecordset(sSQL, dbOpenDynaset, dbReadOnly)
' For this template, the data must be placed on the 4th row, third
column.
' (these values are set to constants for easy future modifications)
iCol = 1
iRow = 2
If Not rst.BOF Then rst.MoveFirst
Do Until rst.EOF
iFld = 0
lRecords = lRecords + 1
'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
'Me.Repaint
For iCol = 1 To 1 + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = True
iFld = iFld + 1
Next
wks.Rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
'ExportRequest = "Total of " & lRecords & " rows processed."
'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
Set rst = Nothing
Set dbs = Nothing
StartofTab3:
Set wks = appExcel.Worksheets(3)
sSQL = "AAAllConsolidatedUnionAfter06"
Set dbs = currentdb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
' For this template, the data must be placed on the 4th row, third
column.
' (these values are set to constants for easy future modifications)
iCol = 1
iRow = 2
If Not rst.BOF Then rst.MoveFirst
Do Until rst.EOF
iFld = 0
lRecords = lRecords + 1
'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
'Me.Repaint
For iCol = 1 To 1 + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = True
iFld = iFld + 1
Next
wks.Rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
'ExportRequest = "Total of " & lRecords & " rows processed."
'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
exit_Here:
' Cleanup all objects (resume next on errors)
On Error Resume Next
appExcel.SaveWorkspace (sOutput)
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Exit Function
err_Handler:
'ExportRequest = Err.Description
'Me.lblMsg.Caption = Err.Description
MsgBox Err.Description, vbOKOnly
Resume exit_Here
End Function