too few parameters. expected 1 Error (1 Viewer)

[bhelmy]

please help
when i use the following code with Query have criteria

too few parameters. expected 1 Error

the code

Code Tags Added by UG
Please use Code Tags when posting VBA Code
Please feel free to Remove this Comment
https://www.access-programmers.co.u...e-use-code-tags-when-posting-vba-code.240420/

Public Sub DataToText(ByVal strTable As String, Optional ByVal strOutput As String = "", _
                            Optional ByVal strDelimiter As String = "", _
                            Optional ByVal bolExtaSpaceAbove As Boolean = False)
   
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim outFile As Integer
    Dim i As Integer
    Dim LineOfText As String
   
    On Error GoTo ErrHandler
    DoCmd.Hourglass True
    If strOutput = "" Then strOutput = CurrentProject.Path & "\Text.txt"
    If strDelimiter = "" Then strDelimiter = Chr(9)
    If Dir(strOutput) <> "" Then Kill (strOutput)
    outFile = FreeFile
    Open strOutput For Output As #outFile
    Set db = CurrentDb
    Set rs = CurrentDb.OpenRecordset(strTable, dbOpenSnapshot)
   
   
    With rs
        If Not (.BOF And .EOF) Then
            .MoveFirst
            If bolExtaSpaceAbove Then
                Print #outFile, ""
            End If
            'if you want column headers, uncomment the following 5 lines of code
            For i = 0 To .Fields.Count - 1
                LineOfText = LineOfText & .Fields(i).Name & strDelimiter
            Next i
            LineOfText = Left(LineOfText, InStrRev(LineOfText, strDelimiter) - 1)
            Print #outFile, LineOfText

            'loop through records
            Do While Not .EOF
                LineOfText = ""
                'build up line of text
                For i = 0 To .Fields.Count - 1
                    LineOfText = LineOfText & Nz(.Fields(i)) & strDelimiter
                Next i
                LineOfText = Left(LineOfText, InStrRev(LineOfText, strDelimiter) - 1)
                'write line of text to file
                Print #outFile, LineOfText
            .MoveNext
            Loop
        End If
    End With
   
Resume_Here:
    If Not rs Is Nothing Then rs.Close: Set rs = Nothing
    If Not db Is Nothing Then Set db = Nothing
    If outFile > 0 Then Close #outFile
    DoCmd.Hourglass False
    Exit Sub
ErrHandler:
    DoCmd.Hourglass False
    If Err.Number = 70 Then
        MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & _
        "Cannot create " & strOutput & "." & vbCrLf & _
        "Make sure you have sufficient right."
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
    Resume Resume_Here
    Resume
End Sub


Public Function SpecialFolderPath1(strFolder As String) As String
    ' Find out the path to the passed special folder. User on of the following arguments:
    ' Options For specical folders
'        AllUsersDesktop
'        AllUsersStartMenu
'        AllUsersPrograms
'        AllUsersStartup
'        Desktop
'        Favorites
'        Fonts
'        MyDocuments
'        NetHood
'        PrintHood
'        Programs
'        Recent
'        SendTo
'        StartMenu
'        Startup
'        Templates

   On Error GoTo ErrorHandler

   'Create a Windows Script Host Object
      Dim objWSHShell As Object
      Set objWSHShell = CreateObject("WScript.Shell")

   'Retrieve path
      SpecialFolderPath1 = objWSHShell.specialfolders(strFolder & "")

CleanUp:
   ' Clean up
      Set objWSHShell = Nothing
      Exit Function

'**************************************
'*      Error Handler
'**************************************
ErrorHandler:
    MsgBox "Error finding " & strFolder, vbCritical + vbOKOnly, "Error"
    Resume CleanUp
End Function

 

[Ranman256]

If your query uses parameters,you put it in code with:
Set qdf= currentdb.querydefs("qsMyQuery")
Qdf.parameters(0)="myCriteria"
Qdf.parameters(1)="myOtherCrit"
Set rst=qdf.openRecordset

 

