Excel VBA infinitely looping in 64bit

S

Samitha156

New Member
Joined
May 6, 2022
Messages
5
Office Version
  1. 2019
Platform
  1. Windows
I have a Excel macro file that is working in 32 bit environment. But it is not working in 64 bit. My question is pretty similar to this one Excel File not working on one computer but will on another.

Here is the code and the x64Solution() function.

VBA Code: 
Private Sub AmnestyFind()
Dim nowUTC As U, utcDate As Date, utcDiff As Double
Dim body$
Dim Strt(1 To 2)
Dim Ennd(1 To 2)
   
    fc = UCase(mainn.[b1])
    Strt(1) = mainn.[B8].Value
    Ennd(1) = mainn.[C8].Value
    Strt(2) = mainn.[B9].Value
    Ennd(2) = mainn.[C9].Value
 

For z = 1 To 2
  
    Set H = CreateObject("WinHTTP.WinHTTPRequest.5.1")
    #If Win64 Then
        Set x64 = x64Solution()
        x64.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        Set S = x64.CreateObjectx86("MSScriptControl.ScriptControl")
    #Else
        Set S = CreateObject("ScriptControl")
    #End If
    S.Language = "JScript"
    S.AddCode "function keys(O) { var k = new Array(); for (var x in O) { k.push(x); } return k; } "
   
    Call GetSystemTime(nowUTC)
    utcDate = nowUTC.a1 & "-" & nowUTC.a2 & "-" & nowUTC.A4 & " " & nowUTC.A5 & ":" & nowUTC.A6 & ":" & nowUTC.A7
    utcDiff = utcDate - Now()
   
    body = "{""index"":""quality_intelligence_amnesty"",""search_type"":""count"",""ignore_unavailable"":true}"
    body = body & Chr(10)
    body = body & "{""query"":{""filtered"":{""query"":{""query_string"":{""query"":""problem_status: \""Resolved\"""",""analyze_wildcard"":true}},""filter"":{""bool"":{""must"":[{""query"":{""query_string"":{""analyze_wildcard"":true,""query"":"
    body = body & """order"":{""1"":""desc""}},""aggs"":{""1"":{""sum"":{""field"":""addback_quantity""}}}}}}}}"
    body = body & Chr(10)

    With H
        .SetAutoLogonPolicy 0
        .Open "GET", "url"
        .SetClientCertificate "CURRENT_USER\MY\" & Environ("USERNAME")
        .Send
        .Open "POST", "url=" & (Now() - 25569 + utcDiff) * 86400
        .Send body
        .WaitForResponse
    End With

    Set JSON = S.Eval("(" & H.responseText & ")")
    Debug.Print H.responseText
    Set JSON = CallByName(JSON, "responses", VbGet)
    Set JSON = CallByName(JSON, "0", VbGet)
    Set JSON = CallByName(JSON, "aggregations", VbGet)
    Set JSON = CallByName(JSON, "3", VbGet)
    Set JSON = CallByName(JSON, "buckets", VbGet)
    Set Keys = S.Run("keys", JSON)

    For Each Key In Keys
        If CallByName(CallByName(JSON, Key, VbGet), "key", VbGet) = "T" Then
            a = CallByName(CallByName(JSON, Key, VbGet), "doc_count", VbGet)
        ElseIf CallByName(CallByName(JSON, Key, VbGet), "key", VbGet) = "F" Then
            B = CallByName(CallByName(JSON, Key, VbGet), "doc_count", VbGet)
        End If
    Next Key
   
chartt.Cells(52, z + 1) = a / (a + B)
    If TypeName(x64) <> "Nothing" Then x64.Close
Next z
End Sub
Private Sub FloorFind()
Dim nowUTC As U, utcDate As Date, utcDiff As Double
Dim body$
Dim Strt(1 To 2)
Dim Ennd(1 To 2)

    fc = UCase(mainn.[b1])
    Strt(1) = mainn.[B8].Value
    Ennd(1) = mainn.[C8].Value
    Strt(2) = mainn.[B9].Value
    Ennd(2) = mainn.[C9].Value
   
