I am using the code from Mark Bertenshaw's post: VB6 -- using POST & GET from URL and displaying in VB6 Form
On 32 Bit development machine Mark's code works fine. But on my 64 Bit machine it Gives an out of memory error at the code:
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
The returned data from the http request is very simple {"response": 2}, or {"response": 6} etc.
On the 32bit machine it is loading scrrun.dll from system32 folder but on 64bit machine it is loading from sysWOW64 folder (in the references).
Is it that that is causing the issue as I think the Memory error message is a red herring?
User Control (HTTPService)
Option Explicit
Private Const m_ksProperty_Default As String = ""
Private m_sHost As String
Private m_nPort As Long
Private m_sPath As String
Private m_dctQueryStringParameters As Scripting.Dictionary
Private m_sOutput As String
' Ensure that all parts of the query string are deleted.
Public Sub ClearQueryString()
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
' Executes "GET" method for URL.
Public Function Get_() As String
' Read in data from URL. UserControl_AsyncReadComplete will fire when finished.
UserControl.AsyncRead "http://" & m_sHost & ":" & CStr(m_nPort) & "" & m_sPath & "?" & GetQueryString(), vbAsyncTypeByteArray, m_ksProperty_Default, vbAsyncReadSynchronousDownload
' Return the contents of the buffer.
Get_ = m_sOutput
' Clear down state.
m_sOutput = vbNullString
End Function
' Returns query string based on dictionary.
Private Function GetQueryString() As String
Dim vName As Variant
Dim sQueryString As String
For Each vName In m_dctQueryStringParameters
sQueryString = sQueryString & CStr(vName) & "=" & m_dctQueryStringParameters.Item(vName) & "&"
Next vName
GetQueryString = Left$(sQueryString, Len(sQueryString) - 1)
End Function
' Sets the remote host.
Public Property Let Host(ByVal the_sValue As String)
m_sHost = the_sValue
End Property
' Sets the directory and filename part of the URL.
Public Property Let Path(ByVal the_sValue As String)
m_sPath = the_sValue
End Property
' Sets the port number for this request.
Public Property Let Port(ByVal the_nValue As Long)
m_nPort = the_nValue
End Property
' Sets a name/value pair in the query string. Supports duplicate names.
Public Property Let QueryStringParameter(ByVal the_sName As String, ByVal the_sValue As String)
m_dctQueryStringParameters.Item(the_sName) = the_sValue
End Property
' Fired when the download is complete.
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
' Gets the data from the internet transfer.
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
End Sub
Private Sub UserControl_Initialize()
' Initialises the scripting dictionary.
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
Calling it from:
Button Code
Private Sub cmdCheckNow_Click()
On Error GoTo err_trap
Call hideCheckNow
QProGIF1.Visible = True
Call DeleteUrlCacheEntry("http://mysite.co.uk/mobicleanud/chkupdates.php")
DoEvents
HttpService.Host = "mysite.co.uk"
HttpService.Port = 80
HttpService.Path = "/thefolder/chkupdates.php"
HttpService.QueryStringParameter("license") = licensekey
HttpService.QueryStringParameter("vers") = "SOFTWARE2"
HttpService.QueryStringParameter("appmajor") = App.Major
HttpService.QueryStringParameter("appminor") = App.Minor
HttpService.QueryStringParameter("apprevis") = App.Revision
txtOutput.Text = HttpService.Get_
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "9" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (9) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "8" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (8) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "7" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (7) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
If txtOutput.Text = "" Or IsNull(txtOutput.Text) Or txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "6" & "})" Then
frmError.lblErrorMessage.Caption = "Licensing Server cannot validate the License Number! Error (6) - Please try again."
frmError.Show vbModal
Call showCheckNow
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
QProGIF1.Visible = False
If txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "2" & "})" Then
lblchecked.Caption = "Your License was validated and there is a new version of Mobiclean Pro available to Download and Install."
lblchecked.Visible = True
QProGIF1.Visible = False
DoEvents
cmdGet.Visible = True
Exit Sub
End If
If txtOutput.Text = "({" & Chr(34) & "response" & Chr(34) & ":" & "3" & "})" Then
lblchecked.Caption = "Your License was validated. You have the latest version of Mobiclean Pro - No Update available."
lblchecked.Visible = True
QProGIF1.Visible = False
DoEvents
Exit Sub
End If
exit_sub:
Exit Sub
err_trap:
frmError.lblErrorMessage.Caption = "An error has occurred - Code: " & Err.Number & " Description: " & Err.description
frmError.Show vbModal
Resume exit_sub
End Sub
Just can't find what is causing the issue.
Error Message is
Out of Memory
If built on On 64Bit Win 10
No error message if built on 32Bit win 10 and reads file and continues no problem
