I have a very simple function for returning the HTML code behind a web page from a VBA app:
Function GetSource(sURL As String) As Variant
' Purpose: To obtain the HTML text of a web page
' Receives: The URL of the web page
' Returns: The HTML text of the web page in a variant
Dim oXHTTP As Object, n As Long
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
oXHTTP.Open "GET", sURL, False
oXHTTP.send
GetSource = oXHTTP.responsetext
Set oXHTTP = Nothing
End Function
It works beautifully when I call it directly -- I get everything there is. However, whenever I try to call it from a running procedure, I get an "access denied" error (-2147024891).
I've tried playing around with the Internet Explorer object, but it only returns a fraction of what MSXML2.XMLHTTP returns -- and not what I want. Can anybody tell me how to overcome the error or get the Internet Explorer object to return what MSXML2.XMLHTTP returns?
This is what I use:
Public Function getHTTP(ByVal sReq As String) As String
On Error GoTo onErr
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", sReq, False: .Send
getHTTP = StrConv(.responseBody, 64)
End With
Exit Function
onErr: MsgBox "Error "&Err &": "&Err.Description,49,"Error opening site"
End Function
It's the same idea as you're using with error handling added... I've never had an issue with it.
More Information:
MSDN: XMLHttpRequest object (Methods & Properties)
Wikipedia: XMLHttpRequest (XHR)
I am new to class programming in vba.
Here is my first attempt using teaching of
:Asynchronous HTTP POST Request in MS Access
I am using word vba.
Here is my CXMLHTTPHandler.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CXMLHTTPHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Dim m_xmlHttp As MSXML2.XMLHTTP
Public Sub Initialize(ByRef xmlHttpRequest As MSXML2.XMLHTTP)
Set m_xmlHttp = xmlHttpRequest
End Sub
Sub OnReadyStateChange()
Attribute OnReadyStateChange.VB_UserMemId = 0
Debug.Print m_xmlHttp.readyState
If m_xmlHttp.readyState = 4 Then
If m_xmlHttp.Status = 200 Then
msgbox m_xmlHttp.responseText
Else
msgbox "Something Went Wrong"
End If
End If
End Sub
Here is my standard module
Option Explicit
Public xmlHttpRequest As MSXML2.XMLHTTP
Function sasynchreq(url As String)
On Error GoTo FailedState
If Not xmlHttpRequest Is Nothing Then Set xmlHttpRequest = Nothing
Dim MyXmlHttpHandler As CXMLHTTPHandler
Set xmlHttpRequest = New MSXML2.XMLHTTP
'Create an instance of the wrapper class.
Set MyXmlHttpHandler = New CXMLHTTPHandler
MyXmlHttpHandler.Initialize xmlHttpRequest
'Assign the wrapper class object to onreadystatechange.
xmlHttpRequest.OnReadyStateChange = MyXmlHttpHandler
'Get the page stuff asynchronously.
xmlHttpRequest.Open "GET", url, True
xmlHttpRequest.send ""
Exit Function
FailedState:
msgbox Err.Number & ": " & Err.Description
End Function
Sub test()
Dim url As String, do_something As String
url = "http://httpbin.org/html"
do_something = sasynchreq(url)
'do somethign with do_something
End Sub
Everything works fine. What if I want to assign httprequest to some variable for example in test sub.?
Sounds like you're after the Property statements. In your case, it would be Property Get (https://msdn.microsoft.com/en-us/library/office/gg264197.aspx).
In your class module, put this:
Public Property Get HttpRequest() As MSXML2.XMLHTTP
Set HttpRequest = m_xmlHttp
End Property
This now gives your Module access to the class variable, like so:
Dim rq as MSXML2.XMLHTTP
set rq = MyXmlHttpHandler.HttpRequest
I think you can expect the ultimate payload predicated on the Send method be present by the time you exit your function. If so, your function signature should look something like:
Function sasynchreq(url As String) As String
and in the body of the function, there should be a:
xmlHttpRequest.send ""
sasynchreq = xmlHttpRequest.responseXML.xml
or something like that. Then do_something would be available right away for use.
Long story short, if there are no synchronicity issues, the way it's currently written, your function is not returning anything back to do_something. Whatever it is you're returning, the function signature and local variable types inside sub test should match. If you are returning an object, you will need to use the Set keyword in both instances.
I want to import data from Anedot, a credit card processing firm, using a HTTP GET request from an MS Access program. Anedot uses a RESTful API and has provided help on there website: https://anedot.com/api/v2
I want to do this with VBA, and associate the import with a button on an MS Access form. I've read that this only possible with XML. Do I create the XML file with VBA?
I'd greatly appreciate some background information on how to get this done, as most of it is flying over my head. I don't really know where to begin and I'm having trouble finding anything useful on google.
So far I've realized I'll need to reference their API via a URL link (which they provide), and that I'll have to authorize my account using my username and a token ID. But how can I do this in VBA?
Thanks.
First of all try to make a request to API using basic authorization. Take a look at the below code as the example:
Sub Test()
' API URL from https://anedot.com/api/v2
sUrl = "https://api.anedot.com/v2/accounts"
' The username is the registered email address of your Anedot account
sUsername = "mymail#example.com"
' The password is your API token
sPassword = "1e56752e8531647d09ec8ab20c311ba928e54788"
sAuth = TextBase64Encode(sUsername & ":" & sPassword, "us-ascii") ' bXltYWlsQGV4YW1wbGUuY29tOjFlNTY3NTJlODUzMTY0N2QwOWVjOGFiMjBjMzExYmE5MjhlNTQ3ODg=
' Make the request
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", sUrl, False
.SetRequestHeader "Authorization", "Basic " & sAuth
.Send
Debug.Print .ResponseText
Debug.Print .GetAllResponseHeaders
End With
End Sub
Function TextBase64Encode(sText, sCharset) ' 05 10 2016
Dim aBinary
With CreateObject("ADODB.Stream")
.Type = 2 ' adTypeText
.Open
.Charset = sCharset ' "us-ascii" for bytes to unicode
.WriteText sText
.Position = 0
.Type = 1 ' adTypeBinary
aBinary = .Read
.Close
End With
With CreateObject("Microsoft.XMLDOM").CreateElement("objNode")
.DataType = "bin.base64"
.NodeTypedValue = aBinary
TextBase64Encode = Replace(Replace(.Text, vbCr, ""), vbLf, "")
End With
End Function
Put your credentials to sUsername and sPassword variables, choose the appropriate URL from API help page and put it to sURL. Then you can parse JSON response from the server (currently you will see the response for /v2/accounts request in Immediate window).
It's a fairly lengthy question to be honest, but lets start with some code to get you going.
This Class Module ("clsXMLHttpMonitor") should help:
Option Explicit
Dim XMLHttpReq As MSXML2.ServerXMLHTTP
Dim RequestedVar As String
Dim P As Object
Public Sub Initialize(ByVal uXMLHttpRequest As Object, Optional RequestedValue As String = "")
RequestedVar = RequestedValue
Set XMLHttpReq = uXMLHttpRequest
End Sub
Sub ReadyStateChangeHandler()
If XMLHttpReq.ReadyState = 4 Then
If XMLHttpReq.Status = 200 Then
'Process the response here
Debug.Print "200 recieved"
Set P = JSON.parse(XMLHttpReq.responseText)
Else
If XMLHttpReq.Status = 404 Then
'Handle it
End If
End If
End If
End Sub
Function returnResponseHeaders() As String
returnResponseHeaders = XMLHttpReq.getAllResponseHeaders
XMLHttpReq.Send
End Function
Function returnFullText() As String
If XMLHttpReq.ReadyState = 4 Then
If XMLHttpReq.Status = 200 Then
returnFullText = XMLHttpReq.responseText
Else
returnFullText = "-1"
End If
Else
returnFullText = ""
End If
End Function
End Function
Use it like this:
Set XMLHttpReq = New MSXML2.ServerXMLHTTP
Set XMLHttpMon = New clsXMLHttpMonitor
XMLHttpMon.Initialize XMLHttpReq
XMLHttpReq.OnReadyStateChange = XMLHttpMon
XMLHttpReq.Open "POST", URL, True
XMLHttpReq.Send strPayload
As you seem to request a Json response from a URL, you can study the Json modules here for a full implementation that collects the Json response in a collection, which you then can use in your code or save to a table. See the demo module for examples:
VBA.CVRAPI
I wrote a VBA code which would take its input(url) from a column of an excel sheet, and return its http status code. The problem I face is that some urls are having Certificate issues and for some websites I am getting Windows Security Alerts. I want a simple solution to automatically click on Yes for all these alerts (if they come at all) as these sites are comletely trusted. I am attaching the the code which checks for the status code.
`'Takes input url as String and return the status(200 is up ,rest all are down)
Function urlCheck(url As String) As Integer
On Error GoTo error_help
Dim http: Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
http.Send
If (Not http.Status = 200) Then
urlCheck = http.Status
Else
urlCheck = http.Status
End If
error_help:
'MsgBox "error"
End Function
`
I have already tried Application.DisplayAlerts = False , it doesn't work
Wrote a small app that accesses a bunch of search websites and puts the results in a word document, which gets run a few hundred times a day.
It saves individual search results in a number of local folders so the next time those words are searched, it grabs them locally instead of loading the website again.
This works fine - even though it's not quick. People are impressed because until a few weeks ago they did this manually by literally loading up six different search websites, searching, and then copying and pasting the results in a word document.
However, our Office's internet is unreliable, and has been down the last half a day. This has meant about 400 bad searches have been saved in the local folders, and inserted into the final documents.
When a person was searching they could tell if the internet was broken and they would do their searches later. Obviously, though, this app can't tell, and because I'm not using APIs or anything, and because I am limited to using the VBA environment (I'm not even allowed MZ tools), I need to find some way to check that the internet is working before continuing with the program flow, without relying on too many references, and preferably without screenscraping for the phrase "404 Page Not Found".
I'm not very familiar with VB, and VBA is ruining me in so many ways, so there's probably some easy way to do this, which is why I'm asking here.
Appreciate any help.
Obviously, your problem has many levels. You should start by defining "connected to the internet", and go on with developing fallback strategies that include not writing invalid files on failure.
As for the "am I connected" question, you can try tapping into the Win32 API:
Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef dwflags As Long, ByVal dwReserved As Long ) As Long
Public Function GetInternetConnectedState() As Boolean
GetInternetConnectedState = InternetGetConnectedState(0&,0&)
End Function
Though depending on your network setup (proxy/NAT/firewall restrictions etc.), Windows might have a different opinion about this than you.
Trying to GET the pages you are interested in, checking on the return status in the HTTP headers (gateway timeout, 404, whatever you expect to happen when it "doen't work) might also be a way to go.
You could use MSXML library & use XMLHttpRequest class to check for things
e.g.
On Error Resume Next
Dim request As MSXML2.XMLHTTP60
request.Open "http://www.google.com"
request.Send
Msgbox request.Status
The status will give you HTTP Status code of what happened to the request.
You might have to do some more checks, depending on your scenario.
Hope that helps.
Use the following code to check for internet connection
first anable XML v6.0 in your references
Function checkInternetConnection() As Integer
'code to check for internet connection
'by Daniel Isoje
On Error Resume Next
checkInternetConnection = False
Dim objSvrHTTP As ServerXMLHTTP
Dim varProjectID, varCatID, strT As String
Set objSvrHTTP = New ServerXMLHTTP
objSvrHTTP.Open "GET", "http://www.google.com"
objSvrHTTP.setRequestHeader "Accept", "application/xml"
objSvrHTTP.setRequestHeader "Content-Type", "application/xml"
objSvrHTTP.Send strT
If err = 0 Then
checkInternetConnection = True
Else
MsgBox "Internet connection not estableshed: " & err.Description & "", 64, "Additt !"
End If
End Function
Unfortunately, this is a bit of a difficult question to answer for a couple of reasons:
How do you define a non-working internet connection? Do you check for a valid IP address? Do you ping out? How do you know that you have permissions to check these things? How do you know that the computer's firewall/antivirus isn't causing wonky behavior?
Once you've established that the connection is working, what do you do if the connection drops mid-operation?
There are probably ways to do what you want to do, but a lot of "devil's in the details" type things tend to pop up. Do you have any way to check that the saved search is valid? If so, that would probably be the best way to do this.
Building on shakalpesh's answer and the comments to it, there are (at least) two ways to get the web page into Word without parsing the XML returned by the XMLHTTP60 object.
(NB the HTTP status code of 200 indicates that "the request has succeeded" - see here)
write the XMLHTTP60.ResponseText out to a text file and then call Documents.Open on that text file
If (xhr.Status = 200) Then
hOutFile = FreeFile
Open "C:\foo.html" For Output As #hOutFile
Print #hOutFile, xhr.responseText
Close #hOutFile
End If
// ...
Documents.Open "C:\foo.html"
This has the disadvantage that some linked elements may be lost and you'll get a message box when the file opens
check the URL status with the XMLHTTP60 object and then use Documents.Open to open the URL as before:
If (xhr.Status = 200) Then
Documents.Open "http://foo.bar.com/index.html"
End If
There is a slight chance that the XMLHTTP60 request could succeed and the Documents.Open one fail (or vice versa). Hopefully this should be a fairly uncommon event though
I found most answers here and elsewhere confusing or incomplete, so here is how to do it for idiots like me:
'paste this code in at the top of your module (it will not work elsewhere)
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Const INTERNET_CONNECTION_MODEM As Long = &H1
Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_PROXY As Long = &H4
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
'paste this code in anywhere
Function IsInternetConnected() As Boolean
Dim L As Long
Dim R As Long
R = InternetGetConnectedState(L, 0&)
If R = 0 Then
IsInternetConnected = False
Else
If R <= 4 Then IsInternetConnected = True Else IsInternetConnected = False
End If
End Function
'your main function/calling function would look something like this
Private Sub btnInternetFunction_Click()
If IsInternetConnected() = True Then
MsgBox ("You are connected to the Internet")
'code to execute Internet-required function here
Else
MsgBox ("You are not connected to the Internet or there is an issue with your Internet connection.")
End If
End Sub
This is what I use. I prefer it because it doesn't require any external references or DLLs.
Public Function IsConnected()
Dim objFS As Object
Dim objShell As Object
Dim objTempFile As Object
Dim strLine As String
Dim strFileName As String
Dim strHostAddress As String
Dim strTempFolder As String
strTempFolder = "C:\PingTemp"
strHostAddress = "8.8.8.8"
IsConnected = True ' Assume success
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Wscript.Shell")
If Dir(strTempFolder, vbDirectory) = "" Then
MkDir strTempFolder
End If
strFileName = strTempFolder & "\" & objFS.GetTempName
If Dir(strFileName) <> "" Then
objFS.DeleteFile (strFileName)
End If
objShell.Run "cmd /c ping " & strHostAddress & " -n 1 -w 1 > " & strFileName, 0, True
Set objTempFile = objFS.OpenTextFile(strFileName, 1)
Do While objTempFile.AtEndOfStream <> True
strLine = objTempFile.Readline
If InStr(1, UCase(strLine), "REQUEST TIMED OUT.") > 0 Or InStr(1, UCase(strLine), "COULD NOT FIND HOST") > 0 Then
IsConnected = False
End If
Loop
objTempFile.Close
objFS.DeleteFile (strFileName)
objFS.DeleteFolder (strTempFolder)
' Remove this after testing. Function will return True or False
MsgBox IsConnected
End Function
I encourted this same problem and after googling a lot, I realized there was a simpler way to do it... It requires the user to enable the Microsoft Internet Explorer Controlers library, but that is all. The idea is that your code navigates to a website (in this case google), and after getting the webpage document (HTML). puts a value in the search box.
Sub Test1()
On Error GoTo no_internet 'Error handler when no internet
Dim IE As New SHDocVw.InternetExplorer
IE.Visible = False 'Not to show the browser when it runs
IE.navigate "www.google.com" 'navigates to google
Do While IE.ReadyState <> READYSTATE_COMPLETE 'loops until it is ready
Loop
'Here It gets the element "q" from the form "f" of the HTML document of the webpage, which is the search box in google.com
'If there is connection, it will run, quit and then go to the msgbox.
'If there is no connection, there will be an error and it will go to the error handler "no_internet" that is declared on top of the code
IE.document.forms("f").elements("q").Value = "test"
IE.Quit
MsgBox "Internet Connection: YES"
Exit Sub
no_internet:
IE.Quit
MsgBox "Internet Connection: NO" ' and here it will know that there is no connection.
End Sub