Export query results from a form - routine only works when done 2x

[SweetTraveller]

Hello,

I'm having a problem with an Export Routine. I've borrowed the code from someone else's project and am trying to adapt it for my use. The code works if done twice, but of course I would like it to work on the first go : ) Essentially I'm trying to export the results of a query, from a form. Here is the code I've been using - if anyone has suggestions I would be gratefull. Sorry its so long....

Private Type OPENFILENAME
lStructSize As Long
hwnd As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_SAVE = 0
Private Const OFN_OPEN = 1



Private Type CTLInf
Name As String
Enabled As Boolean
End Type
Private Declare Function apiSortStringArray Lib "msaccess.exe" _
Alias "#81" _
(astrStringArray() As String) _
As Long

Private arrCtls() As CTLInf
Private mvarOriginalFields As Variant
Private Const mconQ = """"
Private Sub cmdExport_Click()

Dim strSQL As String
Dim strWhere As String
Dim db As DAO.Database
Dim rs As DAO.Recordset

Call ExportRoutine

strSQL = "Select * "

strWhere = cboSearchField.Value & " LIKE '" & txtSearchString & "'"
Me.lstResult.RowSource = "select * from qry012LkpDoctor where " & strWhere
strSQL = strSQL & " from qry012LkpDoctor Where " & strWhere

Me.txtSQL = strSQL

Set rs = Nothing
Set db = Nothing

End Sub

Private Function ExportRoutine()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strName As String
Dim strFile As String
Const strSpecName = "~~TempSpec~~"
On Error GoTo ExportRoutine_err
With Me.lstResult
'With lstResult
.ColumnCount = 4
.ColumnWidths = "0,0,0"
.RowSourceType = "Value List"
.RowSource = "-1,-1,-1,Export Type," & "0,8,.xls,Excel,"
.Selected(1) = True

strFile = DialogFile(OFN_SAVE, "Save file", "", .Column(3) & " (" & .Column(2) & ")|" & .Column(2), CurDir, .Column(2))
End With
If Len(strFile) > 0 Then
'first get a unique name for the querydef object
strName = Application.Run("acwzmain.wlib_stUniquedocname", "Sheet1", acQuery)
Set db = CurrentDb
Set qdf = db.CreateQueryDef(strName, Me.txtSQL)
qdf.Close
With lstResult
DoCmd.TransferSpreadsheet acExport, .Column(1), strName, strFile, True
End With
End If

DoCmd.DeleteObject acQuery, strName

Set qdf = Nothing
db.QueryDefs.Refresh
Set db = Nothing

ExportRoutine_err:


End Function
Public Function DialogFile(wMode As Integer, szDialogTitle As String, szFileName As String, szFilter As String, szDefDir As String, szDefExt As String) As String
Dim X As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String
With OFN
.lStructSize = Len(OFN)
.hwnd = hWndAccessApp
.lpstrTitle = szDialogTitle
.lpstrFile = szFileName & String$(250 - Len(szFileName), 0)
.nMaxFile = 255
.lpstrFileTitle = String$(255, 0)
.nMaxFileTitle = 255
.lpstrFilter = NullSepString(szFilter)
.nFilterIndex = 2
.lpstrInitialDir = szDefDir
.lpstrDefExt = szDefExt
If wMode = 1 Then
OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
X = GetOpenFileName(OFN)
Else
OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
X = GetSaveFileName(OFN)
End If
If X <> 0 Then
If InStr(.lpstrFile, Chr$(0)) > 0 Then
szFile = left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
End If
DialogFile = szFile
Else
DialogFile = ""
End If
End With
End Function

'Pass a "|" separated string and returns a Null separated string
Private Function NullSepString(ByVal CommaString As String) As String
Dim intInstr As Integer
Const vbBar = "|"
Do
intInstr = InStr(CommaString, vbBar)
If intInstr > 0 Then Mid$(CommaString, intInstr, 1) = vbNullChar
Loop While intInstr > 0
NullSepString = CommaString
End Function