Abbas Amiri
جمعه 16 دی 1390, 20:23 عصر
استفاده از کدهای زیر کار را برای فیلتر کردن لیست نمایش داده شده در کمبو آسانتر می کند. فقط کافیست در روال رویداد Change مربوط به کمبو به روش زیر عمل کنید: SmartSourceCombo Combo ,ColumnIndex اگر تعداد ستونهای کمبو یکی باشد ویا فیلدی که در کمبو نمایش داده میشود ، اولین فیلدکوئری مربوط به کمبو باشد، احتیاجی به درج ColumnIndex نیست.
Private Sub MyCombo_Change()
SmartSourceCombo MyCombo, 1
End Sub
کدهای زیر را در یک ماژول کپی کنید.
Public Function SmartSourceCombo(cbo As ComboBox, Optional fldColumnIdx As Integer = 0) As String
Dim sFilter As String, strRowSource As String, k As Integer, j As Integer, str1 As String, str2 As String
Dim SQL_WHERE As String, SQL_HAVING As String
strRowSource = Trim(cbo.RowSource)
If strRowSource = "" Then Exit Function
If InStr(strRowSource, ";") = 0 Then strRowSource = strRowSource & ";"
sFilter = Nz(Left(cbo.Text, Len(cbo.Text) - cbo.SelLength), "")
If SplitSQL(strRowSource, "WHERE") <> "" Then
str1 = SplitSQL(strRowSource, "WHERE")
k = InStr(str1, CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*")
If k Then
str1 = Left(str1, k - 1)
str2 = CompleteFieldName(strRowSource, fldColumnIdx)
k = InStr(SplitSQL(strRowSource, "SELECT"), str2)
k = InStrRev(SplitSQL(strRowSource, "SELECT"), " ", k)
str2 = str1 & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
Else
str2 = str1 & " AND " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
End If
SQL_WHERE = str2
'ElseIf SplitSQL(strRowSource, "HAVING") <> "" And InStr(str1, fldName(strRowSource, fldColumnIdx)) > 0 Then
' str1 = SplitSQL(strRowSource, "HAVING")
' k = InStr(str1, CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*")
' If k Then
' str1 = Left(str1, k - 1)
' str2 = str1 & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
' Else
' str2 = str1 & " AND " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
' End If
' SQL_HAVING = str2
Else
str2 = " WHERE " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
SQL_WHERE = str2
End If
strRowSource = SplitSQL(strRowSource, "SELECT") & SplitSQL(strRowSource, "FROM") & _
IIf(SQL_WHERE <> "", SQL_WHERE, SplitSQL(strRowSource, "WHERE")) & _
SplitSQL(strRowSource, "GROUP BY") & _
SplitSQL(strRowSource, "HAVING") & SplitSQL(strRowSource, "ORDER BY")
cbo.RowSource = strRowSource
cbo.Dropdown
SmartSourceCombo = strRowSource
End Function
Private Function fldName(ByVal sSource As String, idxfld As Integer) As String
On Error GoTo errFldName
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset(sSource)
fldName = rs.Fields(idxfld).Name
rs.Close
Set rs = Nothing
Exit Function
errFldName:
fldName = "Error"
End Function
Private Function GetSection(strSearch As String, Delemiter As String, Optional Nth As Integer = 1) As String
Dim workTb() As String, k As Integer, j As Integer
workTb = Split(strSearch, Delemiter)
k = UBound(workTb)
If k < Nth - 1 Then Exit Function
GetSection = workTb(Nth - 1)
End Function
Private Sub SortStringsByLenght(ByRef str)
Dim k As Integer, j As Integer, tmp As String
For k = 0 To UBound(str) - 1
For j = k + 1 To UBound(str)
If Len(str(k)) > Len(str(j)) Then
tmp = str(k)
str(k) = str(j)
str(j) = tmp
End If
Next
Next
End Sub
Private Function SplitSQL(ByVal strSQL As String, ByVal SQLSection As String)
Dim Sections(5) As String, k As Integer, j As Integer, s As String
Dim SectionList As Variant, tmp
SectionList = Array("FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY", ";")
j = Len(strSQL)
For k = 0 To 5
Sections(k) = GetSection(strSQL, CStr(SectionList(k)))
If Len(Sections(k)) < j Then
Else
Sections(k) = ""
End If
Next
SortStringsByLenght Sections
tmp = Sections
For k = 0 To 5
If Sections(k) <> "" Then
If k Then Sections(k) = Right(Sections(k), Len(Sections(k)) - Len(tmp(k - 1)))
If StrComp(Left(Sections(k), Len(SQLSection)), SQLSection, vbTextCompare) = 0 Then
SplitSQL = Sections(k)
Exit Function
End If
End If
Next
End Function
Private Function CompleteFieldName(strSQL As String, Optional idx As Integer = 0) As String
Dim k As Integer
Dim str1 As String, str2 As String
str2 = fldName(strSQL, idx)
str1 = SplitSQL(strSQL, "SELECT")
k = InStr(str1, str2)
j = InStrRev(str1, " ", k) + 1
str1 = Mid(str1, j, k - j)
CompleteFieldName = str1 & str2
End Function
Private Sub MyCombo_Change()
SmartSourceCombo MyCombo, 1
End Sub
کدهای زیر را در یک ماژول کپی کنید.
Public Function SmartSourceCombo(cbo As ComboBox, Optional fldColumnIdx As Integer = 0) As String
Dim sFilter As String, strRowSource As String, k As Integer, j As Integer, str1 As String, str2 As String
Dim SQL_WHERE As String, SQL_HAVING As String
strRowSource = Trim(cbo.RowSource)
If strRowSource = "" Then Exit Function
If InStr(strRowSource, ";") = 0 Then strRowSource = strRowSource & ";"
sFilter = Nz(Left(cbo.Text, Len(cbo.Text) - cbo.SelLength), "")
If SplitSQL(strRowSource, "WHERE") <> "" Then
str1 = SplitSQL(strRowSource, "WHERE")
k = InStr(str1, CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*")
If k Then
str1 = Left(str1, k - 1)
str2 = CompleteFieldName(strRowSource, fldColumnIdx)
k = InStr(SplitSQL(strRowSource, "SELECT"), str2)
k = InStrRev(SplitSQL(strRowSource, "SELECT"), " ", k)
str2 = str1 & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
Else
str2 = str1 & " AND " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
End If
SQL_WHERE = str2
'ElseIf SplitSQL(strRowSource, "HAVING") <> "" And InStr(str1, fldName(strRowSource, fldColumnIdx)) > 0 Then
' str1 = SplitSQL(strRowSource, "HAVING")
' k = InStr(str1, CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*")
' If k Then
' str1 = Left(str1, k - 1)
' str2 = str1 & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
' Else
' str2 = str1 & " AND " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
' End If
' SQL_HAVING = str2
Else
str2 = " WHERE " & CompleteFieldName(strRowSource, fldColumnIdx) & " LIKE '*" & sFilter & "*' "
SQL_WHERE = str2
End If
strRowSource = SplitSQL(strRowSource, "SELECT") & SplitSQL(strRowSource, "FROM") & _
IIf(SQL_WHERE <> "", SQL_WHERE, SplitSQL(strRowSource, "WHERE")) & _
SplitSQL(strRowSource, "GROUP BY") & _
SplitSQL(strRowSource, "HAVING") & SplitSQL(strRowSource, "ORDER BY")
cbo.RowSource = strRowSource
cbo.Dropdown
SmartSourceCombo = strRowSource
End Function
Private Function fldName(ByVal sSource As String, idxfld As Integer) As String
On Error GoTo errFldName
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset(sSource)
fldName = rs.Fields(idxfld).Name
rs.Close
Set rs = Nothing
Exit Function
errFldName:
fldName = "Error"
End Function
Private Function GetSection(strSearch As String, Delemiter As String, Optional Nth As Integer = 1) As String
Dim workTb() As String, k As Integer, j As Integer
workTb = Split(strSearch, Delemiter)
k = UBound(workTb)
If k < Nth - 1 Then Exit Function
GetSection = workTb(Nth - 1)
End Function
Private Sub SortStringsByLenght(ByRef str)
Dim k As Integer, j As Integer, tmp As String
For k = 0 To UBound(str) - 1
For j = k + 1 To UBound(str)
If Len(str(k)) > Len(str(j)) Then
tmp = str(k)
str(k) = str(j)
str(j) = tmp
End If
Next
Next
End Sub
Private Function SplitSQL(ByVal strSQL As String, ByVal SQLSection As String)
Dim Sections(5) As String, k As Integer, j As Integer, s As String
Dim SectionList As Variant, tmp
SectionList = Array("FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY", ";")
j = Len(strSQL)
For k = 0 To 5
Sections(k) = GetSection(strSQL, CStr(SectionList(k)))
If Len(Sections(k)) < j Then
Else
Sections(k) = ""
End If
Next
SortStringsByLenght Sections
tmp = Sections
For k = 0 To 5
If Sections(k) <> "" Then
If k Then Sections(k) = Right(Sections(k), Len(Sections(k)) - Len(tmp(k - 1)))
If StrComp(Left(Sections(k), Len(SQLSection)), SQLSection, vbTextCompare) = 0 Then
SplitSQL = Sections(k)
Exit Function
End If
End If
Next
End Function
Private Function CompleteFieldName(strSQL As String, Optional idx As Integer = 0) As String
Dim k As Integer
Dim str1 As String, str2 As String
str2 = fldName(strSQL, idx)
str1 = SplitSQL(strSQL, "SELECT")
k = InStr(str1, str2)
j = InStrRev(str1, " ", k) + 1
str1 = Mid(str1, j, k - j)
CompleteFieldName = str1 & str2
End Function