Context: In Microsoft Access, I'm trying to call functions and pass parameters, dynamically, using Application.Run. My code below works in Excel 2013 but does not work in Access 2013.
Code:
Public Sub Test()
Call MethodDynamically("MethodToBeCalled1", "This", "works")
Call MethodDynamically("MethodToBeCalled2", "This", "works", "too")
Call MethodDynamically("MethodToBeCalled3", "This", "works", "too", "as well")
End Sub
Public Sub MethodDynamically(MethodName As String, ParamArray Params() as Variant)
Application.Run MethodName, Params
End Sub
Public Sub MethodToBeCalled1(Params As Variant)
Debug.Print Params(0) & " " & Params(1)
End Sub
Public Sub MethodToBeCalled2(Params As Variant)
Debug.Print Params(0) & " " & Params(1) & " " & Params(2)
End Sub
Public Sub MethodToBeCalled3(Params As Variant)
Debug.Print Params(0) & " " & Params(1) & " " & Params(2) & " " & Params(3)
End Sub
Returns output:
This works
This works too
This works too as well
Error: However in Microsoft Access, the same code gives the error: Compile error: Invalid ParamArray use.
Is there a way of adjusting this code for Access VBA?
You can't pass a ParamArray to another function directly.
Try the following:
Public Sub MethodDynamically(MethodName As String, ParamArray Params() as Variant)
Dim MyArray As Variant
MyArray = Params
Application.Run MethodName, MyArray
End Sub
Related
I'm parsing a JSON string similar to the solution at this link: Parse JSON with VBA (Access 2010). However, I'm getting the "subscript out of range" error.
Public Sub GetValues()
Dim s As String, rates(), i As Long
s = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
rates = Array("id", "class", "exchange", "symbol", "name", "status", "tradeable", "marginable", "shortable", "easy_to_borrow")
For i = LBound(rates) To UBound(rates)
Debug.Print rates(i) & ":" & GetRate(s, rates(i))
Next i
End Sub
Public Function GetRate(ByVal s As String, ByVal delimiter As String) As String
GetRate = Replace(Split(Split(s, delimiter & Chr$(34) & Chr$(58))(1), Chr$(44))(0), Chr$(125), vbNullString)
End Function
You have a typo in your code:
Public Sub GetValues()
Dim s As String, rates(), i As Long
'Just for better reading.
's = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"", _
""class"":""us_equity"", _
""exchange"":""ARCA"", _
""symbol"":""UVXY"", _
""name"":"""", _
""status"":""active"", _
""tradable"":true, _
""marginable"":true, _
""shortable"":false, _
""easy_to_borrow"":false}"
'""tradable"":true, _ <<<<< ERROR in s var. In your rate array you say: "tradeable"
' "tradeable", _ <<<<< rate Array! (I just change it to run the code)
s = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
rates = Array("id", _
"class", _
"exchange", _
"symbol", _
"name", _
"status", _
"tradable", _
"marginable", _
"shortable", _
"easy_to_borrow")
For i = LBound(rates) To UBound(rates)
Debug.Print rates(i) & ":" & GetRate(s, rates(i))
Next i
End Sub
Public Function GetRate(ByVal s As String, ByVal delimiter As String) As String
'Chr$(34) = "
'Chr$(58) = :
'Chr$(125) = }
'Again... better reading.
Dim A: A = Split(s, delimiter & Chr$(34) & Chr$(58))(1)
Dim B: B = Split(A, Chr$(44))(0)
Dim C: C = Chr$(125)
GetRate = Replace(B, C, vbNullString)
End Function
First of all the issue in your code is that you have a typo: In your JSON you have tradable but your rate is called tradeable.
I recommend to include a proper error handling in your function. So if something gets wrong there you don't get stuck but a error message instead.
I also recommend not to have everything in one line in your function like Replace(Split(Split(… because if something gets wrong you don't know in which part it went wrong: First or second Split or the Replace. So if you do that in multiple lines (see below) then you can return a more useful error message.
Shorter code is not necessarily faster and better. But code that is easily readable, debugable and maintainable is very good code because you will make less errors and find them quicker.
I highly recommend to use meaningful variable names. Names like s for example are very bad names. If you use Json instead you always immediately see that this variable contains your JSON string.
Meaningful variables make your code better because it is more human readable and VBA doesn't care about the extra 3 characters.
Finally I would declare variables as close as possible to their first use.
So the code below is a bit longer but has much more improved readability and an error handling that gives at least a proper info if the key word you were looking for did not exist in your JSON.
Option Explicit
Public Sub GetValues()
Dim Json As String
Json = "{""id"":""14acfa60-c0e1-47fb-8f80-ca0831bf3b52"",""class"":""us_equity"",""exchange"":""ARCA"",""symbol"":""UVXY"",""name"":"""",""status"":""active"",""tradable"":true,""marginable"":true,""shortable"":false,""easy_to_borrow"":false}"
Dim Rates() As Variant
Rates = Array("id", "tradeable", "class", "exchange", "symbol", "name", "status", "tradeable", "marginable", "shortable", "easy_to_borrow")
Dim i As Long
For i = LBound(Rates) To UBound(Rates)
Debug.Print Rates(i) & ":" & GetRate(Json, Rates(i))
Next i
End Sub
Public Function GetRate(ByVal Key As String, ByVal Delimiter As String) As String
On Error GoTo RETURN_ERR
Dim SplitKey() As String
SplitKey = Split(Key, Delimiter & Chr$(34) & Chr$(58))
If UBound(SplitKey) = 0 Then
GetRate = "KEY NOT FOUND"
Exit Function
End If
Dim ValueOfKey As String
ValueOfKey = Split(SplitKey(1), Chr$(44))(0)
'remove } from value
ValueOfKey = Replace(ValueOfKey, Chr$(125), vbNullString)
'return
GetRate = ValueOfKey
Exit Function
RETURN_ERR:
GetRate = "Unknown error while extracting value. Check the JSON syntax."
End Function
I try to open a form in another database by using GetObject. Unfortunately I have to open a second instance of the database, but I would like to use the active instance of that database instead (if loaded). TO accomplish this I need to set an object reference to the running instance of that db.
What I currently use is the function below. This function first tries to activate the running instance of the database using its screen name, and if this generates an error the database and the form are loaded. However, if the database is already loaded I want to be able to load the form as well.
On lesser problem is if the error procedure to load the db and form generates an error, the error routine is not followed. How should I manage that?
Anyone has an idea?
I'm Using Access 2016
Thx.
Peter
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
This is not an easy task, but it can be accomplished by using some WinAPI window functions.
Essentially, you want to get an Access Application object by using the window title.
I'm going to assume you haven't got any unicode characters in that window title, else, we'll need something a little more complex.
First, declare our WinAPI functions:
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
FindWindowExA is used to find the window with the specified title. AccessibleObjectFromWindow is used to get the COM object of that window.
Then, we declare some constants to be used for AccessibleObjectFromWindow:
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM As Long = &HFFFFFFF0 'To identify the object type
Then, we can write the function
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Dim hwndAppDb As LongPtr
hwndAppDb = FindWindowExA (,,,strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
Dim guid() As Byte
guid = Application.GuidFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
End If
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
I'm not going to discuss the point of chained error handlers, but you can just review this answer for that. Note that resetting the error handler resets the Err object as well, so you might first want to store error number and description if you want to use that.
This worked like a charm, thank you so much! I never figured this out by myself.
It seems that after an adjustment of the code there is no issue related to the nested errors too. I needed to add a maximize call because mu forms are showed related to the screen and this causes an invisible form when the other database was minimized. The final code is now
Option Compare Database
Option Explicit
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, _
Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, _
Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, _
ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM = &HFFFFFFF0 'To identify the object type
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
Dim hwndAppDb As LongPtr
'Find the Db handle
hwndAppDb = FindWindowExA(, , , strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
'Activate DB if open
Dim guid() As Byte
guid = Application.GUIDFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
Else
'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
End If
If Nz(strOpenForm, "") <> "" Then
objDb.RunCommand acCmdAppMaximize
objDb.DoCmd.OpenForm strOpenForm
objDb.Run "CenterForm", strOpenForm, False, False, False, 0
End If
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_OpenExtDb" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
Again, thank you!
Peter
i declared the global variable in the Module1 and when i was trying to use it in another module it is showing the runtime error '5':\invalid procedure call or argument. i was unable to find the problem please provied the solution for this problem
Declaring global variable:
Function getFilePath() As String
getFilePath = FilePath
Set FilePath = "C:\quadyster\R3AgreementDetails"
End Function
Implementing of globalvariable:
Private Sub SendAgreement_Click()
If (Not IsNull(Me.RequestFrom) And Not IsNull(Me.RequestReference)) Then
Call AttachR3ServiceAgreement(Module1.FilePath, tripObjectFormation, "Agreement")
Me.AgreementDate = Now()
Else
MsgBox "Please provide 'RequestFrom' and 'RequestReference' to proceed." & vbNewLine & vbNewLine & _
"Press Ok to continue.", vbOKOnly, "Alert!!!"
End If
End Sub
this is the calling function
Public Function AttachR3ServiceAgreement(FilePath As String, tripData As
tripDetails, requestType As String)
Here error is occured:
Set objStream = objFSO.OpenTextFile(fileHTML, ForReading)
You have a syntax error there: Set can only be used with objects.
Public FilePath As String
Function getFilePath() As String
FilePath = "C:\quadyster\R3AgreementDetails"
getFilePath = FilePath
End Function
Private Sub SendAgreement_Click()
If (Not IsNull(Me.RequestFrom) And Not IsNull(Me.RequestReference)) Then
Call AttachR3ServiceAgreement(Module1.FilePath, tripObjectFormation, "Agreement")
Me.AgreementDate = Now()
Else
MsgBox "Please provide 'RequestFrom' and 'RequestReference' to proceed." & vbNewLine & vbNewLine & _
"Press Ok to continue.", vbOKOnly, "Alert!!!"
End If
End Sub
I have a textbox that has a name ISCO68Code and ISCO68Title both are texts.
When I encode in ISCO68Code, a caption must appear on ISCO68Title that corresponds in my other table, libISCO1968.
Below is my Code Builder:
Private Sub ISCO68Code_AfterUpdate()
ISCO68Title = DLookup("ISCO68Code", "libISCO1968", "[ISCO68Code]=" & ISCO68Code&)
End Sub
Sadly, I got an error message:
Compile error: Type-declaration character does not match declared data
type.
Any help will do.
You need the quotes telling that the variable is text:
Private Sub ISCO68Code_AfterUpdate()
ISCO68Title = Nz(DLookup("ISCO68Code", "libISCO1968", "[ISCO68Code]='" & ISCO68Code & "'"))
' If the control is a Label, set its Caption:
' ISCO68Title.Caption = Nz(DLookup("ISCO68Code", "libISCO1968", "[ISCO68Code]='" & ISCO68Code & "'"))
End Sub
But your function doesn't make much sense, as DLookup will return the same ISCO68Code as you look up ... except if you just will check if it exists.
Try this function :
Private Function ISCO68Code_AfterUpdate(ByVal ISCO68Code As String) As Variant
ISCO68Code_AfterUpdate = DLookup("ISCO68Code", "libISCO1968", "[ISCO68Code] = " & ISCO68Code)
End Function
Private Sub ISCO68Code_AfterUpdate_test()
Dim ISCO68Title As Variant
ISCO68Title = ISCO68Code_AfterUpdate(ISCO68Code)
'MsgBox ISCO68Title
Debug.Print ISCO68Title
End Sub
I have made a function that adds record in a table:
Public Function AjouterCleint _
(ByVal pcode As String, ByVal prsoc As String, ByVal padresse As String, ByVal pcp As String) As Boolean
On Error GoTo ErrorHandler
MsgBox " code " & " : " & pcode & " / rsoc : " & prsoc & " / adresse : " & padresse & " / cp : " & pcp
AjouterCleint = False
Dim rs As New Recordset
Set rs = New Recordset
Dim conn As ADODB.Connection
Dim strIPAddress As String
Set con = New ADODB.Connection
con.CursorLocation = adUseClient
con.ConnectionString = "DRIVER={MySQL ODBC 3.51 Driver};" _
& "SERVER=LOCALHOST;" _
& " DATABASE=ste002;" _
& "UID=root;PWD=; OPTION=3"
con.Open
Set rs = Nothing
rs.CursorLocation = adUseClient
SQL = "INSERT INTO Client (code,rsoc,adresse,cp) VALUES ('" _
& pcode & "','" & prsoc & "','" & padresse & "','" & pcp & "')"
MsgBox "5"
rs.Open SQL, con, 3, 3
MsgBox "6"
Set rs = Nothing
MsgBox "7"
con.Close
MsgBox "8"
Set con = Nothing
MsgBox "9"
AjouterCleint = True
ErrorHandler:
MsgBox Err.Number & vbLf & Err.Description & vbLf & Err.HelpContext & vbLf & Err.Source, , ""
End Function
the value of parameters are not the some the I used. (I get in the message box:
code: ????, rsoc: ????, adresse :???? , cp :1
When I use this function as the ordinary way(I add it in a module and I call it as :
a = AjouterCleint("13234", "1234", "1234", "1234")
it works, but when I put it in a dll , an error raised:
2147217900
[MySQL][ODBC 3.51 DRIVER] ... SYNTHAX error in “???????????????” in line 1.
1000440
Microsoft OLE DB providerfor ODBC drivers
the exception is in this line:
rs.Open SQL, con, 3, 3
I deleted all parameters in INSET COMMAND and I replaced
SQL = "INSERT INTO Client (code,rsoc,adresse,cp) VALUES ('" _
& pcode & "','" & prsoc & "','" & padresse & "','" & pcp & "')"
By
SQL = "INSERT INTO Client (code,rsoc,adresse,cp) VALUES (12,12,12,12)"
And it works in the dll (I it called in other project and it works).
But I have to work with parameters.
So, any advices!!
Thanks a lot.
PS:” recordset.addnew” don’t works also and an error was raised either.
this is how I call the functions in the dll:
Private Declare Function FunctionCalled Lib "C:\dlls\vbm2dll\Called.dll" _
(ByVal strValuePassed As String) As String
Private Declare Function AjouterCleint Lib "C:\dlls\vbm2dll\Called.dll" _
(ByVal pcode As String, ByVal prsoc As String, ByVal padresse As String, ByVal pcp As String) As Boolean
Private Sub Form_load()
txbValuePassed = "abc"
End Sub
Private Sub cmdCall_Click()
txbValueReturned = FunctionCalled(txbValuePassed)
a = AjouterCleint("1104", "1", "1", "1")
MsgBox a & ""
End Sub
it probably has to do with how you are passing the arguments to the DLL. The code you show doesnt specify ByRef or ByVal so it is using the default, which I think was ByRef in VB6 but you probably arent passing the address. This:
Public Function AjouterCleint(ByVal pcode As String, _
ByVal prsoc As String, _
ByVal padresse As String, _
ByVal pcp As String) As Boolean
Might fix the problem.
EDIT
Your app code also needs to match that declaration to tell VB how to pass the vars:
[Private|Public] Declare Function AjouterCleint Lib "MyLibName.dll" [Alias "AliasName"] _
(ByVal pcode As String, _
ByVal prsoc As String, _
ByVal padresse As String, _
ByVal pcp As String) As Boolean
Since a BSTR is basically still a pointer, you are likely going to have to copy the string data though it seems like it should work with both sides in VB):
Private Declare Sub RtlMoveMemory Lib "kernel32" (ptrDst As Any, _
ptrSrc As Any, ByVal lLen As Long)
Private Function vbstr(ptr As Long) As String
Dim l As Long
l = lstrlenW(ptr)
vbstr = String$(l, vbNullChar)
Call RtlMoveMemory(ByVal StrPtr(vbstr), ByVal ptr, l * 2)
End Function