The VBA code below is supposed to call a REST API to grant user access to the file or not. If the REST API returns allow then the code should close normally and grant access, if the REST API retuns disallow then the program should notify user and close workbook. If there is no Internet access, then the user should be notified and the work book should be closed.
My question is how do I code so the REST API response is handled by the macro properly so that it will either end normally or close due to the disallow response from url?
Here is the VBA code so far:
Private Sub Workbook_activate()
Application.EnableCancelKey = xlDisabled
' Run the Error handler "ErrHandler" when an error occurs.
On Error GoTo Errhandler
ActiveWorkbook.FollowHyperlink Address:="https://mysite.com/licensing/getstatus.php?", NewWindow:=True
' If response is allow
' Exit the macro so that the error handler is not executed.
****what goes here??****
Exit Sub
' If response is disallow
****what goes here??****
MsgBox "Your license key is not valid. Please check your key or contact customer service."
ActiveWorkbook.Close SaveChanges:=False
Errhandler:
' If no Internet Access, display a message and end the macro.
MsgBox "An error has occurred. You need Internet access to open the software."
ActiveWorkbook.Close SaveChanges:=False
End Sub
here an example for a simple HttpWebRequest:
Dim oRequest As Object
Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
oRequest.Open "GET", "https://mysite.com/licensing/getstatus.php?"
oRequest.Send
MsgBox oRequest.ResponseText
If you are behind a proxy you can use something like this:
Const HTTPREQUEST_PROXYSETTING_PROXY = 2
Dim oRequest As Object
Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
oRequest.setProxy HTTPREQUEST_PROXYSETTING_PROXY, "http://proxy.intern:8080"
oRequest.Open "GET", "https://mysite.com/licensing/getstatus.php?"
oRequest.Send
MsgBox oRequest.ResponseText
and if you want to use POST (instead of the GET method) to pass some values to the webserver, you can try this:
Dim oRequest As Object
Set oRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
oRequest.Open "POST", "https://mysite.com/licensing/getstatus.php"
oRequest.SetRequestHeader "Content-Typ", "application/x-www-form-urlencoded"
oRequest.Send "var1=123&anothervar=test"
MsgBox oRequest.ResponseText
Related
I found the following code on an excel forum:
Function URLExists(url As String) As Boolean
Dim Request As Object
Dim ff As Integer
Dim rc As Variant
On Error GoTo EndNow
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
With Request
.Open "GET", url, False
.Send
rc = .StatusText
End With
Set Request = Nothing
If rc = "OK" Then URLExists = True
Exit Function
EndNow:
End Function
I see no reason why it would not work if I use a legitiamte URL. I have been testing it and keep on getting a FALSE returned. Opening the same URL in a browser works.
I suspect that this might have something to do with our coporate security settings. How can I test whether the code works or if it is a security issue?
The function goes to the error line on .Send
I have an excel-sheet which contains many links.
How do I open them all at once in a new tab with my default browser?
Like this? Included checking url is valid (basic check). The advantage here is you adapt to log information about the response from the URL.
Option Explicit
Sub TEST()
Dim h As Hyperlink
For Each h In ActiveSheet.Hyperlinks
If UrlOK(h.Address) Then h.Follow
Next h
End Sub
Public Function UrlOK(ByVal url As String) As Boolean
Dim request As Object
Dim respCode As Long
On Error Resume Next
Set request = CreateObject("WinHttp.WinHttpRequest.5.1")
With request
.Open "GET", url, False
.Send
respCode = .Status
End With
If respCode = 200 Then UrlOK = True
On Error GoTo 0
End Function
Edit: Thanks to #Omegastripes for noting
1) If you use MSXML2.XMLHTTP over WinHttp.WinHttpRequest.5.1 you get a more reliable result
Benefits include (amongst others):
A) Simplified code to open a URL.
B) Separate sessions do not impact each other.
C) Protected Mode IE Support
D) Credential Cache
2) Use HEAD over GET, in the request, to reduce network traffic
With a HEAD request, a server will only return the headers of a resource, rather than the resource itself.
So you could use a revised, more efficient function, as follows:
Public Function UrlOK(ByVal url As String) As Boolean
Dim request As Object
Dim respCode As Long
On Error Resume Next
Set request = CreateObject("MSXML2.XMLHTTP")
With request
.Open "HEAD", url, False
.Send
respCode = .Status
End With
If respCode = 200 Then UrlOK = True
On Error GoTo 0
End Function
Image of code in a standard module and where to place cursor to execute Test sub.
That's pretty easy in VBA
Sub OpenAll()
Dim H As Hyperlink
For Each H In ActiveWorkbook.ActiveSheet.UsedRange.Hyperlinks
H.Follow
Next
End Sub
If there are invalid URLs you can stop the code from erroring like this:
Sub OpenAll()
Dim H As Hyperlink
For Each H In ActiveWorkbook.ActiveSheet.Hyperlinks
On Error Resume Next
H.Follow
On Error GoTo 0
Next
End Sub
We have an internal website, which supports working with API also. When i access an API URI in browser i'm getting JSON response, but if i make the same call from Excel i'm getting 401, invalid credentials. Please find my VBA Code below.
Dim Serv2 As New WinHttpRequest
Sub Conn()
Url = "https://uri/api/nag/"
With Serv2
.Open "GET", Url, False
.Send
MsgBox .Status & " " & .ResponseText
End With
Set Serv2 = Nothing
End Sub
Note: The url provided is sample data.
Many Thanks in advance !!!
I have set up a keyboard shortcut (ctrl+alt+c) That calculates the users selection pretty basic I grabbed off of here
Private Sub Workbook_Open()
Application.OnKey "^%c", "CalculateSelection"
End Sub
Sub CalculateSelection()
On Error GoTo NoSelection
If Not Selection Is Nothing Then
If TypeName(Application.Selection) = "Range" Then
Dim Rng As Range
Set Rng = Application.Selection
Rng.Calculate
End If
End If
Exit Sub
NoSelection:
MsgBox ("No Range Selected")
End Sub
This works perfectly fine on all other cell and i can save my work when its all completed.
If I use this function on a cell that calls an API the function works fine until you save, Microsoft stops working entirely and I have no idea why.
Does anyone know why this might be happening? would this be cause by some object not being destroyed or is my excel corrupt?
All the API function work fine I've had no errors with them until I used this sub on them.
This is the function that sends the data to the API. It has different functions that are called from the sheet to format the data to XML and check whether the data being passed is correct and fully calculated.
Private Function PostToApiXmlToXml(Data As String, Route As String)
'Initialise Document Object Model to hold the XML
'And the xmlHttp to handle Sending Data
Dim xmlhttp As MSXML2.ServerXMLHTTP60
Dim XMLDOM As MSXML2.DOMDocument60
Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
Set XMLDOM = New MSXML2.DOMDocument60
'Load entire Document before moving on
'Data is a string but must conatin opening and closing tags.
XMLDOM.async = False
XMLDOM.LoadXML (Data)
'Using the Http object
With xmlhttp
Call .setOption(2, SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS)
'Set up a POST to the Base Address + Route
.Open "POST", BaseAddress + Route, False
'Content-Type Header is requred to let the API Know What type of Data you are Sending
.setRequestHeader "Content-Type", "application/xml"
'Accept Header Lets the Api know we want to recieve JSON Data
.setRequestHeader "Accept", "application/json"
'Send the Dom as XML in the http object
.send (XMLDOM.Xml)
'Take in the Response as text
PostToApiXmlToXml = .responseText
End With
Set xmlhttp = Nothing
End Function
I can use the keyboard shortcut anywhere on the sheet and save with no problems. and i can use it on single cells with API calls and press ctrl + s and it saves fine. But if i select multiple and press ctrl + alt + c then save with ctrl + s it corrupts the save and restores to previous save doesn't let me open or view any of the problems with the corrupted version.
I'm trying to use VBA to test URLs for bad links and redirects.
I'm able to obtain redirect URLs using HTTP request GET method for URLs that return a 3xx series .Status response using either MSXML2 or WinHttp libraries through VBA.
When I attempt this method for some URLs that have legitimate (intended by the URL site) redirects, I receive an error when trying to obtain the Request object.
For example, when this URL is entered into a browser:
http://www.teconnectivity.com
...the browser will ultimately arrive at this address:
http://www.te.com/en/home.html
However this VBA code will return Error -2147012744: "The server returned an invalid or unrecognized response". The error is thrown on the .Send statement.
Sub Test()
Debug.Print sGetRedirectURL("http://www.teconnectivity.com/")
End Sub
Private Function sGetRedirectURL(ByVal sURL As String) As String
Dim oRequest As WinHttp.WinHttpRequest
Dim sReturn As String
Set oRequest = New WinHttp.WinHttpRequest
On Error GoTo ErrProc
With oRequest
.Option(WinHttpRequestOption_EnableRedirects) = False
.Open "GET", sURL, False
.Send
If Left$(.Status, 1) = "3" Then
sReturn = .GetResponseHeader("Location")
End If
End With
On Error GoTo 0
ExitProc:
sGetRedirectURL = sReturn
Exit Function
ErrProc:
Debug.Print Err.Number & ": " & Err.Description
Resume ExitProc
End Function
How is my browser able to get to the destination: http://www.te.com/en/home.html, if an HTTP request with that URL returns an error?
I can use the browser's application to get the final destination URL like this:
Function sGetFinalURL(sURL As String) As String
Dim oAppIE As Object
Dim sReturn As String
Set oAppIE = CreateObject("InternetExplorer.Application")
With oAppIE
.Navigate sURL
Do While .Busy
Loop
sReturn = .document.url
.Quit
End With
Set oAppIE = Nothing
sGetFinalURL = sReturn
End Function
However, that approach will also return URLs for ISP redirects or other hijacks.
The approach I ended up taking for this was to use the browser application to try to navigate to a non-existent domain URL. If the browser arrives at a URL, then that means it has been redirected by the ISP or something other than the non-existent domain.
Private Function sGetNXDomainRedirect() As String
'--attempts to return the domain used to redirect non-existant
' domain urls. Used to distinguish legitimate redirects
' from ISP redirects or other hijacks
'--returns "NoRedirect" if the bogus url is not redirected.
Dim sReturn As String
Dim oIEapp As Object
Dim uTest As udtHttpInfo
Const sBOGUS_URL As String = _
"http://wwXYXw.NXDomainToTest"
Set oIEapp = CreateObject("InternetExplorer.Application")
With oIEapp
.Navigate sBOGUS_URL
Do While .Busy
Loop
On Error Resume Next
sReturn = .document.Domain
On Error GoTo 0
.Quit
End With
Set oIEapp = Nothing
If Len(sReturn) = 0 Then sReturn = "NoRedirect"
sGetNXDomainRedirect = sReturn
End Function
Link to complete code on MrExcel.com forum
Once that "ISP Redirect" site is known, then the IE Application can be used to test for bad links or legitimate redirects. If the Navigation through the IE Application returns a domain other than the ISP Redirect domain, then I interpret that as a legitimate redirect.