Export Parameter Query Results to Spreadsheet

[cdun2]

Hello,
I have a parameter query called 'Rev by AcctCode' that takes it's value from a form field; Forms![SalesAssoc]![e-mail].

I am trying to find a way to run this query, get the parameter value to it, and populate an Excel spreadsheet with the results.

Apparently, there is no direct way to use TransferSpreadsheet with a parameter query.

Instead, could I somehow get the results into a QueryDef, then use the named QueryDef with TransferSpreadsheet?

How might I do this? Can anyone point me to sample code?

Thank you for your help!

cdun2.

 

[bubba100]

The following is not pretty but it will do what you ask. You might want to print this out as it is a little long as has today. Good luck!

Dim i As Integer
Dim j As Integer
Dim j1 As Integer
Dim prm As Parameter
Dim MyFile, Myfile2, MyDirectory
Dim MyPath
Dim ExcelWasRunning, brunning As Boolean
Dim Message
Dim sheet As Object
Dim strSheetName, strVar As String
Dim xFile As Object
Dim stddocName2 As String
Dim strName, strProperty As String
Dim rstFUTS As QueryDef
Dim rsIrpIfta As QueryDef
Dim rst As Recordset
Dim rsFolder As Recordset
Dim rsIRP As Recordset
Dim dbsCur As Database
Dim CurrentField As Variant
Dim FieldCount As Integer
Dim FieldName As String
strSheetName = "IRPvsIFTA"
ExcelWasRunning = False
brunning = False
If Forms!frmIRPvsIFTA!LblWait.Visible = False Then
Forms!frmIRPvsIFTA!LblWait.Visible = True
End If
Message = MsgBox("Please Wait Until The IRP vs IFTA Reported Information Is Inserted Into The Audit File. This May Take Several Minutes.", vbOKOnly)
Set dbsCur = CurrentDb()
Docmd.Hourglass True
Set rstFUTS = dbsCur.QueryDefs("qryFuts")
Set rst = rstFUTS.OpenRecordset(dbOpenSnapshot)
Set rsFolder = DBEngine(0).Databases(0).OpenRecordset("tblRegistrantName")
Forms!frmRegistrantName!txtFuts.Value = rst!Futs_No
rst.Close
rstFUTS.Close

Set rsIrpIfta = dbsCur.QueryDefs("qryIRPvsIFTARep_Crosstab")
For Each prm In rsIrpIfta.Parameters
prm.Value = Eval(prm.Name)

Next prm
On Error Resume Next
Set xFile = GetObject(, "Excel.Application")
If Err.Number = 0 Then
ExcelWasRunning = True
xFile.Application.ActiveWorkbook.Save
xFile.Application.ActiveWorkbook.Close
Message = MsgBox("An Excel File Was Open, Click OK, The File Will Be Saved And Closed.", vbOKOnly)
End If
Err.Clear
If xFile Is Nothing Then
Set xFile = CreateObject("Excel.Application")
brunning = False
End If
xFile.Application.Workbooks.Open "C:\Program Files\Microsoft Office\Office11\XLStart\Personal.xls"
xFile.ActiveWindow.Visible = False
xFile.Visible = False

xFile.Application.Workbooks.Open "C:\My Documents\" & rsFolder!FolderName & "\" & rsFolder!AuditName
'Xfile.ActiveWindow.Visible = True
'Xfile.Visible = True

For i = 1 To xFile.Application.Sheets.Count
strName = xFile.Application.Sheets(i).Name
If strName = strSheetName Then GoTo SheetCreated:
Next i
xFile.ActiveWorkbook.Sheets.Add
xFile.ActiveSheet.Name = strSheetName
xFile.Application.ActiveWorkbook.Sheets("IRPvsIFTA").Move After:=xFile.Application.Worksheets("Options")

SheetCreated:
strProperty = xFile.Application.Calculation '-4105 seems to be numertic value for xlCalculationAutomatic
If xFile.Application.Calculation = xlCalculationAutomatic Then
xFile.Application.Calculation = xlCalculationManual
End If
'Clean Out Any Old Info On Sheet
xFile.ActiveWorkbook.Sheets(strSheetName).Range("A1:F100").Value = ""
'XXXXX Area Where The Reported IFTA Info Will Be Dropped On The IRPvsIFTA worksheet.
Set sheet = xFile.ActiveWorkbook.Sheets(strSheetName).Range("A1")
Set rsIRP = rsIrpIfta.OpenRecordset(dbOpenSnapshot)
FieldCount = rsIRP.Fields.Count
For j1 = 0 To FieldCount - 1
FieldName = rsIRP.Fields(j1).Name
xFile.ActiveWorkbook.Sheets(strSheetName).Cells(1, (j1 + 1)).Value = FieldName
Next j1

j = 2
Do Until rsIRP.EOF
For i = 0 To rsIRP.Fields.Count - 1
CurrentField = rsIRP(i)
sheet.Cells(j, i + 1).Value = CurrentField
Next i
rsIRP.MoveNext
j = j + 1
Loop

If xFile.Application.Calculation = xlCalculationManual Then
xFile.Application.Calculation = xlCalculationAutomatic
End If

'Xfile.Application.ActiveWorkbook.Save
xFile.Application.ActiveWorkbook.Close savechanges:=True
xFile.Application.Quit
Forms!frmIRPvsIFTA!LblWait.Visible = False

Docmd.Hourglass False
Message = MsgBox("Done, Open The Excel File To View The IRPvsIFTA worksheet.", vbOKOnly)
rsIRP.Close
rsFolder.Close
Set rsIRP = Nothing
Set rsFolder = Nothing
Set rst = Nothing
Set rstFUTS = Nothing
Set dbsCur = Nothing

 

[cdun2]

Thank you so much for taking the time to post this code!

cdun2