Option Compare Database   'Use database order for string comparisons
Option Explicit

' READ ME
'
' Many forms and reports require flexible query criteria based on
' operator input.
'
' Many of my forms and reports create their recordsource or recordsource
' query definition in the FORM_OPEN or REPORT_OPEN Basic subroutine or
' during another event, such as when an operator changes criteria.
'
' This allows me to customize the query for the criteria or conditions at
' the time of the event.
'
' The usual way to do this is to first create the desired query using the
' Access query designer, view the SQL and then cut and past it into
' AB code similar the "Sub_CrtYourQueryDef()" example in this module.
'
' It is usually desirable to break up the SQL string construct into
' reasonable length lines of code, broken according to SQL reserved word
' as in the example.
'
' I would then add the customized "WHERE" or "HAVING" clause and either
' use the createquerydef or openquerydef to create or update the
' recordsource query or update the form or report's recordsource directly
' with the generated "strSQL" string.
'
' The problem is that as my queries change it becomes harder to update this
' code.
'
' I built the QSql() function to retreive and format the SQL
' property from most common select querys.
'
' I usually use it in the immediate box when I am creating or updating a
' function to generate the code from an existing query.
'
' To Use it Open the Immediate Box and Type:
'
'                    ?QSql("Your_Query_Name")
'
' It will return code similar to the "Sub_CrtYourQueryDef()" example.
' paste this into your function and modify it to meet your needs.
'
' QSql was lightly tested for a variety of Select, Update, Append,
' and Crosstab queries, but may not handle every situation properly.

'Author:  Bill Serrahn,  WorkGroup Solutions, Seattle, WA  12/3/94
'         206-726-9377   CIS: 72600,3450






' Written by: Bill Serrahn, WorkGroup Solutions, Seattle, WA
' Purpose   : Build Create Query Definition Function Text
'             From the SQLText of an existing QueryDef
'
Function QSql (QDefName)

On Error GoTo Err_QSql:

    ReDim SQLOPS(0 To 20)
    SQLOPS(0) = "SELECT "
    SQLOPS(1) = "FROM "
    SQLOPS(2) = "INNER "
    SQLOPS(3) = "LEFT "
    SQLOPS(4) = "RIGHT "
    SQLOPS(5) = "ON "
    SQLOPS(6) = "WHERE "
    SQLOPS(7) = "UNION "
    SQLOPS(8) = "HAVING "
    SQLOPS(9) = "GROUP BY "
    SQLOPS(10) = "HAVING "
    SQLOPS(11) = "ORDER BY "
    SQLOPS(12) = "(SELECT "
    SQLOPS(13) = "WITH "
    SQLOPS(14) = "UPDATE "
    SQLOPS(14) = "INSERT "
    SQLOPS(15) = "IN "
    SQLOPS(16) = "EXISTS "
    SQLOPS(17) = "TRANSFORM "
    SQLOPS(18) = "PIVOT "
    SQLOPS(19) = "PARAMETERS "
    SQLOPS(20) = ";"

    Dim db As Database, qdef As QueryDef
    Set db = dbengine(0)(0)
    Set qdef = db.OpenQueryDef(QDefName)

    Dim x As Integer, qdefsql As String, qdeflen As Integer
    qdeflen = Len(qdef.sql)
    
    For x = 1 To Len(qdef.sql)
      
      If Mid(qdef.sql, x, 1) = ";" And x >= (qdeflen - 2) Then
        qdefsql = qdefsql & Mid(qdef.sql, x, 1)
        Exit For
      End If
      
      If Mid(qdef.sql, x, 1) = Chr(13) Then        'CR
         qdefsql = qdefsql & Chr(32)               'Blank
         If Mid(qdef.sql, x + 1, 1) = Chr(13) Then
           x = x + 1                               'skip the second one
         End If
      Else
        If Mid(qdef.sql, x, 1) = Chr(10) Then      'Line Feed at the End
           x = x + 1
        Else
          If Mid(qdef.sql, x, 1) = Chr(34) Then      'Replace " with ""
            qdefsql = qdefsql & Chr(34) & Chr(34)
          Else
            qdefsql = qdefsql & Mid(qdef.sql, x, 1)
          End If
        End If
      End If
    Next
    
    Dim sqlpos As Integer, nextoppos As Integer, nextbreak As Integer
    Dim nextwordpos As Integer, nextsqlpos
    Dim Compto As String, LastChar As String, nextchars As String
    Dim strAB As String

    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "Dim strSQL as String"
    strAB = strAB & Chr(13) & Chr(10)

    qdeflen = Len(qdefsql)
    sqlpos = 1
    
