I am wondering if it is possible to have a dynamic enumeration.
Explanation: I have a function to add errors to an error log in ms access. The categories in my Enum variable are all in a table. If I use the function and enum as depicted below, it works just fine. The problem is however, that there is a possibility that the categories will change with time.
Enum category
Category1 = 1
Category2 = 2
etc... = n
End Enum
Public Function AddError(Current_order_ID As Long, Optional Error_Category As category)
'Add the error to the log
End Function
I have noticed that using DLookups and recordsets and actually everything in general will not work. While compiling, it throws an 'Invalid inside Enum'. Consulting MSDN gives me the following information: You tried to specify a string or some other invalid type as the value of an Enum member. The constant expression used to specify an Enum member must evaluate to type Long or another Enum type.
This tells me that an enum can hold only long types, hence the numbers, but also other Enum types.
What I am looking for: Is there some workaround, or method, to loop through a recordset or query and pass the values on to an array, and dynamically assign these values to an enumeration. Or perhaps it can be done by changing the source code/vba text itself?
Note: I know that there are a lot of other ways to add my errors to a log and I am able to do so, but for know I am just wondering if this is even possible to do.
I am looking forward to your reactions.
The Recordset loops through a table containing the Enum types. Basically this is editing a modules VBA code.
Public Function CreateEnum()
Dim db As Database
Dim rs As Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("MYENUMS", dbOpenSnapshot)
Dim m As Module
Dim s As String
Set m = Modules("myEnumsModule")
s = "Option Compare Database"
s = s & vbNewLine & "Option Explicit"
s = s & vbNewLine
s = s & vbNewLine & "Public Enum MyEnums"
With rs
Do Until .EOF
s = s & vbNewLine & vbTab & .Fields("MYENUM") & " = " & rs.Fields("MYENUM_ID")
.MoveNext
Loop
End With
s = s & vbNewLine & "End Enum"
Call m.DeleteLines(1, m.CountOfLines)
Call m.AddFromString(s)
End Function
While an Enum type cannot be changed at runtime, a variable of that type can actually store any Long value.
Enum category
Category1 = 1
Category2 = 2
End Enum
Sub error(err As category)
Debug.Print err
End Sub
Sub test()
Dim category3 As Long: category3 = 3
Call error(category3) ' prints "3"
End Sub
But no, you cannot declare or update an Enum at runtime, nor convert an array to an Enum.
Related
I am currently trying to upgrade an old ADP project from Access 2010 x64 to Access 2019 x64. I have managed to convert it to an .accdb file, but are now running into errors with my VBA code.
Please consider the following function:
Public Function GetSystemSetting(sKey As String, vValue As Variant) As Boolean
Dim cnTemp As ADODB.Connection, rsTemp As ADODB.Recordset
Dim sSQL As String
On Error GoTo LAB_Error
sSQL = "SELECT T_Value FROM INT_SystemSettings WHERE (T_Key = '" & sKey & "')"
Set cnTemp = New ADODB.Connection
Set rsTemp = New ADODB.Recordset
cnTemp.CursorLocation = adUseServer
cnTemp.Open CurrentProject.BaseConnectionString
rsTemp.Open sSQL, cnTemp, adOpenForwardOnly, adLockReadOnly
If (rsTemp.EOF) Then GoTo LAB_Error
vValue = Nz(rsTemp![T_Value])
rsTemp.Close
cnTemp.Close
On Error GoTo 0
GetSystemSetting = True
Exit Function
LAB_Error:
vValue = Null
If (rsTemp.State <> adStateClosed) Then rsTemp.Close
If (cnTemp.State <> adStateClosed) Then cnTemp.Close
GetSystemSetting = False
End Function
I know that this code is questionable in many aspects, but would like to focus on the line
vValue = Null
When this line gets executed, a runtime error is raised:
Invalid use of Null
I have read dozens of articles about that error message on various sites, including this one, but it always boiled down to that the OP hadn't made the destination variable a variant. But in my case, the destination variable, vValue, is of type variant. Furthermore, that code ran since 8 years without any problem in Access 2010 x64.
What is the reason for that error, and how can I prevent it?
It is important to remember that with functions like this:
Public Function GetSystemSetting(sKey As String, vValue As Variant) As Boolean
vValue = Null
unless you specify ByVal, the parameters are passed ByRef, and so you are actually writing to the variable that is used as parameter when calling the function.
If that variable isn't a variant, the error is triggered.
Dim str As String
If GetSystemSetting("non-existing", str) Then ' KA-BOOM!
An alternative with DLookup would be the following. It should behave exactly the same, unless you have valid SystemSettings that are NULL.
Public Function GetSystemSetting(sKey As String, vValue As Variant) As Boolean
' DLookup returns NULL if no record is found
vValue = DLookup("T_Value", "INT_SystemSettings", "T_Key = '" & sKey & "'")
GetSystemSetting = Not IsNull(vValue)
End Function
DLookup is a read-only operation, so it should be the same regarding locking.
I came upon this (modified) function in a Stack Overflow page and have been trying to get it to work without giving up on the passed object (if I handle the Access.Application strictly within the first routine it will work).
Yes I know of a number of ways to get the same answer (mostly from other posts on the stack), but there is a general concept here of passing objects to functions that I would like to master--please forget for a moment that the function checks the existence of a table.
Function FCN_CheckTblsExist(theDatabase As Access.Application, _
tableName As String) As Boolean
'access.Application.CurrentData.AllTables.Count
'etc is the 'workaround enabling disposal of
'the "theDatabase" object variable
' Presume that table does not exist.
FCN_CheckTblsExist = False
' Define iterator to query the object model.
Dim iTable As Integer
' Loop through object catalogue and compare with search term.
For iTable = 0 To theDatabase.CurrentData.AllTables.Count - 1
If theDatabase.CurrentData.AllTables(iTable).Name = tableName Then
FCN_CheckTblsExist = True
Exit Function
End If
Next iTable
End Function
Function callFCN_CheckTblsExist(tableName As String)
'this is an example of a curried function?--step down in dimensionality
Dim bo0 As String
Dim A As Object
Set A = CreateObject("Access.Application")
bo0 = FCN_CheckTblsExist(A, tableName)
MsgBox tableName & " Exists is " & bo0
End Function
I don't know if the (theDatabase As Access.Application, . ) part is correct, that may be the root of the problem, rather than the Dim, Set, Object (New?) gymnastics that may be required in the auxiliary procedure. Maybe there is a reference library problem (I'm running Access 2013).
Update: I am not sure the following is robust enough but this is what I meant earlier in the post, which is just being put here for completeness. BTW, this is not a split application so maybe that is why the following works. I appreciate HansUp's post, Not enough can be said on this subject. Anyway
Public Function FCN_CheckTblsExist(tableName As String) As Boolean 'Call this function once for every table
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim appAccess As New Access.Application
Dim theDatabase As Access.Application
' Presume that table does not exist.
FCN_CheckTblsExist = False
' Define iterator to query the object model.
Dim iTable As Integer
For iTable = 0 To Access.Application.CurrentData.AllTables.Count - 1
If Access.Application.CurrentData.AllTables(iTable).Name = tableName Then
FCN_CheckTblsExist = True
Exit Function
End If
Next iTable
End Function
Just wanted to add that this last function I posted technically would be considered to be partial or no currying depending on how much the scope of the function was limited by invoking "Access.Application.CurrentData.AllTables." as a substitute for "theDatabase", only substituting the specific string created by Access.Application.CurrentDb.Name into the original function ...(theDatabse,... would it be a true full currying.
Anyway passing objects to functions and the libraries and their methods are the primary focus of this discussion. When I get the DAO issue worked i should have a better feel for what may be going on and then I'll post and mark the best solution accordingly.
The problem is not really about passing an Access.Application object to your other function. Instead you create the Access.Application and later check for the existence of a table without having opened a database within that Access session. In that situation, theDatabase.CurrentData.AllTables.Count should trigger error
2467, "The expression you entered refers to an object that is closed or doesn't exist."
I revised both procedures and tested them in Access 2010. Both compile and run without errors and produce the result I think you want.
Function FCN_CheckTblsExist(theDatabase As Access.Application, _
tableName As String) As Boolean
Dim tdf As DAO.TableDef
Dim blnReturn As Boolean
blnReturn = False
For Each tdf In theDatabase.CurrentDb.TableDefs
If tdf.Name = tableName Then
blnReturn = True
Exit For
End If
Next ' tdf
FCN_CheckTblsExist = blnReturn
End Function
Function callFCN_CheckTblsExist(DbPath As String, tableName As String)
Dim bo0 As Boolean
Dim A As Object
Set A = CreateObject("Access.Application")
A.OpenCurrentDatabase DbPath
bo0 = FCN_CheckTblsExist(A, tableName)
MsgBox tableName & " Exists is " & bo0
Debug.Print tableName & " Exists is " & bo0
A.Quit
Set A = Nothing
End Function
Note I didn't include any provision to check whether the DbPath database exists before attempting to open it. So you will get an error if you give it a path for a database which does not exist.
DAO Reference Issues:
DAO 3.6 was the last of the older DAO series. It only supports the older MDB type databases. When Access 2007 introduced the ACCDB database type, a new DAO library (Access database engine Object Library, sometimes referred to as ACEDAO) was introduced. In addition to supporting ACCDB databases, ACEDAO can also support the older MDB types.
When setting references, don't attempt to choose both.
Here is a screenshot of my project references:
When I examine my project references in the Immediate window, notice that ACEDAO is even referred to as just DAO. I also ran the callFCN_CheckTblsExist procedure to demonstrate it works without a DAO 3.6 reference:
That was all based on Access 2010. You're using Access 2013, so your ACEDAO version number may be different, but everything else should be the same.
Here are a couple of solutions along with a much simpler way to check if a table exists:
Workspace/Database; (much faster than using Application)
Function TestFunction_DataBase()
Dim ws As Workspace
Dim db As Database
Set ws = CreateWorkspace("", "admin", "", "dbUseJet")
Set db = ws.OpenDatabase("the db path", , , CurrentProject.Connection)
MsgBox TdefExists_DataBase(db, "the table name")
db.Close
ws.Close
Set db = Nothing
Set ws = Nothing
End Function
Function TdefExists_DataBase(ac As Database, strTableName As String) As Boolean
'check to see if table exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = ac.TableDefs(strTableName).Name
TdefExists_DataBase = True
Exit Function
ErrHandler:
TdefExists_DataBase = False
End Function
Application:
Function TestFunction_Application()
Dim ac As New Access.Application
ac.OpenCurrentDatabase "the db path"
MsgBox TdefExists_Application(ac, "the table name")
ac.Quit
Set ac = Nothing
End Function
Function TdefExists_Application(ac As Access.Application, strTableName As String) As Boolean
'check to see if table exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = ac.CurrentDb.TableDefs(strTableName).Name
TdefExists_Application = True
Exit Function
ErrHandler:
TdefExists_Application = False
End Function
Within the Current Database:
Function TdefExists(strName As String) As Boolean
'check to see if query exists
On Error GoTo ErrHandler
Dim strBS As String
strBS = CurrentDb.TableDefs(strName).Name
TdefExists = True
Exit Function
ErrHandler:
TdefExists = False
End Function
I have written a couple of VBA functions which in the end return a Collection of Integers:
Public Function ValidIDs() As Collection
Now I want to run create a query in the QueryEditor with the following condition: WHERE TableID IN ValidIDs(). That does not work since access for some reason does not even find my function as long as it returns a Collection. Therefore I wrote a wrapper around it, which joins the Collection:
Public Function joinCollectionForIn(Coll As Collection) As String
Now a third function which calls ValidIDs(), passes the result to joinCollectionForIn and returns that result. Lets call it GetIDCollectionAsString().
As a result I can now change my query to WHERE TableID IN (GetIDCollectionAsString()). Note the added parenthesis since the IN needs them in any case, they can not just be at the end and the beginning of the String returned by GetID....
Running that query however results in
Data type mismatch in criteria expression.
I guess that results from the fact that I return a String, therefore access automatically wraps that string in ' for the SQL and the IN-clause no longer works because I would check if a number is IN a collection of 1 string.
Therefore my question is:
Is there a way to prevent access from wrapping the returned string for the SQL
or (would be a whole lot better):
Is there an already existing way to pass a collection or array to the WHERE IN-clause?
P.S.: I am currently using a workaround by writing a placeholder in the parenthesis following the IN (e.g. IN (1,2,3,4,5)) and replacing that placeholder in Form_Load with the result of GetIDCollectionAsString() - that works but it is not pretty...
Edit: The final query should look like SELECT * FROM TestTable t WHERE t.ID IN (1,2,3,4,5,6,7). That actually works using above method, but not in a nice way.
Well this required more work than it seems.... i couldn't find a straight solution so here is a workaround
Public Function ListforIn(inputString As String) As String
Dim qdf As QueryDef
Dim valCriteria As String
Dim strsql As String
Dim splitcounter As Byte
Dim valcounter As Byte
Set qdf = CurrentDb.QueryDefs(**TheNameOfQueryYouWantToModify**)
strsql = qdf.sql
strsql = Replace(strsql, ";", "") 'To get rid of ";"
splitcounter = Len(inputString) - Len(Replace(inputString, ",", ""))
For valcounter = 0 To splitcounter
valCriteria = valCriteria & ValParseText(inputString, valcounter, ",")
Next
strsql = strsql & " WHERE TableId IN (" & Left(valCriteria, Len(valCriteria) - 1) & ")"
qdf.sql = strsql
End Function
Public Function ValParseText(TextIn As String, X As Byte, Optional MyDelim As String) As Variant
On Error Resume Next
If Len(MyDelim) > 0 Then
ValParseText = "Val(" & (Split(TextIn, MyDelim)(X)) & "),"
Else
ValParseText = Split(TextIn, " ")(X)
End If
End Function
Take for example this code:
sSQL = "select CtyMarket from Market where Country = '" & Country.Value & "'"
Set rec = CurrentDb.OpenRecordset(sSQL)
This statement can return more than one value. How can I access those values?
well, in order to get all the values you could browse both fields and records in your recordset. It could look like that:
'You'll need to declare a new variable
Dim i as long
If rec.EOF and rec.BOF then
Else
do while not rec.EOF
for i = 0 to rec.fields.count - 1
debug.print rec.fields(i).value
next i
rec.movenext
loop
endif
Other ways to get your data would be to use the getrows and\or getstring metyhods of the recordset object, but I do not remember if these are available with DAO recordsets. You could also set a filter for a specific value on a specific field, etc
I use this function to not care about NULL values when reading recordsets:
Public Function toStr(pVar_In As Variant) As String
On Error Resume Next
toStr = CStr(pVar_In)
End Function
Never trust the exact amount of rec.recordcount but rec.RecordCount>0 is safe. That's why you should never use a for loop when using a recordset. If you'd like to know the recordcount anyway what you have to do first is rec.movelast and then rec.movefirst
There are two different ways that I know of:
While not rec.eof
msgbox toStr(rec!CtyMarket)
rec.moveNext
Wend
or
While not rec.eof
msgbox toStr(rec.fields("CtyMarket").value)
rec.moveNext
Wend
I am creating a bill of materials program.
There are two main tables named Products and Sub_Products.
In the Products table, the fields are (Product_Name, Code).
In the Sub_Products table, the fields are (Code, Sub_Name).
The tables are linked with code, i.e.: one product is made up of many sub_products, each sub_product is a product as well, making it have many sub_products.
I have created a query that reads a product and gets its sub_products. I need a query to compare Sub_Name with Product_Name and then check more sub_products,
continuing until no more sub_products are found.
Any ideas?
I guess you will have to use a script rather than SQL query to loop through them. Assuming that the products can be nested more than 3 levels.
I've been working on this exact problem in an ASP.NET MVC application. A function that gathered all the subproducts for each product and recursed on each subproduct worked well. We have some BOMs that are 15 levels deep.
I realize this question was asked a long time ago, but I had a very similar question and finally figured out a good answer. So I am posting it here in case anyone needs to know how to create a Bill of Materials.
In my example there is a table called "Part_Item_Table" which lists parent items and all of their childeren. Those childeren can also be parents to other childeren. The difficulty was that the BOM could be 3 levels deep all the way up to 30 levels deep or more. My "Part_Item_Table" also lists whether items are "Make" items or not. Only "Make" items will have childeren. The table you are querying may not have that feature, but the code below will probably still be helpful to get the idea.
This set of code uses several things that were new to me such as recursive code, calling a query I had already created and passing in a variable using the querydef methods, and using recordsets to get large information sets in and out of functions. I also used a sequence field in my BOM Table so I could sort by it and view the BOM in the order it is meant to be (Showing visually which level 3 items roll up into which level 2 items). If there is something that can be improved I am open to suggestions. This does work for my needs right now and hopefully it is helpful to someone else.
Option Compare Database
Public stFirstPart As String
Private Const BOMTable As String = "BOM_Table" 'Set this variable to the name of the table
Private Const ComponentQ As String = "GetComponentsQ" 'Set to the name of the query in the database
Function BOM()
Dim stQuery As String 'Used to make a query
Dim i As Integer 'Used to create the sequence number
Dim iLevel As Integer 'Used to show BOM level
Dim rsParent, rsBOMTable As DAO.Recordset 'Used to hold query results
'Make sure there is a part number in the form
If IsNull(Forms![Entry Form]![Part_Number]) Then
Debug.Print "There is no part number entered in the form"
MsgBox "There is no part number in the form.", vbOKOnly, "Can't fool me."
Exit Function
End If
stFirstPart = Forms![Entry Form]![Part_Number] 'Get the top part number from the form
'Make sure this is a Make item. Only make items will have childeren
stQuery = "SELECT ITEM.ITEM_NO, ITEM.MAKE_BUY_FLAG, ITEM.CURRENT_FLAG " & _
" FROM PART_ITEM_TABLE AS ITEM " & _
" WHERE (((ITEM.ITEM_NO)='" & stFirstPart & "') AND ((ITEM.MAKE_BUY_FLAG)='M') AND ((ITEM.CURRENT_FLAG)='Y'));"
Set rsParent = CurrentDb.OpenRecordset(stQuery)
If rsParent.EOF And rsParent.BOF Then
Debug.Print "This is not a make item"
MsgBox "This is not a Make item.", vbOKOnly, "I tried."
Exit Function
End If
'Clear the BOM table and load this first part number
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete from " & BOMTable & ""
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
i = 1
iLevel = 1
rsParent.MoveFirst
With rsBOMTable
.AddNew
!Sequence = i
!Level = iLevel
!Item_Number = stFirstPart
!Make_Buy = "M"
.Update
End With
rsParent.Close
Set rsParent = Nothing
rsBOMTable.Close
Set rsBOMTable = Nothing
'-----------------------------------------------------------------------------------------------------------------------------------
'Start going down levels
'-----------------------------------------------------------------------------------------------------------------------------------
iLevel = 2
Call RecursiveLevels(stFirstPart, iLevel, i)
DoCmd.SetWarnings True
End Function
Function RecursiveLevels(PartNumber As String, iLevel As Integer, i As Integer)
Dim rsLevels As DAO.Recordset
Dim stPart As String
Set rsLevels = GetComponents(PartNumber)
If rsLevels.BOF And rsLevels.EOF Then
Debug.Print "This was a Make item with no children. That shouldn't happen. "; PartNumber
GoTo ExitPoint
End If
rsLevels.MoveFirst
Do While Not rsLevels.EOF
If rsLevels!Make_Buy <> "M" Then ' Anything that is not a Make item is written to the BOM table one line at a time.
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
Else 'The Make item is written to the table, then we query for all of its children
stPart = rsLevels!Component_Number
i = i + 1
Call WriteToBOMTable(iLevel, i, rsLevels!Parent_Number, rsLevels!Component_Number, rsLevels!Make_Buy)
If stPart = stFirstPart Then 'Check to make sure this recursive thing doesn't go on forever.
Debug.Print "This part number is the same as the first part number. Circ Reference. "; stPart
GoTo ExitPoint
End If
iLevel = iLevel + 1 ' get ready to go one level deeper
Call RecursiveLevels(stPart, iLevel, i)
End If
rsLevels.MoveNext
Loop
ExitPoint:
iLevel = iLevel - 1 'Done with this level. Come back up a level.
rsLevels.Close
Set rsLevels = Nothing
End Function
Function WriteToBOMTable(Level As Integer, i As Integer, ParentNumber As String, ComponentNumber As String, MakeBuy As String)
Dim rsBOMTable As DAO.Recordset
Set rsBOMTable = CurrentDb.OpenRecordset(BOMTable, dbOpenDynaset)
With rsBOMTable
.AddNew
!Parent_Number = ParentNumber
!Item_Number = ComponentNumber
!Level = Level
!Make_Buy = MakeBuy
!Sequence = i
.Update
End With
Debug.Print "Level: "; Level; "Component: "; ComponentNumber
rsBOMTable.Close
Set rsBOMTable = Nothing
End Function
Function GetComponents(PartNumber As String) As DAO.Recordset
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs(ComponentQ)
qdf.Parameters("PartNumber") = PartNumber
Set GetComponents = qdf.OpenRecordset
End Function