Add a button programmatically in VBA

[dickey_tg]

Hi,

My project need to build the new button(s) by row level and let user through the button to trigger the function from EXCEL to API server. For instance, Approve / Reject processes.

I have [2] problems on coding level.
[1] When I change the coding to [OnAction = withReviewProc(nHYPER_APP, i)], the function is work BUT is not trigger by user. The function is auto-run when I call other button/procedure cmdBTEnquiry_Click() to query the data from API.
[2] When I use coding [OnAction = "btn"], the auto-run function is stopped, good. But I have no the idea how to trigger the function [withReviewProc] via on generated button

** Source : Link **

Here is my code.

Private Sub cmdBTEnquiry_Click()
:
For Each item In JSONa("entry_list")
           :
           i = 7
            nHYPER_APP = "http://api.xyz.com/api/rest.php?method=setentries&input_type=JSON&response_type=JSON&rest_data={"module":"V3295","name_value_list":[{"id":"9eb47658zyxxxxx","review":"Approve"}]}"

            'Create button - Start
            Dim btn As Button
            Application.ScreenUpdating = False
            'ActiveSheet.Buttons.Delete
            Dim t As Range
            Set t = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
            Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
           
            With btn
                '.OnAction = "btn"
                .OnAction = withReviewProc(nHYPER_APP, i)
                .Caption = "Approve"
                '.Caption = "Btn " & i
                .Name = "Btn" & i
            End With
            Application.ScreenUpdating = True
            'Create button - End

           i = i + 1
            :
            :
Next
:
End Sub

Remark : [nHYPER_APP] is generate by dynamic coding. Each row(s)/button(s) should be pass the unify id to API server and let API server to update the specified dataset.

Here is the function of withReviewProc

Function withReviewProc(ByVal myurl As String, ByVal nopos As Integer)
        Dim xmlhttp01 As New MSXML2.XMLHTTP60
        xmlhttp01.Open "post", myurl, False
        xmlhttp01.send
        nRLT02 = xmlhttp01.responseText
        Set JSONe = JsonConverter.ParseJson(nRLT02)
        def = JSONe("ids")(1)
        If Len(def) > 0 Then
            Worksheets("Approval_WB").Cells(nopos, "N").Value = "Updated:" & def
        Else
            Worksheets("Approval_WB").Cells(nopos, "N").Value = "Not match"
        End If
End Function

 

[RoryA]

OnAction needs a string (the name of the routine to run). You are actually calling that function directly in your code. You need something like:

.OnAction = "'withReviewProc """ & nHYPER_APP & """, " & i & "'"

Note that this will not work if your file format is xlsb.

 

[dickey_tg]

OnAction needs a string (the name of the routine to run). You are actually calling that function directly in your code. You need something like:

.OnAction = "'withReviewProc """ & nHYPER_APP & """, " & i & "'"

Note that this will not work if your file format is xlsb.

Hi RoryA,

Thank you for your reply. But it still not work.

Now prompt the new error [ Unable to set the OnAction property of the button class (Run time error 1004) ].

Tried the combination as the below. Same error to show.
.OnAction = "'withReviewProc """ & nHYPER_APP & """, " & i & "'"
.OnAction = "'withReviewProc" & nHYPER_APP & "," & i & " '"
.OnAction = "'withReviewProc" & "(" & nHYPER_APP & "," & i & ")" & "'"
.OnAction = Chr(34) & Chr(39) & withReviewProc & "(" & nHYPER_APP & "," & ctsr(i) & ")" & Chr(39) & Chr(34)

I have some confuse. Shall I need to use the bracket into [OnAction]? . It is because I need to call a function withReviewProc(aaa, nn) but the last syntax is only use """.
Is this equivalent with "(" on statement?

Sorry bro, I'm newly in VBA. not sure the complete syntax in VBA

 

[dickey_tg]

Hi Roya,

It looks like work but has other issue to show. When I click the [Approve] button and the system prompt the dialog message as the below.
[Cannot run the macro Filename.xlsm!'withReviewProc i, "nHYPER_APP_ARR""'. The macro may not be avaialble in this workbook or all macros may be disabled.]

Here is the new coding

            'Create button - Start
            Dim btn As Button
            Application.ScreenUpdating = False
            'ActiveSheet.Buttons.Delete
            Dim t As Range
            Set t = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
            Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
            'chr(34) double quote
            'chr(39) single quote
             
            With btn
                .OnAction = "'withReviewProc i, ""nHYPER_APP_ARR""'"
                .Caption = "Approve"
                .Name = "Btn" & i

            End With
            Application.ScreenUpdating = True
            'Create button - End

Change the function to Sub as the below.

