here is my code below , when i use it without proxy it runs smooth but when i start to use proxy the UI freezez for a bit , kindly tell me if their is something that can be done so it dont freeze and be able to do other stuff while its doing its thing.
Function httpreq(url As String) As String
Dim whr As New WinHttp.WinHttpRequest
Set whr = CreateObject("WinHttp.WinHttpRequest.5.1")
whr.Open "GET", url, False
whr.SetProxy 2, List1.Text, ""
whr.Send
httpreq = whr.ResponseText
RichTextBox1.Text = RichTextBox1.Text & whr.ResponseText
End Function
Related
I want to establish a secure connection with my server which only supports TLS 1.2 and upwards.
I am adding the following line to my VB.NET applications to enable communication with my https server:
ServicePointManager.SecurityProtocol = SecurityProtocolType.Tls12
However, I also still have some VB6 apps which also need to use https server.
And the above line is not available for VB6, and the code throws "Error Occurred in the Secure Channel Support". If I use it on http instead of https, it works fine.
How could I achieve the same for VB6?
Thank you!
Btw, this is my code:
Public Function GetHTTPResponse(Byval uSomeInput) As String
ServicePointManager.SecurityProtocol = SecurityProtocolType.Tls12 'required in order to use https!!!
Dim nReq As Net.WebRequest = Net.WebRequest.Create("https://domain.xyz/answer.php")
nReq.Method = "Post"
nReq.ContentType = "application/x-www-form-urlencoded"
Dim nReqStream As IO.Stream = nReq.GetRequestStream()
Dim nASCIIEncoding As New System.Text.ASCIIEncoding
Dim btPostData As Byte() = Nothing
btPostData = nASCIIEncoding.GetBytes("&MyPHPInput=" & uSomeInput)
nReqStream.Write(btPostData, 0, btPostData.Length)
nReqStream.Close()
Dim reader As New IO.StreamReader(nReq.GetResponse().GetResponseStream())
Dim sRet As String = reader.ReadToEnd
Return sRet
End Function
And this is the same code in VB6, but in VB6, I can't (to my knowledge) not set the Tls12 security protocol:
Public Function GetHTTPResponse(ByVal uSomeInput) As String
'How do I set Tls12 protocol here??
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
xmlhttp.Open "POST", "https://domain.xyz", False
xmlhttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" & VBA.Chr(10) & VBA.Chr(13)
xmlhttp.Send pConvertStringToByte("https://domain.xyz/answer.php?MyPHPInput=" & uSomeInput)
GetHTTPResponse = xmlhttp.responseText
End Function
Edit:
I have followed the advice to try using WinHttp.WinHttpRequest.5.1 instead as discussed here.
It seems to work, but for some reason, the variables are not being transferred / recognized by the script, while they were recognized with my old approach using MSXML2.ServerXMLHTTP.
This is my code:
Public Function GetHTTPResponse(ByVal uSomeInput) As String
Dim xmlhttp As Object
Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
'force TLS 1.2
xmlhttp.Option(9) = 2048
xmlhttp.Option(6) = True
xmlhttp.Open "POST", "https://domain.xyz", False
xmlhttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" & VBA.Chr(10) & VBA.Chr(13)
xmlhttp.Send pConvertStringToByte("https://domain.xyz/answer.php?MyPHPInput=" & uSomeInput)
GetHTTPResponse = xmlhttp.responseText
End Function
Does anybody see why my old byte array is not accepted for "WinHttp.WinHttpRequest.5.1" while it work for "MSXML2.ServerXMLHTTP"?
Try this one:
' Define uSomeInput's data type, otherwise it's passed as a Variant, which might or might not be what we intended
Public Function GetHTTPResponse(ByVal uSomeInput As String) As String
' Use early instead of late binding
Dim xmlhttp As WinHttp.WinHttpRequest
Set xmlhttp = New WinHttpRequest
' force TLS 1.2
xmlhttp.Option(9) = 2048
xmlhttp.Option(6) = True
xmlhttp.Open "POST", "https://domain.xyz", False
xmlhttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" & vbNewLine
' Let the webserver know the size of the data
xmlhttp.SetRequestHeader "Content-Length", CStr(LenB(uSomeInput)) & vbNewLine
xmlhttp.Send pConvertStringToByte("https://domain.xyz/answer.php?MyPHPInput=" & uSomeInput)
' Not sure why the string to byte array conversion is necessary
' Could just try the string as well
xmlhttp.Send "https://domain.xyz/answer.php?MyPHPInput=" & uSomeInput
GetHTTPResponse = xmlhttp.ResponseText
End Function
If everything else fails and you require a VB6 solution and therefore are willing (or forced) to spend money ($ 395) on a commercial component, have a look at SocketTools. Although tempting, I suggest taking the Library over the ActiveX edition (which is just a wrapper of the former, IMHO). I've used SocketTools in VB6 with great success in the past (since its 6.x version, IIRC). I started using it, because I faced a very similar task to yours: I had to support SFTP transfer in my VB6 application.
I'm trying to get the address in
https://dev.virtualearth.net/REST/v1/Locations/40.6718266667,-73.7601944444?o=xml&key=AqF-lvBxcTAEbhY5v0MfOHxhplD5NyaznesQ1IA5KS_RNghU1zrDiYN704mlrc8A
That's the ("//Location/Name")
The code is :
Function FindALocationByPoint(Lat As String, Lon As String, BingMapsKey As String) As String
Dim myRequest As XMLHTTP60
Dim uu As String
uu = "https://dev.virtualearth.net/REST/v1/Locations/" & Lat & "," & Lon & "?o=xml&key=" & BingMapsKey
Set myRequest = New XMLHTTP60
myRequest.Open "POST", uu, 0
myRequest.send
FindALocationByPoint = myRequest.readyState
(I know the final line should be FindALocationByPoint = myRequest.responseXML.SelectNodes("//Location/Name").Item(0).Text) That will also return #VALUE! I think the main problem is the unsuccessful connection to the website.
Then the cell=FindALocationByPoint(K2,L2,$W$4)will return#VALUE!
If I delete myRequest.send then the cell will return 1, which means server connection established, right?
Then, why adding myRequest.send will return #VALUE! ?
Any Guidance?
THANK YOU SO MUCH. I've working with this for two days.
If I change the URL and set uu equals another Geocoding website, there is no problem.
So is there something wrong with the website?(Microsoft Bing)
But I must use Bing, how to deal with this?
Thanks,
Ajax is not the problem here. You can load and use the long path to access:
Option Explicit
Public Sub test()
Const URL As String = "https://dev.virtualearth.net/REST/v1/Locations/40.6718266667,-73.7601944444?o=xml&key=AqF-lvBxcTAEbhY5v0MfOHxhplD5NyaznesQ1IA5KS_RNghU1zrDiYN704mlrc8A"
Dim sResponse As String, xmlDoc As Object 'MSXML2.DOMDocument60
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "GET", URL, False
.send
sResponse = .responseText
End With
Set xmlDoc = CreateObject("MSXML2.DOMDocument") 'New MSXML2.DOMDocument60
With xmlDoc
.validateOnParse = True
.setProperty "SelectionLanguage", "XPath"
.async = False
If Not .LoadXML(sResponse) Then
Err.Raise .parseError.ErrorCode, , .parseError.reason
End If
Dim a As IXMLDOMElement
Set a = .LastChild.LastChild.FirstChild.LastChild.FirstChild.FirstChild
Debug.Print a.nodeTypedValue
End With
End Sub
If you execute the following script, it wll print you the same addresse twice dug out from different nodes. Let me know if this is what you expected or I got you wrong.
Sub GetAddress()
Const URL$ = "https://dev.virtualearth.net/REST/v1/Locations/40.6718266667,-73.7601944444?o=xml&key=AqF-lvBxcTAEbhY5v0MfOHxhplD5NyaznesQ1IA5KS_RNghU1zrDiYN704mlrc8A"
Dim xmlDoc As Object, elem$, elemAno$
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.LoadXML .responseXML.XML
End With
elem = xmlDoc.SelectNodes("//Location/Name")(0).Text
elemAno = xmlDoc.SelectNodes("//Address/FormattedAddress")(0).Text
Debug.Print elem, elemAno
End Sub
The company where I work has an old VB6 application that they want to force to use TSL, rather than SSL. I looked at the code, and told them they should be fine. The code does a post to the client website using HTTPS. It doesn't specify what encryption to use.
This is the relevant code:
Sub PostXML()
Dim XMLHttpRequest As MSXML2.XMLHTTP
Dim TempString As String
Dim strURL As String
Dim strArgs As String
strURL = gPostWebServer & "/" & gPostFile
'ARB 1/8/2004 This is to trap if send fails and allow it to continue.
On Error GoTo errorHandler:
If Not XMLHttpRequest Is Nothing Then Set XMLHttpRequest = Nothing
Set XMLHttpRequest = New MSXML2.XMLHTTP
strArgs = "?Username=" & gPostUserName & "&Password=" & gPostPassword
XMLHttpRequest.Open "POST", strURL & strArgs, False
XMLHttpRequest.send dom_GlobalXMLObject
If XMLHttpRequest.Status >= 400 And XMLHttpRequest.Status <= 599 Then
TempString = "Client Website is not available. Order was not posted successfully ..."
flgOrderPostSuccess = False
strOrderPostError = TempString
Else
TempString = XMLHttpRequest.responseText
'Parse the response
Dim sValid As String
Dim sComments As String
Dim sTimeStamp As String
Dim oRoot As MSXML2.IXMLDOMElement
Dim lNodes As MSXML2.IXMLDOMNodeList
Dim oNodes As MSXML2.IXMLDOMElement
Dim lNodes1 As MSXML2.IXMLDOMNodeList
Dim oNodes1 As MSXML2.IXMLDOMElement
Dim lNodes2 As MSXML2.IXMLDOMNodeList
Dim oNodes2 As MSXML2.IXMLDOMElement
Call Set_Global_XML_Object
dom_GlobalXMLObject.loadXML (TempString)
dom_GlobalXMLObject.Save (Report_Folder & "\Response.xml")
'Get the root of the XML tree.
Set oRoot = dom_GlobalXMLObject.documentElement
If Not oRoot Is Nothing Then
Set lNodes = oRoot.childNodes
For Each oNodes In lNodes
Select Case oNodes.nodeName
Case "Acknowledgement"
Set lNodes1 = oNodes.childNodes
For Each oNodes1 In lNodes1
Select Case oNodes1.nodeName
Case "Received"
sTimeStamp = Trim(oNodes1.nodeTypedValue)
Case "Validated"
sValid = Trim(oNodes1.nodeTypedValue)
Case "Errors"
Set lNodes2 = oNodes1.childNodes
For Each oNodes2 In lNodes2
Select Case oNodes2.nodeName
Case "Description"
sComments = sComments & vbCrLf & Trim(oNodes2.nodeTypedValue)
End Select
Set oNodes2 = Nothing
Next
Set lNodes2 = Nothing
End Select
Set oNodes1 = Nothing
Next
Set lNodes1 = Nothing
End Select
Next
If UCase(sValid) = "YES" Then
TempString = sTimeStamp & " " & "Order uploaded successfully"
flgOrderPostSuccess = True
strOrderPostError = ""
Else
TempString = "Order had following problems:" & vbCrLf
TempString = TempString & sComments
strOrderPostError = TempString
End If
Else 'Non XML response
TempString = Replace(TempString, vbCr, vbCrLf)
TempString = "Order had following problems:" & vbCrLf & TempString
strOrderPostError = TempString
End If
End If
Call FillLogTextBox("-----------------------------------------------" & vbCr)
Call FillLogTextBox(TempString)
Call FillLogTextBox("-----------------------------------------------" & vbCr)
Set oRoot = Nothing
Set lNodes = Nothing
Set oNodes = Nothing
Set lNodes1 = Nothing
Set oNodes1 = Nothing
Set lNodes2 = Nothing
Set oNodes2 = Nothing
Set XMLHttpRequest = Nothing
Exit Sub
errorHandler:
TempString = Err.DESCRIPTION
If InStr(1, TempString, "Method") > 0 Or InStr(1, Err.DESCRIPTION, "failed") > 0 Then
TempString = "Client Website was not found. Order was not posted successfully..."
Call FillLogTextBox(TempString)
Call FillLogTextBox("-----------------------------------------------" & vbCr)
Exit Sub
End If
End Sub
When the client switched from SSL to TSL last weekend, everything worked, except the posts from this one old VB6 app. (So I'm told, anyways. This isn't an application I've supported before.)
We have other VB6 apps that I maintain, but none do a POST out of VB6. All of them use BizTalk for posting.
The client has given us until next Wednesday to fix our app. So, the powers that be want me to force the app to use TSL.
Normally, I don't have problems with VB6, but I've never tried forcing the encryption used to POST. Generally, when we did POST out of the other VB6 apps, they negotiated with Windows on their own, and took care of things. While I've seen successful attempts to force VB6 to use TSL when sending an email, I've never seen anyone do it for POSTing.
All that being said, does anyone know how to force VB6 to use TSL when POSTing?
Thanks
With SChannel you cannot control available/used protocols and ciphers at an application level, you have to configure SChannel protocols/ciphers on the Win2003 box at system level. Here is KB on the subject: http://support.microsoft.com/kb/245030
To disable SSLv3 for both inbound and outbound connections merge something like this in registry (and reboot):
Windows Registry Editor Version 5.00
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\SecurityProviders\SCHANNEL\Protocols\SSL 3.0]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\SecurityProviders\SCHANNEL\Protocols\SSL 3.0\Client]
"DisabledByDefault"=dword:00000001
"Enabled"=dword:00000000
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\SecurityProviders\SCHANNEL\Protocols\SSL 3.0\Server]
"Enabled"=dword:00000000
"DisabledByDefault"=dword:00000001
While there make sure SSLv2 is nuked too.
You might prefer to use IISCrypto -- a nice utility that makes SSL/TLS protocols/ciphers registry config trivial.
I have a script which is able to download files from the https://mysite.com/xxx.zip but when it goes to a secured link, I want to accept the certificate. There is a huge problem here. I am not able to use "ServicePointManager.ServerCertificateValidationCallback" effectively.
Can anyone please help?
I also have the domain for the certificate site: *.mysite.com
code:
Const scriptVer = "1.0"
Const DownloadDest = "https://mysite.com/xxx.zip"
Const LocalFile = "F:\Testing\xxx.zip"
Const webUser = "admin"
Const webPass = "admin"
Const DownloadType = "binary"
dim strURL
function getit()
dim xmlhttp
set xmlhttp=createobject("MSXML2.XMLHTTP.3.0")
'xmlhttp.SetOption 2, 13056 'If https -> Ignore all SSL errors
strURL = DownloadDest
Wscript.Echo "Download-URL: " & strURL
'For basic auth, use the line below together with user+pass variables above
xmlhttp.Open "GET", strURL, false, WebUser, WebPass
'xmlhttp.Open "GET", strURL, false
xmlhttp.Send
Wscript.Echo "Download-Status: " & xmlhttp.Status & " " & xmlhttp.statusText
If xmlhttp.Status = 200 Then
Dim objStream
set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary
objStream.Open
objStream.Write xmlhttp.responseBody
objStream.SaveToFile LocalFile
objStream.Close
set objStream = Nothing
End If
set xmlhttp=Nothing
End function
'=======================================================================
' End Function Defs, Start Main
'=======================================================================
' Get cmdline params and initialize variables
If Wscript.Arguments.Named.Exists("h") Then
Wscript.Echo "Usage: http-download.vbs"
Wscript.Echo "version " & scriptVer
WScript.Quit(intOK)
End If
getit()
Wscript.Echo "Download Complete. See " & LocalFile & " for success."
Wscript.Quit(intOK)
ServicePointManager.ServerCertificateValidationCallback = AddressOf AcceptAllCertifications
Private Shared Function ValidateCertificate(sender As Object, certificate As X509Certificate, chain As X509Chain, sslPolicyErrors As SslPolicyErrors) As Boolean
return True
End Function
ServicePointManager is a .NET class, so it can't be used in VBScript. Try this instead:
Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
xmlhttp.setOption 2, 13056
You must use MSXML2.ServerXMLHTTP here, because MSXML2.XMLHTTP requests don't have the setOption method.
And perhaps you shouldn't broadcast your questions. It's not very polite.
I'm writing a vbscript to pull some data from a webpage, strip out a few key pieces of information and write those to a file.
At the moment my script to access the pages and save the file contents to a string is this:
Set WshShell = WScript.CreateObject("WScript.Shell")
Set http = CreateObject("Microsoft.XmlHttp")
'Load Webpage where address is URL
http.open "GET", URL, FALSE
http.send ""
'Assign webpage contents as a string to variable called Webpage
WEBPAGE = http.responseText
I need to save the content to a string so I can use a regular expression on it to pull out the content that I need.
This script works perfectly, EXCEPT for when the pages contain non-standard characters (such as é). When the page contains something like this, the script throws up an error and stops.
I'm guessing this is something to do with the encoding, but I can't work out how to fix it. Can anyone point me in the right direction? Thanks guys
Edit
Thanks to the help here I realised I've asked the wrong question! It turns out I was downloading the content fine - the problem was, afterwards I was trying to edit it and write it out to a file, and the file was in the wrong format. I had this:
Set objTextFile = objFSO.OpenTextFile(OutputFile, 8, True,)
Changing it to this:
Set objTextFile = objFSO.OpenTextFile(OutputFile, 8, True, -1)
Seems to have fixed it. What a crazy world, eh? Thanks for the help.
You may need to set the correct header blocks before send
eg the following is an example only. You will need to find out what this is exactly for your website
http.open "GET", URL, FALSE
http.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
http.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5"
http.SetRequestHeader "Accept-Language", "en-us,en;q=0.5"
http.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7"
http.send ""
EDIT:
What about this instead. It works ok here
Dim XMLHttpReq,URL,WEBPAGE
Const Eacute = "%C3%89"
Set XMLHttpReq = CreateObject("MSXML2.ServerXMLHTTP")
URL = "http://en.wikipedia.org/wiki/%C3%89"
'Load Webpage where address is URL
XMLHttpReq.Open "GET", URL, False
XMLHttpReq.send ""
'Assign webpage contents as a string to variable called Webpage
WEBPAGE = XMLHttpReq.responseText
WEBPAGE = Replace(WEBPAGE, Eacute, "É")
'Debug.Print WEBPAGE
The E acute in this case returns as string %C3%89 and you can force it to whatever character you choose if required.
EDIT2:
Just to add, if you're doing this with VBScript you may find this method useful
Dim XMLHttpReq, URL, WEBPAGE, fso, f
Const Eacute = "%C3%89"
Set XMLHttpReq = CreateObject("MSXML2.ServerXMLHTTP")
URL = "http://en.wikipedia.org/wiki/%C3%89"
XMLHttpReq.Open "GET", URL, False
XMLHttpReq.send ""
WEBPAGE = XMLHttpReq.responseText
Save2File WEBPAGE, "C:\Users\osknows\Desktop\test.txt"
Sub Save2File (sText, sFile)
Dim oStream
Set oStream = CreateObject("ADODB.Stream")
With oStream
.Open
.CharSet = "utf-8"
.WriteText sText
.SaveToFile sFile, 2
End With
Set oStream = Nothing
End Sub