N
Nick Hudson
Guest
Hello.
I have a main form with a subform.
Currently, the subform list can be filtered alphabetically (by button choice)AND by favourability (ie. Most favourable, Favourable, Least favourable) (again by button). Each has the ALL button.
Hence I can look for a contact starting with a "M" and which belongs to my "Most Favourite" List.
I wish to expand the main form filtering to now have another two series of filters, namely;
1. Category (Consultant, Engineer, and so on)
2. State (ie.Australian States NSW, VIC, QLD, and so on)
So, on the main form, I have 4 filters working simultaneous.
I now have the ability to search for all the 1. Contractors that work in 2. NSW and that belong to my 3. "Favourite" List with 4. Alphabetically being "ALL".
or
I might not quite recall a contractor starting with 1. "K" that is a 2. "Engineer" that lives in 3. "VIC" state
I have the event procedure for the two filters being Favouribility and alphabetcally if that is of use.
I have tried over 6 months to get this and have failed - I'm not a developer.
To give you an example; here is the event procedure that was kindly given to me some time ago - the recipient of whom I have lost contact with.
-------
Extract
-------
ption Compare Database
Option Explicit
Private Sub CombineFilters(LetterFilter As String)
On Error GoTo CombineFilters_AfterUpdate_Err
'New function to mash two filter-sets together
Dim strStatusFilter As String
If (CompanyFilters = 1) Then
' Filter for Most Favourable List
'WKREM DoCmd.ApplyFilter "", "[StatusGreen] = 1"
strStatusFilter = "[StatusGreen] = True"
End If
If (CompanyFilters = 2) Then
' Filter for BOTH Most Favourable List AND Favourable List
'WKREM DoCmd.ApplyFilter "", "[StatusGreen] = 1 Or [StatusOrange] = 1"
strStatusFilter = "[StatusGreen] = True Or [StatusOrange] = True"
End If
If (CompanyFilters = 3) Then
' Filter for Favourable List
strStatusFilter = "[StatusOrange] = True"
End If
If (CompanyFilters = 4) Then
' Filter for Least Favourable List
strStatusFilter = "[StatusRed] = True"
End If
If (CompanyFilters = 5) Then
strStatusFilter = ""
End If
If IsNull(strStatusFilter) = False And Len(strStatusFilter) > 0 Then
'if a statusFilter selected then...
If Len(LetterFilter) > 0 Then
'if a LetterFilter selected then...
DoCmd.ApplyFilter "", LetterFilter & " And (" & strStatusFilter & ")"
Else
'if NO LetterFilter (eg Show All Letters) selected then...
DoCmd.ApplyFilter "", strStatusFilter
End If
Else
'if NO statusFilter selected (eg Show All Statuses) then...
'if a LetterFilter selected then...
If Len(LetterFilter) > 0 Then
DoCmd.ApplyFilter "", LetterFilter
Else
'if NO LetterFilter OR StatusFilter then...
DoCmd.ShowAllRecords
End If
End If
If (RecordsetClone.RecordCount > 0) Then
' If records are returned for the selected letter, go to the Keyword control.
DoCmd.GoToControl "Name"
' Stop the macro.
Exit Sub
End If
If (RecordsetClone.RecordCount = 0) Then
' If no records are returned for the selected list, display a message.
MsgBox "There are no records for that listing.", vbInformation, "No Records Returned"
' Show all records.
DoCmd.ShowAllRecords
' Press in the All button for both filter buttons
CompanyFilters = 5
CompanyFilterByLetter = 27
End If
CombineFilters_AfterUpdate_Exit:
Exit Sub
CombineFilters_AfterUpdate_Err:
MsgBox Error$
Resume CombineFilters_AfterUpdate_Exit
End Sub
Private Sub CompanyFilterByLetter_AfterUpdate()
On Error GoTo CompanyFilterByLetter_AfterUpdate_Err
'This function has been converted to produce a string value of the appropriate filter
'This is then passed to the above CombineFilters function
Dim strLetterFilter As String
If (CompanyFilterByLetter = 1) Then
' Filter for company names that start with A, À, Á, Â, Ã, or Ä.
strLetterFilter = "[Name] Like ""[AÀÁÂÃÄ]*"""
End If
If (CompanyFilterByLetter = 2) Then
' B
strLetterFilter = "[Name] Like ""B*"""
End If
If (CompanyFilterByLetter = 3) Then
' C or Ç
strLetterFilter = "[Name] Like ""[CÇ]*"""
End If
If (CompanyFilterByLetter = 4) Then
' D
strLetterFilter = "[Name] Like ""D*"""
End If
If (CompanyFilterByLetter = 5) Then
' E, È, É, Ê, or Ë
strLetterFilter = "[Name] Like ""[EÈÉÊË]*"""
End If
If (CompanyFilterByLetter = 6) Then
' F
strLetterFilter = "[Name] Like ""F*"""
End If
If (CompanyFilterByLetter = 7) Then
' G
strLetterFilter = "[Name] Like ""G*"""
End If
If (CompanyFilterByLetter = 8) Then
' H
strLetterFilter = "[Name] Like ""H*"""
End If
If (CompanyFilterByLetter = 9) Then
' I, Ì, Í, Î, or Ï
strLetterFilter = "[Name] Like ""[IÌÍÎÏ]*"""
End If
If (CompanyFilterByLetter = 10) Then
' J
strLetterFilter = "[Name] Like ""J*"""
End If
If (CompanyFilterByLetter = 11) Then
' K
strLetterFilter = "[Name] Like ""K*"""
End If
If (CompanyFilterByLetter = 12) Then
' L
strLetterFilter = "[Name] Like ""L*"""
End If
If (CompanyFilterByLetter = 13) Then
' M
strLetterFilter = "[Name] Like ""M*"""
End If
If (CompanyFilterByLetter = 14) Then
' N, or Ñ
strLetterFilter = "[Name] Like ""[NÑ]*"""
End If
If (CompanyFilterByLetter = 15) Then
' O, Ò, Ó, Ô, Õ, or Ö
strLetterFilter = "[Name] Like ""[OÒÓÔÕÖ]*"""
End If
If (CompanyFilterByLetter = 16) Then
' P
strLetterFilter = "[Name] Like ""P*"""
End If
If (CompanyFilterByLetter = 17) Then
' Q
strLetterFilter = "[Name] Like ""Q*"""
End If
If (CompanyFilterByLetter = 18) Then
' R
strLetterFilter = "[Name] Like ""R*"""
End If
If (CompanyFilterByLetter = 19) Then
' S or Š (S hacek)
strLetterFilter = "[Name] Like ""[SŠ]*"""
End If
If (CompanyFilterByLetter = 20) Then
' T
strLetterFilter = "[Name] Like ""T*"""
End If
If (CompanyFilterByLetter = 21) Then
' U, Ù, Ú, Û, or Ü
strLetterFilter = "[Name] Like ""[UÙÚÛÜ]*"""
End If
If (CompanyFilterByLetter = 22) Then
' V
strLetterFilter = "[Name] Like ""V*"""
End If
If (CompanyFilterByLetter = 23) Then
' W
strLetterFilter = "[Name] Like ""W*"""
End If
If (CompanyFilterByLetter = 24) Then
' X
strLetterFilter = "[Name] Like ""X*"""
End If
If (CompanyFilterByLetter = 25) Then
' Y, Ý, or ÿ
strLetterFilter = "[Name] Like ""[YÝÿ]*"""
End If
If (CompanyFilterByLetter = 26) Then
' Z, Æ, Ø, or Å
strLetterFilter = "[Name] Like ""[ZØÅ]*"""
End If
If (CompanyFilterByLetter = 27) Then
strLetterFilter = ""
End If
'Mash the two filter-sets together via CombineFilters function
Call CombineFilters(strLetterFilter)
CompanyFilterByLetter_AfterUpdate_Exit:
Exit Sub
CompanyFilterByLetter_AfterUpdate_Err:
MsgBox Error$
Resume CompanyFilterByLetter_AfterUpdate_Exit
End Sub
Private Sub More_Details_Button_Click()
On Error GoTo Err_More_Details_Button_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Company Details Mainform1"
stLinkCriteria = "[CompanyID]=" & Me![CompanyID]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_More_Details_Button_Click:
Exit Sub
Err_More_Details_Button_Click:
MsgBox Err.Description
Resume Exit_More_Details_Button_Click
End Sub
Private Sub Close_Button_Click()
On Error GoTo Err_Close_Button_Click
DoCmd.Close
Exit_Close_Button_Click:
Exit Sub
Err_Close_Button_Click:
MsgBox Err.Description
Resume Exit_Close_Button_Click
End Sub
'------------------------------------------------------------
' CompanyFilters_AfterUpdate
'
'------------------------------------------------------------
Private Sub CompanyFilters_AfterUpdate()
On Error GoTo CompanyFilters_AfterUpdate_Err
'Moved all code into CombineFilters function
'Call to CompanyFilterByLetter_AfterUpdate to grab the letter filter string and then mash the
'filters together via CombineFilters
Call CompanyFilterByLetter_AfterUpdate
CompanyFilters_AfterUpdate_Exit:
Exit Sub
CompanyFilters_AfterUpdate_Err:
MsgBox Error$
Resume CompanyFilters_AfterUpdate_Exit
End Sub
Private Sub Open_Contacts_Subform3_Click()
On Error GoTo Err_Open_Contacts_Subform3_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Contact Details Subform2"
stLinkCriteria = "[CompanyID]=" & Me![CompanyID]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Open_Contacts_Subform3_Click:
Exit Sub
Err_Open_Contacts_Subform3_Click:
MsgBox Err.Description
Resume Exit_Open_Contacts_Subform3_Click
End Sub
'------------------------------------------------------------
' Command37_Click
'
'------------------------------------------------------------
Private Sub Command37_Click()
On Error GoTo Command37_Click_Err
DoCmd.OpenForm "Company Details Mainform1", acNormal, "", "", , acNormal
DoCmd.GoToRecord , "", acNewRec
DoCmd.GoToControl "Name"
Command37_Click_Exit:
Exit Sub
Command37_Click_Err:
MsgBox Error$
Resume Command37_Click_Exit
End Sub
Function GetLineNumber()
Dim RS As Recordset
Dim CountLines
Dim F As Form
Dim KeyName As String
Dim KeyValue
Set F = Form
KeyName = "companyid"
KeyValue = [CompanyID]
On Error GoTo Err_GetLineNumber
Set RS = F.RecordsetClone
' Find the current record.
Select Case RS.Fields(KeyName).Type
' Find using numeric data type key value.
Case DB_INTEGER, DB_LONG, DB_CURRENCY, DB_SINGLE, _
DB_DOUBLE, DB_BYTE
RS.FindFirst "[" & KeyName & "] = " & KeyValue
' Find using date data type key value.
Case DB_DATE
RS.FindFirst "[" & KeyName & "] = #" & KeyValue & "#"
' Find using text data type key value.
Case DB_TEXT
RS.FindFirst "[" & KeyName & "] = '" & KeyValue & "'"
Case Else
MsgBox "ERROR: Invalid key field data type!"
Exit Function
End Select
' Loop backward, counting the lines.
Do Until RS.BOF
CountLines = CountLines + 1
RS.MovePrevious
Loop
Bye_GetLineNumber: ' Return the result.
GetLineNumber = CountLines
Exit Function
Err_GetLineNumber:
CountLines = 0
Resume Bye_GetLineNumber
End Function
Private Sub Form_Click()
Me!ctlCurrentRecord = Me.SelTop
End Sub
Private Sub Form_Current()
Me!ctlCurrentRecord = Me.SelTop
End Sub
-------
If you would like to see a "print screen" clip of where this used, please forward me you email adress
I have a main form with a subform.
Currently, the subform list can be filtered alphabetically (by button choice)AND by favourability (ie. Most favourable, Favourable, Least favourable) (again by button). Each has the ALL button.
Hence I can look for a contact starting with a "M" and which belongs to my "Most Favourite" List.
I wish to expand the main form filtering to now have another two series of filters, namely;
1. Category (Consultant, Engineer, and so on)
2. State (ie.Australian States NSW, VIC, QLD, and so on)
So, on the main form, I have 4 filters working simultaneous.
I now have the ability to search for all the 1. Contractors that work in 2. NSW and that belong to my 3. "Favourite" List with 4. Alphabetically being "ALL".
or
I might not quite recall a contractor starting with 1. "K" that is a 2. "Engineer" that lives in 3. "VIC" state
I have the event procedure for the two filters being Favouribility and alphabetcally if that is of use.
I have tried over 6 months to get this and have failed - I'm not a developer.
To give you an example; here is the event procedure that was kindly given to me some time ago - the recipient of whom I have lost contact with.
-------
Extract
-------
ption Compare Database
Option Explicit
Private Sub CombineFilters(LetterFilter As String)
On Error GoTo CombineFilters_AfterUpdate_Err
'New function to mash two filter-sets together
Dim strStatusFilter As String
If (CompanyFilters = 1) Then
' Filter for Most Favourable List
'WKREM DoCmd.ApplyFilter "", "[StatusGreen] = 1"
strStatusFilter = "[StatusGreen] = True"
End If
If (CompanyFilters = 2) Then
' Filter for BOTH Most Favourable List AND Favourable List
'WKREM DoCmd.ApplyFilter "", "[StatusGreen] = 1 Or [StatusOrange] = 1"
strStatusFilter = "[StatusGreen] = True Or [StatusOrange] = True"
End If
If (CompanyFilters = 3) Then
' Filter for Favourable List
strStatusFilter = "[StatusOrange] = True"
End If
If (CompanyFilters = 4) Then
' Filter for Least Favourable List
strStatusFilter = "[StatusRed] = True"
End If
If (CompanyFilters = 5) Then
strStatusFilter = ""
End If
If IsNull(strStatusFilter) = False And Len(strStatusFilter) > 0 Then
'if a statusFilter selected then...
If Len(LetterFilter) > 0 Then
'if a LetterFilter selected then...
DoCmd.ApplyFilter "", LetterFilter & " And (" & strStatusFilter & ")"
Else
'if NO LetterFilter (eg Show All Letters) selected then...
DoCmd.ApplyFilter "", strStatusFilter
End If
Else
'if NO statusFilter selected (eg Show All Statuses) then...
'if a LetterFilter selected then...
If Len(LetterFilter) > 0 Then
DoCmd.ApplyFilter "", LetterFilter
Else
'if NO LetterFilter OR StatusFilter then...
DoCmd.ShowAllRecords
End If
End If
If (RecordsetClone.RecordCount > 0) Then
' If records are returned for the selected letter, go to the Keyword control.
DoCmd.GoToControl "Name"
' Stop the macro.
Exit Sub
End If
If (RecordsetClone.RecordCount = 0) Then
' If no records are returned for the selected list, display a message.
MsgBox "There are no records for that listing.", vbInformation, "No Records Returned"
' Show all records.
DoCmd.ShowAllRecords
' Press in the All button for both filter buttons
CompanyFilters = 5
CompanyFilterByLetter = 27
End If
CombineFilters_AfterUpdate_Exit:
Exit Sub
CombineFilters_AfterUpdate_Err:
MsgBox Error$
Resume CombineFilters_AfterUpdate_Exit
End Sub
Private Sub CompanyFilterByLetter_AfterUpdate()
On Error GoTo CompanyFilterByLetter_AfterUpdate_Err
'This function has been converted to produce a string value of the appropriate filter
'This is then passed to the above CombineFilters function
Dim strLetterFilter As String
If (CompanyFilterByLetter = 1) Then
' Filter for company names that start with A, À, Á, Â, Ã, or Ä.
strLetterFilter = "[Name] Like ""[AÀÁÂÃÄ]*"""
End If
If (CompanyFilterByLetter = 2) Then
' B
strLetterFilter = "[Name] Like ""B*"""
End If
If (CompanyFilterByLetter = 3) Then
' C or Ç
strLetterFilter = "[Name] Like ""[CÇ]*"""
End If
If (CompanyFilterByLetter = 4) Then
' D
strLetterFilter = "[Name] Like ""D*"""
End If
If (CompanyFilterByLetter = 5) Then
' E, È, É, Ê, or Ë
strLetterFilter = "[Name] Like ""[EÈÉÊË]*"""
End If
If (CompanyFilterByLetter = 6) Then
' F
strLetterFilter = "[Name] Like ""F*"""
End If
If (CompanyFilterByLetter = 7) Then
' G
strLetterFilter = "[Name] Like ""G*"""
End If
If (CompanyFilterByLetter = 8) Then
' H
strLetterFilter = "[Name] Like ""H*"""
End If
If (CompanyFilterByLetter = 9) Then
' I, Ì, Í, Î, or Ï
strLetterFilter = "[Name] Like ""[IÌÍÎÏ]*"""
End If
If (CompanyFilterByLetter = 10) Then
' J
strLetterFilter = "[Name] Like ""J*"""
End If
If (CompanyFilterByLetter = 11) Then
' K
strLetterFilter = "[Name] Like ""K*"""
End If
If (CompanyFilterByLetter = 12) Then
' L
strLetterFilter = "[Name] Like ""L*"""
End If
If (CompanyFilterByLetter = 13) Then
' M
strLetterFilter = "[Name] Like ""M*"""
End If
If (CompanyFilterByLetter = 14) Then
' N, or Ñ
strLetterFilter = "[Name] Like ""[NÑ]*"""
End If
If (CompanyFilterByLetter = 15) Then
' O, Ò, Ó, Ô, Õ, or Ö
strLetterFilter = "[Name] Like ""[OÒÓÔÕÖ]*"""
End If
If (CompanyFilterByLetter = 16) Then
' P
strLetterFilter = "[Name] Like ""P*"""
End If
If (CompanyFilterByLetter = 17) Then
' Q
strLetterFilter = "[Name] Like ""Q*"""
End If
If (CompanyFilterByLetter = 18) Then
' R
strLetterFilter = "[Name] Like ""R*"""
End If
If (CompanyFilterByLetter = 19) Then
' S or Š (S hacek)
strLetterFilter = "[Name] Like ""[SŠ]*"""
End If
If (CompanyFilterByLetter = 20) Then
' T
strLetterFilter = "[Name] Like ""T*"""
End If
If (CompanyFilterByLetter = 21) Then
' U, Ù, Ú, Û, or Ü
strLetterFilter = "[Name] Like ""[UÙÚÛÜ]*"""
End If
If (CompanyFilterByLetter = 22) Then
' V
strLetterFilter = "[Name] Like ""V*"""
End If
If (CompanyFilterByLetter = 23) Then
' W
strLetterFilter = "[Name] Like ""W*"""
End If
If (CompanyFilterByLetter = 24) Then
' X
strLetterFilter = "[Name] Like ""X*"""
End If
If (CompanyFilterByLetter = 25) Then
' Y, Ý, or ÿ
strLetterFilter = "[Name] Like ""[YÝÿ]*"""
End If
If (CompanyFilterByLetter = 26) Then
' Z, Æ, Ø, or Å
strLetterFilter = "[Name] Like ""[ZØÅ]*"""
End If
If (CompanyFilterByLetter = 27) Then
strLetterFilter = ""
End If
'Mash the two filter-sets together via CombineFilters function
Call CombineFilters(strLetterFilter)
CompanyFilterByLetter_AfterUpdate_Exit:
Exit Sub
CompanyFilterByLetter_AfterUpdate_Err:
MsgBox Error$
Resume CompanyFilterByLetter_AfterUpdate_Exit
End Sub
Private Sub More_Details_Button_Click()
On Error GoTo Err_More_Details_Button_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Company Details Mainform1"
stLinkCriteria = "[CompanyID]=" & Me![CompanyID]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_More_Details_Button_Click:
Exit Sub
Err_More_Details_Button_Click:
MsgBox Err.Description
Resume Exit_More_Details_Button_Click
End Sub
Private Sub Close_Button_Click()
On Error GoTo Err_Close_Button_Click
DoCmd.Close
Exit_Close_Button_Click:
Exit Sub
Err_Close_Button_Click:
MsgBox Err.Description
Resume Exit_Close_Button_Click
End Sub
'------------------------------------------------------------
' CompanyFilters_AfterUpdate
'
'------------------------------------------------------------
Private Sub CompanyFilters_AfterUpdate()
On Error GoTo CompanyFilters_AfterUpdate_Err
'Moved all code into CombineFilters function
'Call to CompanyFilterByLetter_AfterUpdate to grab the letter filter string and then mash the
'filters together via CombineFilters
Call CompanyFilterByLetter_AfterUpdate
CompanyFilters_AfterUpdate_Exit:
Exit Sub
CompanyFilters_AfterUpdate_Err:
MsgBox Error$
Resume CompanyFilters_AfterUpdate_Exit
End Sub
Private Sub Open_Contacts_Subform3_Click()
On Error GoTo Err_Open_Contacts_Subform3_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Contact Details Subform2"
stLinkCriteria = "[CompanyID]=" & Me![CompanyID]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Open_Contacts_Subform3_Click:
Exit Sub
Err_Open_Contacts_Subform3_Click:
MsgBox Err.Description
Resume Exit_Open_Contacts_Subform3_Click
End Sub
'------------------------------------------------------------
' Command37_Click
'
'------------------------------------------------------------
Private Sub Command37_Click()
On Error GoTo Command37_Click_Err
DoCmd.OpenForm "Company Details Mainform1", acNormal, "", "", , acNormal
DoCmd.GoToRecord , "", acNewRec
DoCmd.GoToControl "Name"
Command37_Click_Exit:
Exit Sub
Command37_Click_Err:
MsgBox Error$
Resume Command37_Click_Exit
End Sub
Function GetLineNumber()
Dim RS As Recordset
Dim CountLines
Dim F As Form
Dim KeyName As String
Dim KeyValue
Set F = Form
KeyName = "companyid"
KeyValue = [CompanyID]
On Error GoTo Err_GetLineNumber
Set RS = F.RecordsetClone
' Find the current record.
Select Case RS.Fields(KeyName).Type
' Find using numeric data type key value.
Case DB_INTEGER, DB_LONG, DB_CURRENCY, DB_SINGLE, _
DB_DOUBLE, DB_BYTE
RS.FindFirst "[" & KeyName & "] = " & KeyValue
' Find using date data type key value.
Case DB_DATE
RS.FindFirst "[" & KeyName & "] = #" & KeyValue & "#"
' Find using text data type key value.
Case DB_TEXT
RS.FindFirst "[" & KeyName & "] = '" & KeyValue & "'"
Case Else
MsgBox "ERROR: Invalid key field data type!"
Exit Function
End Select
' Loop backward, counting the lines.
Do Until RS.BOF
CountLines = CountLines + 1
RS.MovePrevious
Loop
Bye_GetLineNumber: ' Return the result.
GetLineNumber = CountLines
Exit Function
Err_GetLineNumber:
CountLines = 0
Resume Bye_GetLineNumber
End Function
Private Sub Form_Click()
Me!ctlCurrentRecord = Me.SelTop
End Sub
Private Sub Form_Current()
Me!ctlCurrentRecord = Me.SelTop
End Sub
-------
If you would like to see a "print screen" clip of where this used, please forward me you email adress
