Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
cBrowser - web service access
'gistThat@mcpher.com :do not modify this line - see ramblings.mcpher.com for details: updated on 11/22/2013 11:15:19 AM : from manifest:7471153 gist https://gist.github.com/brucemcpherson/3423912/raw/cBrowser.cls
Option Explicit
' acknowledgement
' http://pastie.org/1192157 for basic authentication 'how to'
'for more about this
' http://ramblings.mcpher.com/Home/excelquirks/classeslink/data-manipulation-classes
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' http://ramblings.mcpher.com/Home/excelquirks/codeuse
' v2.14
Private pLockActive As Boolean
Private pLockdown As Boolean
Private pSuccessCode As String
Private pDeniedCode As String
Private pResponseHeaders As String
Private pOptionUrl As String
Private pHtml As String
Private pText As String
Private WithEvents pIeOB As InternetExplorer
Private pStatus As Long
' everything to do with accessing web pages from Excel
Public Property Get browser() As InternetExplorer
Set browser = pIeOB.Application
End Property
Public Property Get isOk() As Boolean
isOk = (pStatus = 200 Or pStatus = 201)
End Property
Public Property Get status() As Long
status = pStatus
End Property
Public Property Get responseHeaders() As String
responseHeaders = pResponseHeaders
End Property
Public Property Get optionURL() As String
optionURL = pOptionUrl
End Property
Public Property Get successCode() As String
successCode = pSuccessCode
End Property
Public Property Get deniedCode() As String
deniedCode = pDeniedCode
End Property
Public Property Get Text() As String
Text = pText
End Property
Public Property Get url() As String
url = pHtml
End Property
Public Function init() As cBrowser
Set pIeOB = New InternetExplorer
Set init = Me
End Function
Public Function Navigate(fn As String, Optional lockDown As Boolean = False, _
Optional visible As Boolean = True) As cBrowser
' bring up the web page requested
pHtml = fn
pLockdown = lockDown
pSuccessCode = vbNullString
pDeniedCode = vbNullString
With browser
If lockDown Then
.AddressBar = False
.MenuBar = False
.Resizable = False
End If
.visible = visible
.Navigate2 pHtml
pLockActive = True
' will fire document complete, then we can set this off
Do
DoEvents
If Not pLockdown Then
pLockActive = Not (.ReadyState = READYSTATE_COMPLETE And Not .Busy)
End If
Loop Until Not pLockActive
End With
Set Navigate = Me
End Function
Public Function httpPost(fn As String, _
Optional data As String = vbNullString, Optional isjson As Boolean = False, _
Optional authHeader As String = vbNullString, _
Optional additionalHeaders As Object = Nothing, _
Optional method As String = "POST") As String
pHtml = fn
Dim v As Variant, ohttp As MSXML2.ServerXMLHTTP60
Set ohttp = New MSXML2.ServerXMLHTTP60
With ohttp
.setOption 2, .getOption(2) - SXH_SERVER_CERT_IGNORE_CERT_DATE_INVALID
.Open method, pHtml, False
If isjson Then
.SetRequestHeader "Content-Type", "application/json"
Else
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
End If
If (authHeader <> vbNullString) Then
ohttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
ohttp.SetRequestHeader "Authorization", authHeader
End If
extraHeaders ohttp, additionalHeaders
'Debug.Print method, pHtml
ohttp.Send data
storeStuff ohttp
End With
httpPost = pText
Set ohttp = Nothing
End Function
Private Function extraHeaders(ohttp As Object, additionalHeaders As cJobject) As Object
Dim job As cJobject
' any extra headers?
If Not additionalHeaders Is Nothing Then
For Each job In additionalHeaders.children
ohttp.SetRequestHeader job.key, job.value
Next job
End If
Set extraHeaders = ohttp
End Function
Public Function httpGET(fn As String, _
Optional authUser As String = vbNullString, _
Optional authPass As String = vbNullString, _
Optional accept As String = vbNullString, _
Optional timeout As Long = 0, _
Optional authHeader As String = vbNullString, _
Optional additionalHeaders As Object = Nothing, _
Optional method As String = "GET") As String
pHtml = fn
Dim ohttp As Object, job As Object
Set ohttp = New MSXML2.ServerXMLHTTP60
' can have change of timeout for complex/long queries
If timeout = 0 Then timeout = 30
ohttp.SetTimeouts 0, 30 * 1000, 30 * 1000, timeout * 1000
Call ohttp.Open(method, pHtml, False)
If (authUser <> vbNullString) Then
' need to do basic authentication
' acknowledgement to http://pastie.org/1192157
ohttp.SetRequestHeader "Content-Type", "application/json"
ohttp.SetRequestHeader "Accept", "application/json"
ohttp.SetRequestHeader "Authorization", "Basic " + _
Base64Encode(authUser + ":" + authPass)
End If
' some times we need to set the accept header
If accept <> vbNullString Then
ohttp.SetRequestHeader "Accept", accept
End If
' this would be if we were doing an oauth2
If (authHeader <> vbNullString) Then
ohttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
ohttp.SetRequestHeader "Authorization", authHeader
End If
extraHeaders ohttp, additionalHeaders
'Debug.Print method, pHtml
ohttp.Send ""
storeStuff ohttp
httpGET = pText
Set ohttp = Nothing
End Function
Private Sub storeStuff(o As Object)
With o
pStatus = .status
pText = .ResponseText
pResponseHeaders = .GetAllResponseHeaders()
End With
End Sub
Public Function Element(eID As String) As IHTMLElement
On Error GoTo crappedout
Set Element = browser().Document.getElementById(eID)
Exit Function
crappedout:
Set Element = Nothing
End Function
Public Function elementTags(tag As String) As IHTMLElementCollection
On Error GoTo crappedout
Set elementTags = browser().Document.getElementsByTagName(tag)
Exit Function
crappedout:
Set elementTags = Nothing
End Function
Public Property Get ElementText(eID As String) As String
Dim e As IHTMLElement
Set e = Element(eID)
If (e Is Nothing) Then
ElementText = ""
Else
ElementText = e.value
End If
End Property
Public Sub kill()
browser.Quit
End Sub
Private Sub Class_Initialize()
pLockActive = False
End Sub
Private Sub Class_Terminate()
Set pIeOB = Nothing
End Sub
Public Sub tearDown()
If Not pIeOB Is Nothing Then
kill
Set pIeOB = Nothing
End If
End Sub
Private Sub pIeOB_OnQuit()
pLockActive = False
End Sub
Private Sub pIeOB_TitleChange(ByVal Text As String)
Dim s As String, f As String
f = "Denied error="
s = "Success code="
If (pLockdown) Then
If (left(Text, Len(s)) = s) Then
pSuccessCode = Mid(Text, Len(s) + 1)
pLockActive = False
ElseIf (left(Text, Len(f)) = f) Then
pDeniedCode = Mid(Text, Len(f) + 1)
pLockActive = False
End If
If (Not pLockActive) Then
With browser
.visible = False
End With
End If
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.