[cheekybuddha]

Hi,

Usually this can mean that you have a spelling mistake in one of the the field names of an SQL statement

However, if you are passing a saved query, then you will need to resolve the criteria.

You can use the Leigh's Generic Recordset() function to open your recordset.

You would substitute the following line in your code:

' ...
'  Set rs = CurrentDb.OpenRecordset(strTable, dbOpenSnapshot)
  Set rs = fDAOGenericRst(strTable, dbOpenSnapshot)
' ...

hth,

d

 

[cheekybuddha]

Oops! Ranman got in there before I finished typing!

 

[cheekybuddha]

As an alternative to all the code you have written to create a tab-delimited file, you can utilise a neat trick of an ADODB recordset (GetString() method).

It would mean using the fADOGenericRst() for the link I posted above. Here is version modified to be late bound, so you don't have to set a reference:

Function fADOGenericRst(ByVal strSource As String, _
                        Optional cnn As Object, _
                        Optional pCursorLocation As Integer = 2, _
                        Optional pCursorType As Integer = 1, _
                        Optional pLockType As Integer = 3, _
                        Optional pOption As Integer = -1) As Object

  Dim cmd As Object
  Dim prm As Object

  Set cmd = CreateObject("ADODB.Command")
  Set prm = CreateObject("ADODB.Parameter")

  If cnn Is Nothing Then
    Set cnn = CurrentProject.Connection
  End If

  Set cmd.ActiveConnection = cnn

  If Left(strSource, 11) <> "PARAMETERS " And Left(strSource, 7) <> "SELECT " Then
    strSource = "SELECT * FROM [" & strSource & "]"
  End If

  cmd.CommandText = strSource
  'cmd.Parameters.Refresh 'Is implicit - this is a Jet util so doesn't incur
  'overhead penalties
  For Each prm In cmd.Parameters
    prm.Value = Eval(prm.Name)
  Next

  Set fADOGenericRst = CreateObject("ADODB.Recordset")
  With fADOGenericRst
    .CursorLocation = pCursorLocation
    .Open cmd, , pCursorType, pLockType, pOption
  End With

  Set prm = Nothing
  Set cmd = Nothing

End Function

Then, you can reduce your code to:

Public Sub DataToText(ByVal strTable As String, _
                      Optional ByVal strOutput As String, _
                      Optional ByVal strDelimiter As String, _
                      Optional ByVal strRecBreak As String = vbNewLine, _
                      Optional ByVal bolExtaSpaceAbove As Boolean)
On Error GoTo ErrHandler

  Const adSaveCreateOverWrite = 2
  Dim i As Integer, strRecs As String
  
  DoCmd.Hourglass True
  If strOutput = "" Then strOutput = CurrentProject.Path & "\Text.txt"
  If strDelimiter = "" Then strDelimiter = Chr(9)
  With fADOGenericRst(strTable)
    For i = 0 To .Fields.Count - 1
      strRecs = strRecs & strDelimiter & .Fields(i).Name
    Next i
    strRecs = Mid(strRecs, Len(strDelimiter) + 1) & strRecBreak & _
              IIf(bolExtaSpaceAbove, strRecBreak, vbNullString)
    strRecs = strRecs & .GetString(, , strDelimiter, strRecBreak)
    .Close
  End With
  With CreateObject("ADODB.Stream")
    .Charset = "utf-8"
    .Open
    .WriteText strRecs
    .SaveToFile strOutput, adSaveCreateOverWrite
    .Close
  End With
  
Resume_Here:
  DoCmd.Hourglass False
  Exit Sub
  
ErrHandler:
  DoCmd.Hourglass False
  If Err.Number = 70 Then
    MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & _
            "Cannot create " & strOutput & "." & vbCrLf & _
            "Make sure you have sufficient right."
  Else
    MsgBox Err.Number & ": " & Err.Description
  End If
  Resume Resume_Here
  
End Sub

hth,

d