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