لقد قمت ببناء فئة باني استعلام أساسي إلى حد ما للتغلب على فوضى تسلسل السلسلة وللتعامل مع نقص المعلمات المسماة. إنشاء استعلام بسيط إلى حد ما.

Public Function GetQuery() As String

    With New MSAccessQueryBuilder
        .QueryBody = "SELECT * FROM tblEmployees"

        .AddPredicate "StartDate > @StartDate OR StatusChangeDate > @StartDate"
        .AddPredicate "StatusIndicator IN (@Active, @LeaveOfAbsence) OR Grade > @Grade"
        .AddPredicate "Salary > @SalaryThreshhold"
        .AddPredicate "Retired = @IsRetired"

        .AddStringParameter "Active", "A"
        .AddLongParameter "Grade", 10
        .AddBooleanParameter "IsRetired", False
        .AddStringParameter "LeaveOfAbsence", "L"
        .AddCurrencyParameter "SalaryThreshhold", 9999.99@
        .AddDateParameter "StartDate", #3/29/2018#

        .QueryFooter = "ORDER BY ID ASC"
        GetQuery = .ToString

    End With

End Function

يشبه إخراج الأسلوب ToString ():

SELECT * من tblEmployees من أين 1 = 1 و (StartDate> # 3/29/2018 # أو StatusChangeDate> # 3/29/2018 #) و (StatusIndicator IN ('A'، 'L') أو Grade> 10) AND (Grade الراتب> 9999.99) AND (Retired = False) ترتيب حسب معرف ASC؛

يتم التفاف كل المسند في parens للتعامل مع الجمل و / أو المرتبطة ، والمعلمات التي تحمل نفس الاسم يجب أن تعلن مرة واحدة فقط. الرمز الكامل هو في github بلدي واستنساخها أدناه. لدي أيضًا version لاستعلامات Oracle التي تستخدم معلمات ADODB. في النهاية ، أرغب في الالتفاف على حد سواء في واجهة IQueryBuilder.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "MSAccessQueryBuilder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'@Folder("VBALibrary.Data")
'@Description("Provides tools to construct Microsoft Access SQL statements containing predicates and parameters.")

Option Explicit

Private Const mlngErrorNumber As Long = vbObjectError + 513
Private Const mstrClassName As String = "MSAccessQueryBuilder"
Private Const mstrParameterExistsErrorMessage As String = "A parameter with this name has already been added to the Parameters dictionary."

Private Type TSqlBuilder
    QueryBody As String
    QueryFooter As String
End Type

Private mobjParameters As Object
Private mobjPredicates As Collection
Private this As TSqlBuilder


' =============================================================================
' CONSTRUCTOR / DESTRUCTOR
' =============================================================================

Private Sub Class_Initialize()
    Set mobjParameters = CreateObject("Scripting.Dictionary")
    Set mobjPredicates = New Collection
End Sub


' =============================================================================
' PROPERTIES
' =============================================================================

'@Description("Gets or sets the query statement (SELECT, INSERT, UPDATE, DELETE), exclusive of any predicates.")
Public Property Get QueryBody() As String
    QueryBody = this.QueryBody
End Property
Public Property Let QueryBody(ByVal Value As String)
    this.QueryBody = Value
End Property

'@Description("Gets or sets post-predicate query statements (e.g., GROUP BY, ORDER BY).")
Public Property Get QueryFooter() As String
    QueryFooter = this.QueryFooter
End Property
Public Property Let QueryFooter(ByVal Value As String)
    this.QueryFooter = Value
End Property


' =============================================================================
' PUBLIC METHODS
' =============================================================================

'@Description("Maps a boolean parameter and its value to the query builder.")
'@Param("strName: The parameter's name.")
'@Param("blnValue: The parameter's value.")
Public Sub AddBooleanParameter(ByVal strName As String, ByVal blnValue As Boolean)
    If mobjParameters.Exists(strName) Then
        Err.Raise mlngErrorNumber, mstrClassName & ".AddBooleanParameter", mstrParameterExistsErrorMessage
    Else
        mobjParameters.Add strName, CStr(blnValue)
    End If
End Sub

' =============================================================================

'@Description("Maps a currency parameter and its value to the query builder.")
'@Param("strName: The parameter's name.")
'@Param("curValue: The parameter's value.")
Public Sub AddCurrencyParameter(ByVal strName As String, ByVal curValue As Currency)
    If mobjParameters.Exists(strName) Then
        Err.Raise mlngErrorNumber, mstrClassName & ".AddCurrencyParameter", mstrParameterExistsErrorMessage
    Else
        mobjParameters.Add strName, CStr(curValue)
    End If
End Sub

' =============================================================================

'@Description("Maps a date parameter and its value to the query builder.")
'@Param("strName: The parameter's name.")
'@Param("dtmValue: The parameter's value.")
Public Sub AddDateParameter(ByVal strName As String, ByVal dtmValue As Date)
    If mobjParameters.Exists(strName) Then
        Err.Raise mlngErrorNumber, mstrClassName & ".AddDateParameter", mstrParameterExistsErrorMessage
    Else
        mobjParameters.Add strName, "#" & CStr(dtmValue) & "#"
    End If
End Sub

' =============================================================================

'@Description("Maps a long parameter and its value to the query builder.")
'@Param("strName: The parameter's name.")
'@Param("lngValue: The parameter's value.")
Public Sub AddLongParameter(ByVal strName As String, ByVal lngValue As Long)
    If mobjParameters.Exists(strName) Then
        Err.Raise mlngErrorNumber, mstrClassName & ".AddNumericParameter", mstrParameterExistsErrorMessage
    Else
        mobjParameters.Add strName, CStr(lngValue)
    End If
End Sub

' =============================================================================

'@Description("Adds a predicate to the query's WHERE criteria.")
'@Param("strPredicate: The predicate text to be added.")
Public Sub AddPredicate(ByVal strPredicate As String)
    mobjPredicates.Add "(" & strPredicate & ")"
End Sub

' =============================================================================

'@Description("Maps a string parameter and its value to the query builder.")
'@Param("strName: The parameter's name.")
'@Param("strValue: The parameter's value.")
Public Sub AddStringParameter(ByVal strName As String, ByVal strValue As String)
    If mobjParameters.Exists(strName) Then
        Err.Raise mlngErrorNumber, mstrClassName & ".AddStringParameter", mstrParameterExistsErrorMessage
    Else
        mobjParameters.Add strName, "'" & strValue & "'"
    End If
End Sub

' =============================================================================

'@Description("Parses the query, its predicates, and any parameter values, and outputs an SQL statement.")
'@Returns("A string containing the parsed query.")
Public Function ToString() As String

Dim strPredicatesWithValues As String

    Const strErrorSource As String = "QueryBuilder.ToString"

    If this.QueryBody = vbNullString Then
        Err.Raise mlngErrorNumber, strErrorSource, "No query body is currently defined. Unable to build valid SQL."
    End If
    ToString = this.QueryBody

    strPredicatesWithValues = ReplaceParametersWithValues(GetPredicatesText)
    EnsureParametersHaveValues strPredicatesWithValues

    If Not strPredicatesWithValues = vbNullString Then
        ToString = ToString & " " & strPredicatesWithValues
    End If

    If Not this.QueryFooter = vbNullString Then
        ToString = ToString & " " & this.QueryFooter & ";"
    End If

End Function


' =============================================================================
' PRIVATE METHODS
' =============================================================================

'@Description("Ensures that all parameters defined in the query have been provided a value.")
'@Param("strQueryText: The query text to verify.")
Private Sub EnsureParametersHaveValues(ByVal strQueryText As String)

Dim strUnmatchedParameter As String
Dim lngMatchedPoisition As Long
Dim lngWordEndPosition As Long

    Const strProcedureName As String = "EnsureParametersHaveValues"

    lngMatchedPoisition = InStr(1, strQueryText, "@", vbTextCompare)
    If lngMatchedPoisition <> 0 Then
        lngWordEndPosition = InStr(lngMatchedPoisition, strQueryText, Space$(1), vbTextCompare)
        strUnmatchedParameter = Mid$(strQueryText, lngMatchedPoisition, lngWordEndPosition - lngMatchedPoisition)
    End If

    If Not strUnmatchedParameter = vbNullString Then
        Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strUnmatchedParameter & " has not been provided a value."
    End If

End Sub

' =============================================================================

'@Description("Combines each predicate in the predicates collection into a single string statement.")
'@Returns("A string containing the text of all predicates added to the query builder.")
Private Function GetPredicatesText() As String

Dim strPredicates As String
Dim vntPredicate As Variant

    If mobjPredicates.Count > 0 Then
        strPredicates = "WHERE 1 = 1"
        For Each vntPredicate In mobjPredicates
            strPredicates = strPredicates & " AND " & CStr(vntPredicate)
        Next vntPredicate
    End If

    GetPredicatesText = strPredicates

End Function

' =============================================================================

'@Description("Replaces parameters in the predicates statements with their provided values.")
'@Param("strPredicates: The text of the query's predicates.")
'@Returns("A string containing the predicates text with its parameters replaces by their provided values.")
Private Function ReplaceParametersWithValues(ByVal strPredicates As String) As String

Dim vntKey As Variant
Dim strParameterName As String
Dim strParameterValue As String
Dim strPredicatesWithValues As String

    Const strProcedureName As String = "ReplaceParametersWithValues"

    strPredicatesWithValues = strPredicates
    For Each vntKey In mobjParameters.Keys
        strParameterName = CStr(vntKey)
        strParameterValue = CStr(mobjParameters(vntKey))

        If InStr(1, strPredicatesWithValues, "@" & strParameterName, vbTextCompare) = 0 Then
            Err.Raise mlngErrorNumber, mstrClassName & "." & strProcedureName, "Parameter " & strParameterName & " was not found in the query."
        Else
            strPredicatesWithValues = Replace(strPredicatesWithValues, "@" & strParameterName, strParameterValue, 1, -1, vbTextCompare)
        End If
    Next vntKey

    ReplaceParametersWithValues = strPredicatesWithValues

End Function

' =============================================================================

هناك العديد من الطرق لاستخدام المعلمات في الاستعلامات. سأحاول تقديم أمثلة لمعظمهم ، وحيثما تكون قابلة للتطبيق.

أولاً ، سنناقش الحلول الفريدة لـ Access ، مثل النماذج والتقارير ومجاميع المجال. ثم ، سنتحدث عن DAO و ADO.

استخدام القيم من النماذج والتقارير كمعلمات

في Access ، يمكنك استخدام القيمة الحالية لعناصر التحكم في النماذج والتقارير مباشرة في رمز SQL الخاص بك. هذا يحد من الحاجة إلى المعلمات.

يمكنك الرجوع إلى عناصر التحكم بالطريقة التالية:

Forms!MyForm!MyTextbox لعنصر تحكم بسيط في نموذج

Forms!MyForm!MySubform.Form!MyTextbox لعنصر تحكم في نموذج فرعي

Reports!MyReport!MyTextbox لعنصر تحكم في تقرير

تنفيذ العينة:

DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Forms!MyForm!MyTextbox" 'Inserts a single value
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = Forms!MyForm!MyTextbox" 'Inserts from a different table

هذا متاح للاستخدامات التالية:

عند استخدام DoCmd.RunSQL ، استعلامات عادية (في واجهة المستخدم الرسومية) ، مصادر سجلات النماذج والتقارير ، عوامل تصفية النماذج DoCmd.OpenForm ، مجاميع المجال ، DoCmd.OpenForm و DoCmd.OpenReport

هذا غير متوفر للاستخدامات التالية:

عند تنفيذ الاستعلامات باستخدام DAO أو ADODB (مثل فتح مجموعات السجلات ، CurrentDb.Execute )

استخدام TempVars كمعلمات

TempVars في Access هي متغيرات متوفرة على مستوى العالم ، والتي يمكن تعيينها في VBA أو باستخدام وحدات الماكرو. يمكن إعادة استخدامها لاستعلامات متعددة.

تنفيذ العينة:

TempVars!MyTempVar = Me.MyTextbox.Value 'Note: .Value is required
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE ID = TempVars!MyTempVar"
TempVars.Remove "MyTempVar" 'Unset TempVar when you're done using it

توفر TempVars مماثل لتلك الخاصة بالقيم من النماذج والتقارير: غير متوفر لـ ADO و DAO ، المتاح للاستخدامات الأخرى.

أوصي TempVars باستخدام المعلمات عند فتح النماذج أو التقارير عبر الإشارة إلى أسماء عناصر التحكم ، لأنه إذا تم إغلاق الكائن الذي يفتحه ، فسيظل TempVars متاحًا. أوصي باستخدام أسماء TempVar الفريدة لكل نموذج أو تقرير ، لتجنب الغرابة عند تحديث النماذج أو التقارير.

استخدام الدالات المخصصة (UDFs) كمعلمات

مثل TempVars ، يمكنك استخدام دالة مخصصة ومتغيرات ثابتة لتخزين واسترداد القيم.

تنفيذ العينة:

Option Compare Database
Option Explicit

Private ThisDate As Date


Public Function GetThisDate() As Date
    If ThisDate = #12:00:00 AM# Then
        ' Set default value.
        ThisDate = Date
    End If 
    GetThisDate = ThisDate
End Function


Public Function SetThisDate(ByVal NewDate As Date) As Date
    ThisDate = NewDate
    SetThisDate = ThisDate
End Function

وثم:

SetThisDate SomeDateValue ' Will store SomeDateValue in ThisDate.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeDateField] = GetThisDate()"

أيضًا ، يمكن إنشاء وظيفة واحدة مع معلمة اختيارية لكل من الإعداد والحصول على قيمة متغير ثابت خاص:

Public Function ThisValue(Optional ByVal Value As Variant) As Variant
    Static CurrentValue As Variant
    ' Define default return value.
    Const DefaultValue  As Variant = Null

    If Not IsMissing(Value) Then
        ' Set value.
        CurrentValue = Value
    ElseIf IsEmpty(CurrentValue) Then
        ' Set default value
        CurrentValue = DefaultValue
    End If
    ' Return value.
    ThisValue = CurrentValue
End Function

لتعيين قيمة:

ThisValue "Some text value"

للحصول على القيمة:

CurrentValue = ThisValue

في استعلام:

ThisValue "SomeText"  ' Set value to filter on.
DoCmd.RunSQL "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE [SomeField] = ThisValue()"

باستخدام DoCmd.SetParameter

استخدامات DoCmd.SetParameter محدودة نوعا ما ، لذلك سأكون مختصرا. يسمح لك بتعيين معلمة للاستخدام في DoCmd.OpenForm و DoCmd.OpenReport وبعض عبارات DoCmd الأخرى ، لكنها لا تعمل مع DoCmd.RunSQL والمرشحات و DAO و ADO.

تنفيذ العينة

DoCmd.SetParameter "MyParameter", Me.MyTextbox
DoCmd.OpenForm "MyForm",,, "ID = MyParameter"

باستخدام DAO

في DAO ، يمكننا استخدام كائن DAO.QueryDef لإنشاء استعلام ، وتعيين المعلمات ، ثم فتح مجموعة سجلات أو تنفيذ الاستعلام. قمت أولاً بتعيين SQL للاستعلامات ، ثم استخدم مجموعة QueryDef.Parameters لتعيين المعلمات.

في مثالي ، سأستخدم أنواع المعلمات الضمنية. إذا كنت تريد توضيحها ، فأضف إعلان PARAMETERS إلى استفسارك.

تنفيذ العينة

'Execute query, unnamed parameters
With CurrentDb.CreateQueryDef("", "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ?p1 And Field2 = ?p2")
    .Parameters(0) = Me.Field1
    .Parameters(1) = Me.Field2
    .Execute
End With

'Open recordset, named parameters
Dim rs As DAO.Recordset
With CurrentDb.CreateQueryDef("", "SELECT Field1 FROM Table2 WHERE Field1 = FirstParameter And Field2 = SecondParameter")
    .Parameters!FirstParameter = Me.Field1 'Bang notation
    .Parameters("SecondParameter").Value = Me.Field2 'More explicit notation
    Set rs = .OpenRecordset
End With

بينما لا يتوفر هذا إلا في DAO ، يمكنك تعيين أشياء كثيرة على مجموعات سجلات DAO لجعلها تستخدم المعلمات ، مثل مجموعات السجلات النموذجية وسجلات مربع القائمة وسجلات مربع التحرير والسرد. ومع ذلك ، نظرًا لأن Access يستخدم النص ، وليس مجموعة السجلات ، عند الفرز والتصفية ، فقد تثبت هذه الأشياء أنها مشكلة إذا قمت بذلك.

باستخدام ADO

يمكنك استخدام المعلمات في ADO باستخدام كائن ADODB.Command . استخدم Command.CreateParameter لإنشاء معلمات ، ثم إلحاقها بمجموعة Command.Parameters .

يمكنك استخدام مجموعة .Parameters في ADO .Parameters المعلمات بشكل صريح أو تمرير صفيف معلمة إلى أسلوب Command.Execute لتمرير المعلمات ضمنيًا.

لا يدعم ADO المعلمات المسماة. بينما يمكنك تمرير اسم ، إلا أنه لم تتم معالجته.

تنفيذ العينة:

'Execute query, unnamed parameters
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
    Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
    .CommandText = "INSERT INTO Table1(Field1) SELECT Field1 FROM Table2 WHERE Field1 = ? And Field2 = ?"
    .Parameters.Append .CreateParameter(, adVarWChar, adParamInput, Len(Me.Field1), Me.Field1) 'adVarWChar for text boxes that may contain unicode
    .Parameters.Append .CreateParameter(, adInteger, adParamInput, 8, Me.Field2) 'adInteger for whole numbers (long or integer)
    .Execute
End With

'Open recordset, implicit parameters
Dim rs As ADODB.Recordset
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
With cmd
    Set .ActiveConnection = CurrentProject.Connection 'Use a connection to the current database
    .CommandText = "SELECT Field1 FROM Table2 WHERE Field1 = @FirstParameter And Field2 = @SecondParameter"
     Set rs = .Execute(,Array(Me.Field1, Me.Field2))
End With

تنطبق نفس القيود المطبقة على فتح سجلات DAO. بينما تقتصر هذه الطريقة على تنفيذ الاستعلامات وفتح السجلات ، يمكنك استخدام هذه السجلات في مكان آخر في التطبيق الخاص بك.