VBA DoCmd.OutputTo With QueryDef

Question

我一直在寻找一种解决方案来导出带有打开参数的查询。我需要将查询导出为格式化的Excel电子表格，并且不能为正在使用的数据库创建其他表格，查询，表单或报告。我使用DoCmd.OutputTo，因为它导出的格式化查询不像DoCmd.TransferSpreadsheet，但我似乎无法导出具有已定义参数的查询。我需要包含这些参数，否则用户将被迫输入作为数据库的开始和结束日期，因为数据库出于某种原因要求startDate和endDate两次，并且为了保持excel电子表格和随后的展望部分洽我将不得不

Sub Main() 
On Error GoTo Main_Err 


'Visually Display Process 
DoCmd.Hourglass True 

Dim fpath As String 
Dim tname As String 
Dim cname As String 
Dim tType As AcOutputObjectType 
Dim tempB As Boolean 

fpath = CurrentProject.path & "\" 
'tType = acOutputTable 
'tname = "APPROVED SWPS FOR LOOK AHEAD & BAR CHART" 
tType = acOutputQuery 
tname = "ASFLA&BC Query" 
cname = "Temp BPC Calendar" 


Dim qdfQry As DAO.QueryDef 
Dim strStart As String 
Dim strEnd As String 

Set qdfQry = CurrentDb().QueryDefs(tname) 


'strStart = InputBox("Please enter Start date (mm/dd/yyyy)") 
'strEnd = InputBox("Please enter Start date (mm/dd/yyyy)") 


qdfQry.Parameters("ENTER START DATE") = FormatDateTime("6/30/12", vbShortDate) 'strEnd 
qdfQry.Parameters("ENTER END DATE") = FormatDateTime("7/1/12", vbShortDate) 'strStart 





tempB = Backup(fpath, qdfQry, tType) 
If (Not tempB) Then 
    MsgBox "Excel Conversion Ended Prematurely..." 
    Exit Sub 
End If 

' tempB = sendToOutlook(qdfQry, cname) 
' If (Not tempB) Then 
'  MsgBox "Access Conversion Ended Prematurely..." 
'  Exit Sub 
' End If 

MsgBox "Procedure Completed Successfully" 

Main_Exit: 
    DoCmd.Hourglass False 
    Exit Sub 

Main_Err: 
    DoCmd.Beep 
    MsgBox Error$ 
    Resume Main_Exit 
End Sub 


'************************************************************************************ 
'* 
'*          Excel PORTION 
'* 
'************************************************************************************ 



Public Function Backup(path As String, db As DAO.QueryDef, Optional outputType As  AcOutputObjectType) As Boolean 
On Error GoTo Error_Handler 
    Backup = False 
    Dim outputFileName As String 
Dim name As String 
Dim tempB As Boolean 

'Set Up All Name Variablesand 
name = Format(Date, "MM-dd-yy") & ".xls" 

'Cleans Directory of Any older files and places them in an archive 
SearchDirectory path, "??-??-??.xls", name 

'See If File Can Now Be Exported. If Already Exists ask to overwrite 
outputFileName = path & name 

tempB = OverWriteRequest(outputFileName) 



If tempB Then 
    'Formats The Table And Exports Into A Formatted SpreadSheet 
    'Checks if an output type was added to the parameter if not defualt to table 
    If Not IsMissing(outputType) Then 
     DoCmd.OutputTo outputType, db.name, acFormatXLS, outputFileName, False 
    Else 
     DoCmd.OutputTo acOutputTable, db.name, acFormatXLS, outputFileName, False 
    End If 
Else 
    Exit Function 
End If 



Backup = True 

Error_Handler_Exit: 
    Exit Function 

Error_Handler: 
    MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _ 
Err.number & vbCrLf & "Error Source: Main Excel Backup" & vbCrLf & "Error Description: " & _ 
Err.Description, vbCritical, "An Error has Occured!" 

Resume Error_Handler_Exit 
End Function 

的SQL目前给出的模样类似再次要求用户输入他们以前的参数以下为清晰

PARAMETERS [ENTER START DATE] DateTime, [ENTER END DATE] DateTime; 
SELECT [SWPS].STATION, 
     [SWPS].START_DATE, 
     [SWPS].END_DATE, 
FROM [SWPS] 
WHERE ((([SWPS].STATION) 
Like ("*")) 
AND (([SWPS].START_DATE)<=[ENTER END DATE]) 
AND (([SWPS].END_DATE)>=[ENTER START DATE]) 
AND (([SWPS].SWP_STATUS) In ("A","P","W","T","R"))); 

Answer 1

省略领域，我建议你改变的SQL查询。

Dim qdfQry As DAO.QueryDef 
Dim strStart As String 
Dim strEnd As String 

''You could use a query specifically for this 
Set qdfQry = CurrentDb.QueryDefs(tname) 

sSQL=qdfQry.SQL 

NewSQL = "SELECT [SWPS].STATION, [SWPS].START_DATE, [SWPS].END_DATE, " _ 
     & "FROM [SWPS] WHERE [SWPS].STATION Like '*' " _ 
     & "AND [SWPS].SWP_STATUS In ('A','P','W','T','R') " _ 
     & "AND [SWPS].START_DATE)<=#" & Format(DateStart, "yyyy/mm/dd") & "# " _ 
     & "AND [SWPS].END_DATE)>=#" & Format(DateEnd, "yyyy/mm/dd") & "#" 

qdfQry.SQL = NewSQL 

''Do the excel stuff 

''Reset the query 
qdfQry.SQL = sSQL