CODEWITHSUNDEEP
ms-accessvba
kdgwill
kdgwill

Reputation: 2199

VBA DoCmd.OutputTo With QueryDef

I've been looking a while now for a solution to export a query with open parameters. I need to export a Query as a Formatted Excel Spreadsheet and can't create additional Tables, Queries, Forms, or Reports to the Database being used. I use DoCmd.OutputTo as it exports a formatted query unlike DoCmd.TransferSpreadsheet however I can't seem to export the query with defined parameters. I need to include the parameters or else the user will be forced to input the start and end date three times a piece as the database for some reason asks for the startDate and endDate twice and in order to keep the excel spreadsheet and the subsequent outlook section consistant i would have to ask the user to input their previous parameters again 

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

The SQL currently given looks like similar to below with omitted fields for for clarity

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")));

Upvotes: 1

Views: 4440

Answers (1)

Fionnuala
Fionnuala

Reputation: 91356

I suggest you change the sql of the query.

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

Upvotes: 2

Related Questions