Sub withReviewProc(ByVal nopos As Integer, ByVal myurl As String)
        Dim xmlhttp01 As New MSXML2.XMLHTTP60
        xmlhttp01.Open "post", myurl, False
        xmlhttp01.send
        nRLT02 = xmlhttp01.responseText
        Set JSONe = JsonConverter.ParseJson(nRLT02)
        def = JSONe("ids")(1)
        If Len(def) > 0 Then
            Worksheets("Approval_Q1").Cells(nopos, "N").Value = "Updated:" & def
        Else
            Worksheets("Approval_Q1").Cells(nopos, "N").Value = "Not match"
        End If
End Sub

 

[Domenic]

Try...

.OnAction = "'withReviewProc " & i & ", """ & nHYPER_APP_ARR & """'"

Hope this helps!

 

[dickey_tg]

Hi RoryA,

Last reply is wrong because the syntax has the bug. Now reverse to new. However still has a error message.
Run time error 1004: Unable to set the OnAction Property of the Button class
Already verified the Excel 4.0 macro is ENABLED under trust center.

OnAction needs a string, so I added new variable [onactionstring01] to contain the variables for easy to control.

I reverse the coding as the below.

:
Dim nHYPER_APP, nHYPER_REJ As String
For Each item In JSONa("entry_list")
'-- Major to prevent the double quote or other symbols to interrupt the submit process
nHYPER_APP = n02JSON & "{" & "[-DQ]" & "id" & "[-DQ]" & ":" & "[-DQ]" & nSYSID & "[-DQ]" & "[-CO]" & _
            "[-DQ]" & "z_status" & "[-DQ]" & ":" & "[-DQ]" & "Approve" & "[-DQ]" & "}]}"
nHYPER_APP = Replace(Replace(Replace(nHYPER_APP, "&", "[-AN]"), """", "[-DQ]"), ",", "[-CO]")

            'Create button - Start
            Dim btn As Button
            Application.ScreenUpdating = False
            Dim t As Range
            Set t = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
            Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
            onactionstring01 = "'withReviewProc " & CStr(i) & ", " & Chr(34) & nHYPER_APP & Chr(34) & "'"
            Worksheets("Approval_Q1").Cells(i, "P") = onactionstring01
            With btn
                .OnAction = onactionstring01
                .Caption = "Approve"
                .Name = "Btn" & i
            End With
            Application.ScreenUpdating = True

Public Function withReviewProc(ByVal nopos As Integer, ByVal myurl As String)
        myurl = Replace(Replace(Replace(myurl, "[-DQ]", "Chr(34)"), "[-CO]", ","), "[-AN]", "&")
        Dim xmlhttp01 As New MSXML2.XMLHTTP60
        xmlhttp01.Open "post", myurl, False
        xmlhttp01.send
        nRLT02 = xmlhttp01.responseText
        Set JSONe = JsonConverter.ParseJson(nRLT02)
        def = JSONe("ids")(1)
        If Len(def) > 0 Then
            Worksheets("CTR_Approval_Q1").Cells(nopos, "N").Value = "Updated:" & def
        Else
            Worksheets("CTR_Approval_Q1").Cells(nopos, "N").Value = "Not match"
        End If
End Function

[onactionstring01] value as the below
'withReviewProc 7, ".xyz Domain Names | Join Generation XYZ{[-DQ]session[-DQ]:[-DQ]xxxxxxxxxxxxxx[-DQ][-CO][-DQ]module_name[-DQ]:[-DQ]V3295[-DQ][-CO][-DQ]name_value_list[-DQ]:[{[-DQ]id[-DQ]:[-DQ]94b336ff-10d6-ea7c-3be5-632812b91a76[-DQ][-CO][-DQ]z_status[-DQ]:[-DQ]Approve[-DQ]}]}"'

 

[dickey_tg]

Try...

.OnAction = "'withReviewProc " & i & ", """ & nHYPER_APP_ARR & """'"

Hope this helps!

Hi Domenic,

Revised lines as the below
onactionstring01 = "'withReviewProc " & i & ", """ & nHYPER_APP & """'"
.OnAction = onactionstring01

Now Show error message : Cannot run the macro xxxxx.xlsm, The macro may not be available in this workbook or all macros may be disabled.

Still stuck OnAction line ........

Already verified the Excel 4.0 macro is ENABLED under trust center.

 

[RoryA]

Which module is withReviewProc in?

 

[dickey_tg]

Which module is withReviewProc in?

The function [withReviewProc] is located on worksheet [CTR_Approval_Q1], not module.

Filename:Demo_20220920_API_R47250_R2_O365.xlsm
Worksheet:CTR_Approval_Q1

 

[RoryA]

If it's in a worksheet, then you need to include the codename of the worksheet in the OnAction, so it would be:

onactionstring01 = "'Sheet57.withReviewProc " & i & ", """ & nHYPER_APP & """'"

or put the routine in a normal module.