Related
I created a connection to REST API using PowerQuery in Excel2016 and it gets me information about companies.
In a certain query table, after the results are loaded, there is a column with ID of the company. Now, i want to be able to click on some id and this could be passed to my new query with this id as a parameter in a header. My connection string looks like this:
let
Source = Json.Document(Web.Contents("https://rejestr.io/api/v1/persons/"& Excel.CurrentWorkbook(){[Name="ID"]}[Content]{0}[Column1] &"/relations", [Headers=[Authorization="xxxxxxxxx"]]))
<..rest of the code, mainly formatting...>
in
"ColumnChanged"
Here im referencing the ID from a certain cell (user provided), but i want to be able to pass in this place a value from just selected cell on ID column and then a new query should be created and loaded onto a new worksheet.
I was thinking about this function to "get" a value cell from that column:
Worksheet_SelectionChange(ByVal Target As Range)
But i cannot figure out how to launch a new power query with that...
Alex
Generally, the idea is to avoid manipulating Power Query code directly via VBA (since you cannot be sure the result will be syntactically valid in M).
However, you genuinely seem to want to create a separate new sheet and query each time the user clicks an ID.
I therefore suggest you ignore my previous answer/approach and try the code below. I can't test the code (since I don't have my own credentials for this rejestr.io API) but I think it should work:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Intersect(Target.Parent.Range("ID"), Target) Is Nothing Then Exit Sub
' If there is any additional validation required (e.g. if the ID should be numeric,
' or should satisfy some condition/criteria) then it should be done here
' before proceeding to code below.
Dim idSelected As String
idSelected = Target.Value
Dim targetQuery As WorkbookQuery
Set targetQuery = GetOrCreateQueryFromId(idSelected)
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets.Add
Dim targetTable As ListObject
Set targetTable = targetSheet.ListObjects.Add( _
SourceType:=0, _
Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & targetQuery.Name & ";Extended Properties=""""", _
Destination:=targetSheet.Range("$A$1") _
)
With targetTable.QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & targetQuery.Name & "]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "_" & targetQuery.Name
.Refresh BackgroundQuery:=False
End With
End Sub
Private Function GetOrCreateQueryFromId(ByVal someId As String) As WorkbookQuery
' Should accept an ID and return the existing WorkbookQuery object.
' If no query for the ID exists, this function should create one (and then
' return the newly created query).
Dim targetQuery As WorkbookQuery
On Error Resume Next
Set targetQuery = ThisWorkbook.Queries(someId)
On Error GoTo 0
Dim queryAlreadyExists As Boolean
queryAlreadyExists = Not (targetQuery Is Nothing)
Dim queryFormula As String
queryFormula = CreateQueryFormulaFromId(someId)
If queryAlreadyExists Then
targetQuery.Formula = queryFormula
Set GetOrCreateQueryFromId = targetQuery
Exit Function
End If
Set GetOrCreateQueryFromId = ThisWorkbook.Queries.Add(Name:=someId, Formula:=queryFormula)
End Function
Private Function CreateQueryFormulaFromId(ByVal someId As String) As String
' Given an ID, should return the Power Query code (code only) required to get data for that ID.
' This function returns the code itself only. It doesn't create the query object.
CreateQueryFormulaFromId = _
"let" & Chr(13) & "" & Chr(10) & _
" Source = Json.Document(Web.Contents(""https://rejestr.io/api/v1/krs/" & someId & "/relations"", [Headers=[Authorization=""x""]]))," & Chr(13) & "" & Chr(10) & _
" #""Converted to Table"" = Table.FromList(Source, Splitter.SplitByNothing(), null, null, ExtraValues.Error), " & Chr(13) & "" & Chr(10) & _
" #""Expanded Column1"" = Table.ExpandRecordColumn(#""Converted to Table"", ""Column1"", {""address"", ""business_insert_date"", ""ceo"", ""current_relations_count"", ""data_fetched_at"", ""first_entry_date"", ""historical_relations_count"", ""id"", ""is_opp"", ""is_removed"", ""krs"", ""last_entry_date"", ""last_entry_no"", ""last_state_entry_date"", ""last_state_entry_no"", ""legal_form"", ""name"", ""name_short"", ""nip"", ""regon"", ""type"", ""w_likwidacji"", ""w_upadlosci"", ""w_zawieszeniu"", ""relations"", ""birthday"", ""first_name"", ""krs_person_id"", ""last_name"", ""organizations_count"", ""second_names"", ""sex""}, " & _
"{""Column1.address"", ""Column1.business_insert_date"", ""Column1.ceo"", ""Column1.current_relations_count"", ""Column1.data_fetched_at"", ""Column1.first_entry_date"", ""Column1.historical_relations_count"", ""Column1.id"", ""Column1.is_opp"", ""Column1.is_removed"", ""Column1.krs"", ""Column1.last_entry_date"", ""Column1.last_entry_no"", ""Column1.last_state_entry_date"", ""Column1.last_state_entry_no"", ""Column1.legal_form"", ""Column1.name"", ""Column1.name_short"", ""Column1.nip"", ""Column1.regon"", ""Column1.type"", ""Column1.w_likwidacji"", ""Column1.w_upadlosci"", ""Column1.w_zawieszeniu"", ""Column1.relations"", ""Column1.birthday"", ""Column1.first_name"", ""Column1.krs_person_id"", ""Column1.last_name"", ""Column1.organizations_count"", ""Column1.second_names"", ""Column1.sex""})" & Chr(13) & "" & Chr(10) & _
"in" & Chr(13) & "" & Chr(10) & _
" #""Expanded Column1"""
End Function
If that is a genuine API key/credential in your question, then you may want to have the server provider revoke/change it (so that nobody can consume this service API using your credentials).
There is no error handling implemented and currently the user's input is not validated/sanitised in any way.
Hi I implemented your method. However i encountered 2 problems:
When I run the macro when im clicking on defined range and query is added, range is being "shortened" to only the field i just clicked on. So the "idselected" instead of A2:A10 now becames just A2...
The query is sucessfully added and parameter is succesfully passed but when i ran the query and the new sheet is added, the error occurs:
"The worksheet data for a table needs to be on the same sheet as the table"
My final VBA code looks like this now:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Intersect(Target.Parent.Range("Range5"), Target) Is Nothing Then Exit Sub
With ThisWorkbook
.Names("Range5").RefersTo = Target
.Queries.Add Name:="2-1_1", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Json.Document(Web.Contents(""https://rejestr.io/api/v1/krs/"" & Excel.CurrentWorkbook(){[Name=""Range5""]}[Content]{0}[Column1] & ""/relations"", [Headers=[Authorization=""xxxxxxx""]]))," & Chr(13) & "" & Chr(10) & " #""Converted to Table"" = Table.FromList(Source, Splitter.SplitByNothing(), null, null, ExtraValues.Error), " & Chr(13) & "" & Chr(10) & " #""Expanded Column1"" = Table.ExpandRecordColumn(#""Con" & _
"verted to Table"", ""Column1"", {""address"", ""business_insert_date"", ""ceo"", ""current_relations_count"", ""data_fetched_at"", ""first_entry_date"", ""historical_relations_count"", ""id"", ""is_opp"", ""is_removed"", ""krs"", ""last_entry_date"", ""last_entry_no"", ""last_state_entry_date"", ""last_state_entry_no"", ""legal_form"", ""name"", ""name_short"", ""nip"", ""regon"", ""type"", ""w_likwidacji"", ""w_upadlo" & _
"sci"", ""w_zawieszeniu"", ""relations"", ""birthday"", ""first_name"", ""krs_person_id"", ""last_name"", ""organizations_count"", ""second_names"", ""sex""}, {""Column1.address"", ""Column1.business_insert_date"", ""Column1.ceo"", ""Column1.current_relations_count"", ""Column1.data_fetched_at"", ""Column1.first_entry_date"", ""Column1.historical_relations_count"", ""Column1.id"", ""Column1.is_opp"", ""Column1.is_rem" & _
"oved"", ""Column1.krs"", ""Column1.last_entry_date"", ""Column1.last_entry_no"", ""Column1.last_state_entry_date"", ""Column1.last_state_entry_no"", ""Column1.legal_form"", ""Column1.name"", ""Column1.name_short"", ""Column1.nip"", ""Column1.regon"", ""Column1.type"", ""Column1.w_likwidacji"", ""Column1.w_upadlosci"", ""Column1.w_zawieszeniu"", ""Column1.relations"", ""Column1.birthday"", ""Column1.first_name"", ""Column1.krs_person_id"", ""Column1.last_name"", ""Column1.organizations_count"", ""Column1.second_names"", ""Column1.sex""})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Expanded Column1"""
ActiveWorkbook.Worksheets.Add
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=2-1_1;Extended Properties=""""" _
, Destination:=Range("$S$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [2-1_1]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "_2_1_1"
.Refresh BackgroundQuery:=False
End With
End With
I inherited the database from the guy who left, and have been trying to run maintenance and add functionality as required. I should say that when I stared this job 3 weeks ago, I had absolutely no coding experience, but have picked up things here and there. On to the problem:
The main form has a table nested in there, and the filters were basically set up to filter out and play with the data in the table. I'll try and attach a picture on imugr and add the link (EDIT:http://imgur.com/nHUsCdX)
There are a number of filters and search boxes on the left side. This includes:
A text search box (search through Column A)
A Date search box
Group Filter - searches in Group column, and filters out based on chosen value.
Trending - a filter that basically fills up the Date Search Box (2) with pre-set dates for earnings quarters.
Region Filter - works the same way as Group Filter (3), except search in the region column.
The following lines of code more or less governs these filters and search boxes, i'll post it in its entirety.
Private Sub frmFieldPresets_AfterUpdate()
Dim fieldPreset As String
Select Case Me.frmFieldPresets
Case 1
fieldPreset = "Audit"
DoCmd.OpenForm "frm_Fields"
Call Forms.frm_Fields.cmd_De_SelectAllFields_Click
Forms.frm_Fields.chk_EN.Value = True
Forms.frm_Fields.chk_BLI.Value = True
Forms.frm_Fields.chk_AN.Value = True
Forms.frm_Fields.chk_EDD.Value = True
Forms.frm_Fields.chk_GIIC.Value = True
Forms.frm_Fields.chk_NILGIC.Value = True
Forms.frm_Fields.chk_RDTTO.Value = True
Forms.frm_Fields.chk_ESB.Value = True
Call Forms.frm_Fields.refreshFields
DoCmd.Close acForm, "frm_Fields"
Case 2
fieldPreset = "CMRM"
DoCmd.OpenForm "frm_Fields"
Call Forms.frm_Fields.cmd_De_SelectAllFields_Click
Forms.frm_Fields.chk_BLI.Value = True
Forms.frm_Fields.chk_AN.Value = True
Forms.frm_Fields.chk_OID.Value = True
Forms.frm_Fields.chk_EN.Value = True
Forms.frm_Fields.chk_GIIC.Value = True
Forms.frm_Fields.chk_NILGIC.Value = True
Forms.frm_Fields.chk_RDTTO.Value = True
Forms.frm_Fields.chk_EDD.Value = True
Call Forms.frm_Fields.refreshFields
DoCmd.Close acForm, "frm_Fields"
Case 3
fieldPreset = "Finance"
DoCmd.OpenForm "frm_Fields"
Call Forms.frm_Fields.cmd_De_SelectAllFields_Click
Forms.frm_Fields.chk_EN.Value = True
Forms.frm_Fields.chk_RDTTO.Value = True
Forms.frm_Fields.chk_BLI.Value = True
Forms.frm_Fields.chk_GIIC.Value = True
Forms.frm_Fields.chk_NILGIC.Value = True
Call Forms.frm_Fields.refreshFields
DoCmd.Close acForm, "frm_Fields"
Case 4
fieldPreset = "TBM"
DoCmd.OpenForm "frm_Fields"
Call Forms.frm_Fields.cmd_De_SelectAllFields_Click
Forms.frm_Fields.chk_EN.Value = True
Forms.frm_Fields.chk_BLI.Value = True
Forms.frm_Fields.chk_AN.Value = True
Forms.frm_Fields.chk_RDTTO.Value = True
Forms.frm_Fields.chk_GIIC.Value = True
Forms.frm_Fields.chk_NILGIC.Value = True
Forms.frm_Fields.chk_EDD.Value = True
Call Forms.frm_Fields.refreshFields
DoCmd.Close acForm, "frm_Fields"
Exit Sub
End Select
End Sub
Private Sub frmRegions_AfterUpdate()
Call refresh_Filters
End Sub
Private Function regionselection()
Select Case Me.frmRegions
Case 1
regionselection = "Canada"
Case 2
regionselection = "USA"
Case 3
regionselection = "Singapore"
Case 4
regionselection = "Europe & Asia Pacific"
Case 5
regionselection = "Global"
End Select
End Function
Private Sub frmTrendingQuarters_AfterUpdate()
Dim fieldPreset As String
Select Case Me.frmTrendingQuarters
Case 1
txtDate1.Value = "11/1/2014"
txtDate2.Value = "1/31/2015"
fieldPreset = "Q1"
Case 2
txtDate1.Value = "2/1/2015"
txtDate2.Value = "4/30/2015"
fieldPreset = "Q2"
Case 3
txtDate1.Value = "5/1/2015"
txtDate2.Value = "7/31/2015"
fieldPreset = "Q3"
Case 4
txtDate1.Value = "8/1/2015"
txtDate2.Value = "10/30/2015"
fieldPreset = "Q4"
Exit Sub
End Select
DoCmd.OpenForm "frm_Fields"
Call Forms.frm_Fields.cmd_De_SelectAllFields_Click
Forms.frm_Fields.chk_OID.Value = True
Forms.frm_Fields.chk_EN.Value = True
Forms.frm_Fields.chk_FWCO.Value = True
Forms.frm_Fields.chk_Reg.Value = True
Forms.frm_Fields.chk_RC.Value = True
Forms.frm_Fields.chk_Rem1.Value = True
Forms.frm_Fields.chk_Rem2.Value = True
Forms.frm_Fields.chk_RDTTO.Value = True
Call Forms.frm_Fields.refreshFields
DoCmd.Close acForm, "frm_Fields"
Call refresh_Filters
End Sub
Private Sub txtDate1_AfterUpdate()
Call refresh_Filters
End Sub
Private Sub txtDate2_AfterUpdate()
Call refresh_Filters
End Sub
Private Sub txtSearch_AfterUpdate()
Call refresh_Filters
End Sub
Private Sub refresh_Filters()
Dim searchFilter, dateFilter, allFilter As String
Dim searchString, date1String, date2String As String
Me.Refresh
If IsNull(Me.txtSearch) Then
searchString = "*"
Else
searchString = Me.txtSearch
End If
If IsNull(Me.txtDate1) Then
date1String = "1/1/2000"
Else
date1String = Me.txtDate1
End If
If IsNull(Me.txtDate2) Then
date2String = "1/1/2020"
Else
date2String = Me.txtDate2
End If
searchFilter = "(" & "[Event Name] Like '*" & searchString & "*'" & ")"
regionFilter = "(" & "[Region] Like '*" & regionselection & "*'" & ")"
dateFilter = "(" & "[OpERA Create Date] Between " & "#" & date1String & "#" & " AND " & "#" & date2String & "#" & ")"
allFilter = searchFilter & " And " & dateFilter & " And " & regionFilter
Me.frm_ORE_All.Form.Filter = allFilter
Me.frm_ORE_All.Form.FilterOn = True
End Sub
Now the part I need help with is the last few lines of code. At some point, I was told the parameters for textSearch, which was only looking in one column (Event Name), needed to be expanded to include additional columns. So the search would expand to look through more columns. So I changed the code for searchFilter, and added more columns to it.
This is the UPDATED code, the last few lines.
'searchFilter = "(" & "[Event Name] Like '*" & searchString & "*'" & ")"
searchFilter = "(" & "[Event Name] Like '*" & searchString & "*'" & ") OR (" & "[Event Submitted By] Like '*" & searchString & "*'" & ") OR (" & "[Organizational Business Unit] Like '*" & searchString & "*'" & ") OR (" & "[Business Line Impacted] Like '*" & searchString & "*'" & ") OR (" & "[Attester Name] Like '*" & searchString & "*'" & ") OR (" & "[Comments] Like '*" & searchString & "*'" & ") OR (" & "[Function Where Cause Occurred] Like '*" & searchString & "*'" & ") OR (" & "[Root Cause] Like '*" & searchString & "*'" & ") OR (" & "[Remedy 1] Like '*" & searchString & "*'" & ") OR (" & "[Remedy 2] Like '*" & searchString & "*'" & ")"
regionFilter = "(" & "[Region] Like '*" & regionselection & "*'" & ")"
dateFilter = "(" & "[OpERA Create Date] Between " & "#" & date1String & "#" & " AND " & "#" & date2String & "#" & ")"
allFilter = searchFilter & " And " & dateFilter & " And " & regionFilter
Me.frm_ORE_All.Form.Filter = allFilter
Me.frm_ORE_All.Form.FilterOn = True
End Sub
Once I slot in this new line of code for searchFilter, and decommission the original one, it works perfectly. EXCEPT the other filters stop working for whatever reason. So while GroupFilters still work, Trending and RegionFilter stop working altogether.
If I switch back in the original line of code, and decommission the new one, everything starts working fine again (except the fact that the textboxsearch goes back to searching through one column only).
I'm sure it's just inefficiency in my code, or something glaringly obvious that you'll spot when I don't. Any tips?
This is about operator precedence and how the computer combines your various Or and And statements. Try putting your new searchFilter inside a set of brackets. So,
searchFilter = "((" & "[Event Name] ... [Remedy 2] Like '*" & searchString & "*'" & "))"
This will make sure that your new tests get treated as a single unit with the result of that unit then added to the other tests using the And operator.
A filter on a form is essentially the WHERE clause of a SQL statement.
The problem is that you are missing parentheses in your search string SQL.
The code you are running is this:
Filter = ([Event Name] Like '*SEARCH*')
OR ([Event Submitted By] Like '*SEARCH*')
OR ([Organizational Business Unit] Like '*SEARCH*')
OR ([Business Line Impacted] Like '*SEARCH*')
...
OR ([Remedy 2] Like '*SEARCH*')
AND ([Region] Like '*REGIONSEARCH*')
AND ([OpERA Create Date] Between #DATE1# AND #DATE2#)
What you intend to do is have all of the "OR" statements determined together and then also have the AND statements, but what the code is actually doing is this:
Filter = ([Event Name] Like '*SEARCH*')
OR ([Event Submitted By] Like '*SEARCH*')
OR ([Organizational Business Unit] Like '*SEARCH*')
OR ([Business Line Impacted] Like '*SEARCH*')
...
OR **(** ([Remedy 2] Like '*SEARCH*')
AND ([Region] Like '*REGIONSEARCH*')
AND ([OpERA Create Date] Between #DATE1# AND #DATE2#) **)**
Add the parentheses to the search string to get the appropriate filter:
Filter = **(** ([Event Name] Like '*SEARCH*')
OR ([Event Submitted By] Like '*SEARCH*')
OR ([Organizational Business Unit] Like '*SEARCH*')
OR ([Business Line Impacted] Like '*SEARCH*')
...
OR ([Remedy 2] Like '*SEARCH*') **)**
AND ([Region] Like '*REGIONSEARCH*')
AND ([OpERA Create Date] Between #DATE1# AND #DATE2#)
Surround the search clause in parentheses and this should fix the problem.
I have a master form which contains three list boxes and one sub form. I would like to build a routine which allows me to switch links between the sub form and the three list boxes. Is this possible? Or do i have to create three copies of the same sub form and hide two while one the other is activated?
To be practical, my form will work like this: The sub form contains a list of records of people participating in a project, their specific role, and which internal team they come from. I would like to use three list boxes to allow the user to filter this form by either:
(1) All participants coming from a certain team
(2) All participants by roles (titles)
(3) Filter by name of particants
Where I am short is on how to re-link the filter on the sub form so that it changes from list box to list box as the user passes from filter to filter.
Using Krish's suggestion below as a simple test i am trying the following code but am getting a compilation error message on the recordsource line stating that it is impossible to find the method or the data member.. Not sure what that means:
Private Sub lstRoles_AfterUpdate()
Dim SQL_GET As String
SQL_GET = "SELECT * from tblProjectGovernanceResources where ((role like '" & lstRoles.Value & "')"
Me.frmProjectGovernanceResources.RecordSource = SQL_GET
End Sub
you can retrieve the selected value from a listbox simply byt listbox1.value.
As Wayne G pointed. you would add a code in your listbox_after_update event to update your subform's recordsource.
something like:
dim SQL_GET as string
sql_get = "SELECT * from tbl_myTAble where ((condition like '" & listbox1.value & "') OR (condition2 like '"& listbox2.value &"') OR (condition3_number like "& listbox3.value &"))
me.mysubform.recordsource = sql_Get
obviously you need to improve this as per your requirements.
Try this and for a better answer, produce what you have coded so far..
I created some code for the easiest version possible. This means all of your listboxes have the 'multi select' property set to 'None' (this means you can't select multiple items in the list and you can't 'deselect' an item by clicking on it again. I did add some code at the end so you can see how a different multi-select option may work.
My form has three listboxes, a subform, and two buttons. One button will clear all selections in all listboxes. The other button applies the filter to the subform.
Option Compare Database
Option Explicit
'*** NOTE!!! THIS CODE ASSUMES YOU HAVE SET YOUR LISTBOX PROPERTY to 'NONE'.
' IF YOU SET 'MULTI SELECT' To 'SIMPLE' or 'EXTENDED', you MUST use different code to find all selected items.
Dim strWhereTeam As String
Dim strWhereRole As String
Dim strWhereParticipant As String
Private Sub cmdClear_Click()
' Clear all selections in all listboxes
Dim i As Integer
For i = 0 To Me.lstParticipant.ListCount 'Deselect ALL rows in Listbox
lstParticipant.Selected(i) = False
Next i
For i = 0 To Me.lstRole.ListCount 'Deselect ALL rows in Listbox
lstRole.Selected(i) = False
Next i
For i = 0 To Me.lstTeam.ListCount 'Deselect ALL rows in Listbox
lstTeam.Selected(i) = False
Next i
strWhereTeam = ""
strWhereRole = ""
strWhereParticipant = ""
Me.MySubForm.Form.Filter = "" ' Reste filter to NONE
Me.MySubForm.Form.FilterOn = False
End Sub
Private Sub cmdFilter_Click()
'Build Filter (concatenate three selections)
Dim strFilter As String
strFilter = ""
If strWhereTeam & "" <> "" Then
strFilter = strWhereTeam
If strWhereRole & "" <> "" Then
strFilter = strFilter & " AND " & strWhereRole
If strWhereParticipant & "" <> "" Then
strFilter = strFilter & " AND " & strWhereParticipant
End If
Else
If strWhereParticipant & "" <> "" Then
strFilter = strFilter & " AND " & strWhereParticipant
End If
End If
ElseIf strWhereRole & "" <> "" Then
strFilter = strWhereRole
If strWhereParticipant & "" <> "" Then
strFilter = strFilter & " AND " & strWhereParticipant
End If
ElseIf strWhereParticipant & "" <> "" Then
strFilter = strWhereParticipant
End If
If strFilter = "" Then
Me.MySubForm.Form.Filter = ""
Me.MySubForm.Form.FilterOn = False
Else
Me.MySubForm.Form.Filter = strFilter
Me.MySubForm.Form.FilterOn = True
End If
End Sub
Private Sub lstParticipant_Click()
strWhereParticipant = "[Participant] = '" & Me.lstParticipant.ItemData(Me.lstParticipant.ListIndex) & "'"
Debug.Print strWhereParticipant
End Sub
Private Sub lstRole_Click()
strWhereRole = "[Role] = '" & Me.lstRole.ItemData(Me.lstRole.ListIndex) & "'"
Debug.Print strWhereRole
End Sub
Private Sub lstTeam_Click()
If Me.lstTeam.MultiSelect <> 0 Then
MsgBox "You have set the 'Multi Select' property to either Simple or Extended. This code may not work!", vbOKOnly + vbCritical, "ListBox MultiSelect not 'None'"
End If
strWhereTeam = "[Team] = '" & Me.lstTeam.ItemData(Me.lstTeam.ListIndex) & "'"
Debug.Print strWhereTeam
'Simple_Code
End Sub
'' Sample code if set 'Multi Select' to 'Simple' or 'Extended'
'Sub Simple_Code()
' Dim var As Variant
' strWhereTeam = ""
' For Each var In Me.lstTeam.ItemsSelected
' strWhereTeam = strWhereTeam & "[Team] = '" & Me.lstTeam.ItemData(var) & "' OR "
' Next var
' strWhereTeam = "(" & left(strWhereTeam, Len(strWhereTeam) - 4) & ")"
' Debug.Print strWhereTeam
'End Sub
Thanks a lot! This did it all!
Private Sub lstRoles_AfterUpdate()
Dim SQL_GET As String
SQL_GET = "SELECT * from tblProjectGovernanceResources where ([role] = '" & lstRoles.Value & "')"
Me.frmProjectGovernanceResources.Form.RecordSource = SQL_GET
End Sub
I have a database. In this i have hundreds of tables,macros and forms.
No my problem is i have to find what all queries,macros that are related to specific table.
I'm using microsoft acess 2000.
But i even i tried objet dependencies in access 2007, it showed plenty of errors and close automatically.
Is this there any easy way to get this???
Thanks,
Shanmugam
You can try to execute SQL Query against system tables directly to get dependencies that are shown in 2003+ versions in more user-friendly way. I am not sure if that works on 2000 (it does in 2003+) but it is worth trying:
SELECT DISTINCT MSysObjects.Name
FROM MSysQueries INNER JOIN MSysObjects ON MSysQueries.ObjectId=MSysObjects.Id
WHERE (((MSysQueries.Name1) Like "*" & [TableName] & "*")) OR (((MSysQueries.Name2) Like "*" & [TableName] & "*"))
You may need to check if you have permissions to access system tables...
Hope this helps
You can buy third-party software that will do this for you, but I've never felt the need for that. Instead, I wrote a couple of procedures that will do this. They require a reference to DAO.
The first one (SearchQueries) searches the text of queries only and runs quite fast. The second (SearchDB) searches forms, macros, queries, reports, and code. It takes a bit longer but is very thorough. The usage should be pretty self-explanatory but ask questions if you're unsure of anything.
Here's the full text of the procedures:
Sub SearchQueries(SearchText As String, _
Optional ShowSQL As Boolean = False, _
Optional QryName As String = "*")
On Error Resume Next
Dim QDef As QueryDef
For Each QDef In CurrentDb.QueryDefs
If QDef.Name Like QryName Then
If InStr(QDef.SQL, SearchText) > 0 Then
Debug.Print QDef.Name
If ShowSQL Then Debug.Print QDef.SQL & vbCrLf
End If
End If
Next QDef
End Sub
'Updated: 1/19/09 Limit search by object name pattern
Sub SearchDB(SearchText As String, _
Optional ObjType As AcObjectType = acDefault, _
Optional ObjName As String = "*")
Dim db As Database, obj As AccessObject, Ctl As Control, Prop As Property
Dim Frm As Form, Rpt As Report, mdl As Module
Dim objLoaded As Boolean, Found As Boolean, Instances As Long
Dim SLine As Long, SCol As Long, ELine As Long, ECol As Long
On Error GoTo Err_SearchDB
Set db = CurrentDb
Application.Echo False
'===============================================
'Search queries
If ObjType = acDefault Or ObjType = acQuery Then
Debug.Print "Queries:"
SearchQueries SearchText, False, ObjName
Debug.Print vbCrLf
End If
'===============================================
'Search forms
If ObjType = acDefault Or ObjType = acForm Then
Debug.Print "Forms:"
On Error Resume Next
For Each obj In CurrentProject.AllForms
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not obj.IsLoaded Then DoCmd.OpenForm obj.Name, acDesign, , , , acHidden
Set Frm = Application.Forms(obj.Name)
For Each Prop In Frm.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Form: " & Frm.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
If Frm.HasModule Then
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = Frm.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = Frm.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print "Form: " & Frm.Name & _
" Module: " & Instances & " instances"
End If
For Each Ctl In Frm.Controls
For Each Prop In Ctl.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Form: " & Frm.Name & _
" Control: " & Ctl.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
Next Ctl
Set Frm = Nothing
If Not objLoaded Then DoCmd.Close acForm, obj.Name, acSaveNo
DoEvents
End If
Next obj
On Error GoTo Err_SearchDB
Debug.Print vbCrLf
End If
'===============================================
'Search modules
If ObjType = acDefault Or ObjType = acModule Then
Debug.Print "Modules:"
For Each obj In CurrentProject.AllModules
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not objLoaded Then DoCmd.OpenModule obj.Name
Set mdl = Application.Modules(obj.Name)
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = mdl.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = mdl.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print obj.Name & ": " & Instances & " instances"
Set mdl = Nothing
If Not objLoaded Then DoCmd.Close acModule, obj.Name
End If
Next obj
Debug.Print vbCrLf
End If
'===============================================
'Search macros
If ObjType = acDefault Or ObjType = acMacro Then
'Debug.Print "Macros:"
'Debug.Print vbCrLf
End If
'===============================================
'Search reports
If ObjType = acDefault Or ObjType = acReport Then
Debug.Print "Reports:"
On Error Resume Next
For Each obj In CurrentProject.AllReports
If obj.Name Like ObjName Then
objLoaded = obj.IsLoaded
If Not obj.IsLoaded Then DoCmd.OpenReport obj.Name, acDesign
Set Rpt = Application.Reports(obj.Name)
For Each Prop In Rpt.Properties
Err.Clear
If InStr(Prop.Value, SearchText) > 0 Then
If Err.Number = 0 Then
Debug.Print "Report: " & Rpt.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
End If
Next Prop
If Rpt.HasModule Then
SLine = 0: SCol = 0: ELine = 0: ECol = 0: Instances = 0
Found = Rpt.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Do Until Not Found
Instances = Instances + 1
SLine = ELine + 1: SCol = 0: ELine = 0: ECol = 0
Found = Rpt.Module.Find(SearchText, SLine, SCol, ELine, ECol)
Loop
If Instances > 0 Then Debug.Print "Report: " & Rpt.Name & _
" Module: " & Instances & " instances"
End If
For Each Ctl In Rpt.Controls
For Each Prop In Ctl.Properties
If InStr(Prop.Value, SearchText) > 0 Then
Debug.Print "Report: " & Rpt.Name & _
" Control: " & Ctl.Name & _
" Property: " & Prop.Name & _
" Value: " & Prop.Value
End If
Next Prop
Next Ctl
Set Rpt = Nothing
If Not objLoaded Then DoCmd.Close acReport, obj.Name, acSaveNo
DoEvents
End If
Next obj
On Error GoTo Err_SearchDB
Debug.Print vbCrLf
End If
Exit_SearchDB:
Application.Echo True
Exit Sub
Err_SearchDB:
Application.Echo True
Debug.Print Err.Description
Debug.Assert False
Resume
End Sub
For others who find this page as I did, below is a variation that includes occurences of a string, in all queries' tables or expressions. (This worked in both Access 2003 and Access 2013.)
SELECT DISTINCT
MSysObjects.Name, MSysQueries.Name1, MSysQueries.Name2, MSysQueries.Expression
FROM
MSysQueries
INNER JOIN
MSysObjects ON MSysQueries.ObjectId = MSysObjects.Id
WHERE
( (((MSysQueries.Name1) Like "*" & [String to search for] & "*"))
OR (((MSysQueries.Name2) Like "*" & [String to search for] & "*"))
OR (((MSysQueries.Expression) Like "*" & [String to search for] & "*")) )
And "Comment: You will be prompted once, for the [String to search for]"<>""
And "Comment: The starting point for this code came from link:"<>
"http://stackoverflow.com/questions/7831071/how-to-find-all-queries-related-to-table-in-ms-access# "
;
SELECT DISTINCT
MSysObjects.Name, MSysQueries.Name1, MSysQueries.Name2, MSysQueries.Expression
FROM
MSysQueries
INNER JOIN
MSysObjects ON MSysQueries.ObjectId = MSysObjects.Id;
This gave me a table of everything I was looking for. Thanks Igor.
This is by no means essential, but I would like to find out how to create more efficient code, and i'm sure this is far from efficient!
On the form disabled fields values are cleared before the form is saved.
The below code send a message to the user to inform them that they may lose some data if they leave a checkbox unchecked.
In the context of the form it all makes sense, i would just like to know a simpler methodology, i'm sure i could use an array somewhere but cant quite figure it out.
Dim couldLoseData As Boolean
Dim msgStr As String
couldLoseData = False
If (Me.chkInvSent = False) And (Not IsNull(Me.invoicedDate)) Then
couldLoseData = True
msgStr = "Invoice Sent"
End If
If (Me.chkFeePaid = False) And (Not IsNull(Me.datePaid)) Then
couldLoseData = True
If msgStr = "" Then
msgStr = "Claim Fee Paid"
Else
msgStr = msgStr & " / Claim Fee Paid"
End If
End If
If (Me.chkFeeLodged = False) And (Not IsNull(Me.lodgedDate)) Then
couldLoseData = True
If msgStr = "" Then
msgStr = "Fee Lodged"
Else
msgStr = msgStr & " / Fee Lodged"
End If
End If
If couldLoseData = True Then
If MsgBox("You will lose data in the following areas as the relevant checkboxes are unticked." & vbNewLine & vbNewLine & _
msgStr & vbNewLine & vbNewLine & "Do you wish to continue?", vbYesNo, dbNameOf) = vbNo Then
Cancel = True
End If
Else
'
'
'
' Procedure that gets carried out here
End If
No biggie but if any one could offer me a simpler solution it would be appreciated.
Cheers
Noel
I'm not sure why you think you should be using arrays. When it comes to the msgStr variable logic I would just put in the following:
msgStr = msgStr & "Invoice Sent / "
rather than the five lines of If msgstr = "" Then, etc, etc, End If lines.
Then at the end I would put in the following line
msgStr = lef(msgStr, len(msgStr) - 3) ' remove the trailing /
This then removes the trailing " / "
Purists will tell you that you should never add anything to a string you later remove. I say, so long as you leave a comment there for the next person who is reading your code, this reduces complexity of your preceding lines of code making it much easier to grasp exactly what is going on.
Whenever I'm looking for a value to be returned from a MsgBox I place the string creating in a separate line of code. Thus is much easier to see, at a glance, exactly what the code is doing.
strMsg = "You will lose data in the following areas as the relevant checkboxes are unticked." & vbNewLine & vbNewLine & _
msgStr & vbNewLine & vbNewLine & "Do you wish to continue?"
If MsgBox(strMsg, vbYesNo, dbNameOf) <> vbYes Then _
Cancel = True
If I'm only setting one value in the If statement, such as you show, I will also put in the _ and thus not require the End If.
I also prefer <> vbYes just in case something wonky should happen or if someone, not you of course, mucks with the msgbox options.
Why do you even allow the user to close the form when all the data fields have not been filled out?
Basically, to me, your logic is all in the wrong place. If you have a CLOSE button on your form (assuming you've gotten rid of the default Windows CLOSE X), you would not enable it until such time as all the data fields have been filled out appropriately.
The way I usually do this is to write a subroutine (or function) that checks all the fields that have to be filled out and enables the CLOSE button if everything is in order. Thus, the user CAN'T close the form until all the appropriate fields are filled out, except, perhaps, if you've provided a CANCEL button (in which case, you WANT to lose the data).
You don't need arrays but a simple helper method to simplify code and make it more reusable:
(just replace checkboxes and conditions in the following code)
Public Function ErrorChecker(assumption As Boolean, errorMessage As String, condition As Boolean, concatenate As Boolean) As String
Dim ret As String = [String].Empty
If Not assumption AndAlso condition Then
If concatenate Then
ret += " / "
End If
ret += errorMessage
End If
Return ret
End Function
Private Sub button1_Click(sender As Object, e As EventArgs)
Dim message As String = [String].Empty
message += ErrorChecker(checkBox1.Checked, "Error 1", value1 Is Nothing, False)
message += ErrorChecker(checkBox2.Checked, "Error 2", value2 Is Nothing, True)
message += ErrorChecker(checkBox3.Checked, "Error 3", value3 Is Nothing, True)
If message <> String.Empty Then
'messagebox
End If
End Sub
I've written a simple function to concatenate two strings that eliminates the need to worry about whether you need to strip anything off when you're done concatenating. Here's the function:
'-----------------------------------------------------------------------------
' Purpose : Concatenates two strings
' Usage : Dim MyList As String
' MyList = Conc(MyList, SomeValue)
' Notes : Eliminates the need to strip off the leading/trailing delimiter
' when building a string list
'-----------------------------------------------------------------------------
Function Conc(StartText As String, NextVal, _
Optional Delimiter As String = ", ") As String
If Len(StartText) = 0 Then
Conc = Nz(NextVal)
ElseIf Len(CStr(Nz(NextVal))) = 0 Then
Conc = StartText
Else
Conc = StartText & Delimiter & NextVal
End If
End Function
And here's how I'd rewrite your code using this function:
Dim msgStr As String
If (Me.chkInvSent = False) And (Not IsNull(Me.invoicedDate)) Then
msgStr = Conc(msgStr, "Invoice Sent", " / ")
End If
If (Me.chkFeePaid = False) And (Not IsNull(Me.datePaid)) Then
msgStr = Conc(msgStr, "Claim Fee Paid", " / ")
End If
If (Me.chkFeeLodged = False) And (Not IsNull(Me.lodgedDate)) Then
msgStr = Conc(msgStr, "Fee Lodged", " / ")
End If
If Len(msgStr) > 0 Then
If MsgBox("You will lose data in the following areas as the relevant checkboxes are unticked." & vbNewLine & vbNewLine & _
msgStr & vbNewLine & vbNewLine & "Do you wish to continue?", vbYesNo, dbNameOf) <> vbYes Then
Cancel = True
End If
Else
' Procedure that gets carried out here
End If
This is how I'd code it up
Dim couldLoseData As Boolean
Dim msgStr As String
Dim InvBoolean as boolean
Dim PaidBoolean as boolean
Dim LodgedBoolean as boolean
Dim response as integer
couldLoseData = False
InvBoolean = (Me.chkInvSent = False) And (Not IsNull(Me.invoicedDate))
PaidBoolean = (Me.chkFeePaid = False) And (Not IsNull(Me.datePaid))
LodgedBoolean = (Me.chkFeeLodged = False) And (Not IsNull(Me.lodgedDate))
couldLoseData = InvBoolean or PaidBoolean or LodgeBoolean
'if any one is true, there could be lost data.
if couldLoseData = false then
exit sub 'bail if nothing applies
'you may want a GOTO if there is stuff this sub needs to do regardless
end if
If InvBoolean = true then 'add phrase and move to new line
msgStr = msgStr & "Invoice Sent" & vbcrlf
end if
If PaidBoolean = true then 'add phrase and move to new line
msgStr = msgStr & "Claim Fee Paid" & vbcrlf
end if
If LodgedBoolean = true then 'add phrase and move to new line
msgStr = msgStr & "Fee Lodged" & vbcrlf
end if
If couldLoseData = True Then
msgStr = "You will lose data in the following areas as the relevant checkboxes are unticked." & vbcrlf & msgStr & vbcrlf
msgStr = msgStr & "Do you wish to continue?"
response = msgbox(msgstr, vbYesNo)
if response = vbno then
Cancel = True
End If
end if
If you really were looking to use an array:
Dim couldLoseData As Boolean
Dim msgStr As String
Dim ConditionsResponses(0 to 2,1)
Dim x as integer
Dim response as integer
couldLoseData = False
ConditionsResponses(0,0) = (Me.chkInvSent = False) And (Not IsNull(Me.invoicedDate))
ConditionsResponses(1,0) = (Me.chkFeePaid = False) And (Not IsNull(Me.datePaid))
ConditionsResponses(2,0) = (Me.chkFeeLodged = False) And (Not IsNull(Me.lodgedDate))
ConditionsResponses(0,1) = "Invoice Sent" & vbcrlf
ConditionsResponses(1,1) = "Claim Fee Paid" & vbcrlf
ConditionsResponses(2,1) = "Fee Lodged" & vbcrlf
couldLoseData = ConditionsResponses(0,0) or ConditionsResponses(0,0) or ConditionsResponses(0,0)
'if any one is true, there could be lost data.
for x = 0 to 2
if ConditionsResponses(x,0)= true then
msgStr = msgStr & ConditionsResponses(x,1)
end if
next x
If couldLoseData = True Then
msgStr = "You will lose data in the following areas as the relevant checkboxes are unticked." & vbcrlf & msgStr & vbcrlf
msgStr = msgStr & "Do you wish to continue?"
response = msgbox(msgstr, vbYesNo)
if response = vbno then
Cancel = True
End If
end if