For z = 1 To 2
   
    Set H = CreateObject("WinHTTP.WinHTTPRequest.5.1")
    #If Win64 Then
        Set x64 = x64Solution()
        x64.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        Set S = x64.CreateObjectx86("MSScriptControl.ScriptControl")
    #Else
        Set S = CreateObject("ScriptControl")
    #End If
    S.Language = "JScript"
    S.AddCode "function keys(O) { var k = new Array(); for (var x in O) { k.push(x); } return k; } "
   
    Call GetSystemTime(nowUTC)
    utcDate = nowUTC.a1 & "-" & nowUTC.a2 & "-" & nowUTC.A4 & " " & nowUTC.A5 & ":" & nowUTC.A6 & ":" & nowUTC.A7
    utcDiff = utcDate - Now()

    body = "{""index"":""quality_intelligence_amnesty"",""search_type"":""count"",""ignore_unavailable"":true}"
    body = body & Chr(10)
    body = body & "{""query"":{""filtered"":{""query"":{""query_string"":{""query"":""problem_status: \""Resolved\"""",""analyze_wildcard"":true}},""filter"":{""bool"":{""must"":[{""query"":{""query_string"":{""analyze_wildcard"":true,""query"":"
    body = body & Chr(10)

    With H
        .SetAutoLogonPolicy 0
        .Open "GET", "url"
        .SetClientCertificate "CURRENT_USER\MY\" & Environ("USERNAME")
        .Send
        .Open "POST", "url" & (Now() - 25569 + utcDiff) * 86400
        .Send body
    End With

    Set JSON = S.Eval("(" & H.responseText & ")")
    Set JSON = CallByName(JSON, "responses", VbGet)
    Set JSON = CallByName(JSON, "0", VbGet)
    Set JSON = CallByName(JSON, "aggregations", VbGet)
    Set JSON = CallByName(JSON, "3", VbGet)
    Set JSON = CallByName(JSON, "buckets", VbGet)
    Set JSON = CallByName(JSON, "0", VbGet)
    Set JSON = CallByName(JSON, "4", VbGet)
    Set JSON = CallByName(JSON, "buckets", VbGet)
    Set JSON = CallByName(JSON, "0", VbGet)
    Set JSON = CallByName(JSON, "5", VbGet)
    Set JSON = CallByName(JSON, "buckets", VbGet)
    Set Keys = S.Run("keys", JSON)

 a = CallByName(JSON, "doc_count", VbGet)
 
    Set JSON2 = S.Eval("(" & H.responseText & ")")
    Set JSON2 = CallByName(JSON2, "responses", VbGet)
    Set JSON2 = CallByName(JSON2, "0", VbGet)
    Set JSON2 = CallByName(JSON2, "aggregations", VbGet)
    Set JSON2 = CallByName(JSON2, "3", VbGet)
    Set JSON2 = CallByName(JSON2, "buckets", VbGet)
    Set JSON2 = CallByName(JSON2, "1", VbGet)
    Set JSON2 = CallByName(JSON2, "4", VbGet)
    Set JSON2 = CallByName(JSON2, "buckets", VbGet)
    Set JSON2 = CallByName(JSON2, "0", VbGet)
    Set JSON2 = CallByName(JSON2, "5", VbGet)
    Set JSON2 = CallByName(JSON2, "buckets", VbGet)
    Set Keys = S.Run("keys", JSON2)

 B = CallByName(JSON2, "doc_count", VbGet)
 
 chartt.Cells(53, z + 1) = a / (a + B)
    If TypeName(x64) <> "Nothing" Then x64.Close
Next z
End Sub

----------------------------------------------------------------
VBA Code: 
Private Function x64Solution()
    Dim druifj, kindle
    On Error Resume Next
    druifj = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & druifj & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each kindle In CreateObject("Shell.Application").Windows
            Set x64Solution = kindle.GetProperty(druifj): If Err.Number = 0 Then Exit Function
            Err.Clear
        Next kindle
    Loop
End Function
--------------------------------------------------------------

This is actually what happens. It run up to the very first
VBA Code: 
#If Win64 Then
Then it jump right to the
VBA Code: 
Private Function x64Solution()

Then it infinitely looping in the For loop which is
VBA Code: 
For Each kindle In CreateObject("Shell.Application").Windows
            Set x64Solution = kindle.GetProperty(druifj): If Err.Number = 0 Then Exit Function
            Err.Clear
        Next kindle



Any help will be really appreciated. Thank you
 
Last edited by a moderator:

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
A 'Do' loop requires an exit condition. Example:
VBA Code: 
    Do While x < 900
        x = x + 1
    Loop
where x < 900 is the exit condition.

or
VBA Code: 
    Do
        x = x + 1
    Loop Until x >= 900


Your 'Do' loop:
VBA Code: 
    Do
        For Each kindle In CreateObject("Shell.Application").Windows
            Set x64Solution = kindle.GetProperty(druifj): If Err.Number = 0 Then Exit Function
            Err.Clear
        Next kindle
    Loop

has no exit condition.
 
Upvote 0
Appreciate your reply! I'm really not sure what should be the exit condition or what is the loop does. So I removed the " Do " loop and tested only with the For loop, but it does not work either. Any idea for that?
 
Upvote 0
You need to modify your Do loop so that the construction is either Do ... While <condition is true> or else a "Loop .....until <condition is true>" (see my earlier examples above). What the condition should be is for you to say, not me. There is not enough information for me to assess why you have a Do loop there. I don't see a need, but I have limited context. This sub is badly coded in general

VBA Code: 
Private Function x64Solution()
    Dim druifj, kindle
    On Error Resume Next
    druifj = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & druifj & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each kindle In CreateObject("Shell.Application").Windows
            Set x64Solution = kindle.GetProperty(druifj): If Err.Number = 0 Then Exit Function
            Err.Clear
        Next kindle
    Loop
End Function

Lack of proper variable data type declaration and turning off runtime error checking On Error Resume Next make it a lot harder to assess what is going on. Error messages can provide valuable information that can help to identify why things are not working. If it were me, I would revert everything back to the known-good 32 bit code and then start working though any errors seen under 64bit one by one.
 
Last edited:
Upvote 0
Yes I got what you said but the problem is I have no clear idea about that is the condition to add into Do ... While . I'm not really sure that is this druifj and kindle objects are doing.
 
Upvote 0
No
Samitha156 said:
Yes I got what you said but the problem is I have no clear idea about that is the condition to add into Do ... While . I'm not really sure that is this druifj and kindle objects are doing.
Click to expand...
So the code is not yours? You did not write it?
 
Upvote 0
So I'm going to go ahead and assume that you did not write the code yourself. Unfortunately I don't know what was in the programmer's mind and absent code comments or documentation to explain intent, I cannot guess at why it was written that way. It does look like the reason for all that new complicated code is because the 32-bit "ScriptControl" component is not supported in 64 bit. However, there supposedly is a 64-bit drop-in replacement (Tabalacus script control) that may be worth looking at:

github.com

GitHub - tablacus/TablacusScriptControl: Script Control for 64-bit platforms

Script Control for 64-bit platforms. Contribute to tablacus/TablacusScriptControl development by creating an account on GitHub.
github.com github.com

I say "supposedly" because I have no direct knowledge or experience with it. It's suitability, or lack thereof would be for you to determine.
 
Upvote 0
No.. It's not my code I didn't write it. I found this while I was trying to do some similar type of work and I though I can use this code to implement what I want. I will try this Git and see what is over there.
 
Upvote 0
What I think is this has written in a 32 bit version and they tried to implement it in to 64 in a case any user want to run it in 64.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Why does this JSON Microsoft Script VBA code work in Excel 2016 but takes forever in 2019?
2 3 4
Replies
39
Views
10K
Indominus
I
I
  • Question Question
VBA code only runs fast in a newly opened workbook
Replies
2
Views
820
Indominus
I
T
  • Question Question
Excel File not working on one computer but will on another.
2 3
Replies
20
Views
8K
TrainerBlue
T
T
  • Question Question
Excel VBA JSON issue
Replies
1
Views
3K
Dan_W
D

Forum statistics

Threads
1,223,884
Messages
6,175,177
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top