Ошибка «Недостаточно памяти» на Win10 64-битной, но не 32-битной?[РЕШЕНО] - PullRequest
Новая
       44

Ошибка «Недостаточно памяти» на Win10 64-битной, но не 32-битной?[РЕШЕНО]

1 голос
/ 17 июня 2019

Я использую код из сообщения Марка Бертеншоу: VB6 - используя POST & GET из URL и отображая в форме VB6

На 32-битной машине разработки код Марка работает нормально. Но на моей 64-битной машине это выдает ошибку нехватки памяти в коде: 

m_sOutput = StrConv(AsyncProp.Value, vbUnicode)

Возвращенные данные из http-запроса очень просты {"response": 2} или {"response": 6} и т. Д.

На 32-битной машине он загружает scrrun.dll из папки system32, но на 64-битной машине он загружается из папки sysWOW64 (в ссылках).

Это является причиной проблемы, так как я думаю, что сообщение об ошибке памяти - красная сельдь?

Контроль пользователя (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

Позвонив по номеру:

Код кнопки 

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

Просто не могу найти причину проблемы.

Сообщение об ошибке

Недостаточно памяти

Если построен на 64-битной Win 10

Нет сообщения об ошибке, если он построен на 32-битной Win 10, читает файл и продолжает без проблем

...