NextLine_WGS_Qdefstr:
    
    nextwordpos = sqlpos
    nextsqlpos = 0
    nextoppos = 0
    
    Do Until nextoppos > 0
      
      nextbreak = InStr(nextwordpos + 1, qdefsql, Chr(32))  'Next Blank
      If nextbreak = 0 Then
        nextwordpos = qdeflen
      Else
        nextwordpos = nextbreak + 1
      End If
      
      For x = 0 To 20
        Compto = Mid(qdefsql, nextwordpos, Len(SQLOPS(x)))
        If SQLOPS(x) = Compto Then
            nextoppos = nextwordpos
            Exit Do
        End If
      Next
    
    Loop

    If (nextoppos - sqlpos) < 60 Then
       nextsqlpos = nextoppos
    Else
       x = sqlpos + 59
       Do Until x = sqlpos
         If x + 4 <= qdeflen Then
           If Mid(qdefsql, x, 5) = " AND " Then
             nextsqlpos = x + 1
             Exit Do
           End If
         End If
         If x + 3 <= qdeflen Then
           If Mid(qdefsql, x, 4) = " OR " Then
             nextsqlpos = x + 1
             Exit Do
           End If
         End If
         x = x - 1
       Loop
       
       If nextsqlpos = 0 Then
         x = sqlpos + 59
         Do Until x = sqlpos
           If x + 3 < qdeflen Then
             If Mid(qdefsql, x, 5) = " AS " Then
               nextsqlpos = x + 1
               Exit Do
             End If
           End If
           x = x - 1
         Loop
       End If
       
       If nextsqlpos = 0 Then
         x = sqlpos + 59
         Do Until x = sqlpos
           If x + 1 < qdeflen Then
             If Mid(qdefsql, x, 2) = ", " Then
               nextsqlpos = x + 2
               Exit Do
             End If
           End If
           x = x - 1
         Loop
       End If
       If nextsqlpos = 0 Then
         x = sqlpos + 59
         Do Until x = sqlpos
           If x < qdeflen Then
             If Mid(qdefsql, x, 1) = " " Or Mid(qdefsql, x, 1) = "," Then
               nextsqlpos = x + 1
               Exit Do
             End If
           End If
           x = x - 1
         Loop
       End If
    End If

    If nextsqlpos = 0 Then
      nextsqlpos = nextoppos
    End If

    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "strSQL = strSQL & """
    strAB = strAB & Mid(qdefsql, sqlpos, nextsqlpos - sqlpos) & """"
    
    sqlpos = nextsqlpos
    If sqlpos < qdeflen Then GoTo NextLine_WGS_Qdefstr:

    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "strSQL = strSQL & "";"""
    strAB = strAB & Chr(13) & Chr(10)
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "Dim db as database, qdef as querydef "
    strAB = strAB & Chr(13) & Chr(10)
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "Set db = dbengine(0)(0)"
    strAB = strAB & Chr(13) & Chr(10)
    strAB = strAB & Chr(13) & Chr(10) & "On Error Resume Next:"
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "db.deletequerydef(""YOUR_QDEF_NAME_HERE"")"
    strAB = strAB & Chr(13) & Chr(10)
    strAB = strAB & Chr(13) & Chr(10) & "On Error Goto Err_YOUR_LABEL_HERE:"
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "Set qdef = db.createquerydef(""YOUR_QDEF_NAME_HERE"")"
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "qdef.sql = strSQL"
    strAB = strAB & Chr(13) & Chr(10) & Chr(9) & "qdef.close"
    strAB = strAB & Chr(13) & Chr(10)

    QSql = strAB

Exit_QSql:
    Exit Function

Err_QSql:
    MsgBox Error$
    Resume Exit_QSql:

End Function

Sub Sub_CrtYourQueryDef ()
        
    Dim strSQL As String

    strSQL = strSQL & "SELECT DISTINCTROW C.CustomerID, C.Name, P.ProjectID, "
    strSQL = strSQL & "P.ProjName, P.WIPStatus, PP.PhaseID, PP.PhaseSeq, "
    strSQL = strSQL & "PP.PhaseDesc, PP.EstStart, PP.EstFinish, PP.Completed "
    strSQL = strSQL & "FROM (Customer AS C "
    strSQL = strSQL & "INNER JOIN [Project Phases] AS PP "
    strSQL = strSQL & "ON C.CustomerID = PP.CustomerID) "
    strSQL = strSQL & "INNER JOIN Project AS P "
    strSQL = strSQL & "ON (C.CustomerID = P.CustomerID) "
    strSQL = strSQL & "AND (P.CustomerID = PP.CustomerID) "
    strSQL = strSQL & "AND (P.ProjectID = PP.ProjectID) "
    strSQL = strSQL & "WHERE ((P.WIPStatus=""O"")) "
    strSQL = strSQL & "ORDER BY C.Name, P.ProjectID, PP.PhaseSeq"
    strSQL = strSQL & ";"

    Dim db As Database, qdef As QueryDef

    Set db = dbengine(0)(0)

On Error Resume Next:
    db.DeleteQueryDef ("YOUR_QDEF_NAME_HERE")

On Error GoTo Err_YOUR_LABEL_HERE:
    Set qdef = db.CreateQueryDef("YOUR_QDEF_NAME_HERE")
    qdef.sql = strSQL
    qdef.Close
        

EXIT_YOUR_LABEL_HERE:
    Exit Sub

Err_YOUR_LABEL_HERE:
    MsgBox Error$
    Resume EXIT_YOUR_LABEL_HERE:

End Sub

