EVE Technology Lab

Public Function ewaGetXML(ByVal sURL As String, Optional ByVal sParams As String = vbNullString) As String
'------------------------------------------------------------------------------
'Purpose  : Retrieves a XML file from a web service (web server)
'
'Prereq.  : Reference to MS XML (6.0), set in menu Extras -> References
'Parameter: sURL    - URL to query, i.e. https://api.eveonline.com/server/ServerStatus.xml.aspx
'           sParams - Parameters to be passed to the web service
'                     i.e. keyID=MyAPIKeyID&vCode=MyVCode=&characterID=12345
'Returns  : Contents of XML
'Note     : -
'
'   Author: Hel O'Ween 07.06.2014
'   Source: -
'  Changed: -
'------------------------------------------------------------------------------
Dim oHTTP As MSXML2.ServerXMLHTTP
Dim bolResult As Boolean
Dim sHTTPStatus As String, sResult As String
Dim lAPIResult As Long, sAPIText As String, lRetry As Long

On Error GoTo GetXMLErrHandler

' Create instance of MS XML parser
Set oHTTP = New MSXML2.ServerXMLHTTP
    
' ** Timeouts
' Set timeouts (in milliseconds) if needed, default timeouts are:
' - ResolveTo:  0
' - ConnectTo:  60000
' - SendTo:     300000
' - ReceiveTo:  4800000
oHTTP.setTimeouts eHTTPTimeouts.ResolveTo, eHTTPTimeouts.ConnectTo, eHTTPTimeouts.SentTo, eHTTPTimeouts.ReceiveTo
    
' Prepare the HTTP POST command
oHTTP.Open "POST", sURL, True

' ** Proxy
' Configure web proxy, if necessary
' specify the proxy server either via its host name or IP address
'oHTTP.setProxy SXH_PROXY_SET_PROXY, my.proxy.tld

' In case the proxy needs authentification ...
'oHTTP.setProxyCredentials MyUsername, MyPassword

' ** Misc. HTTP headers
' * The folowing part sets HTTP headers.
' Be polite and let the server know the name of your tool
oHTTP.setRequestHeader "USER-AGENT", "MyTool"
' Required header for letting the server know we're using the HTTP POST
' method to query for information and that we're passing parameters to the
' server
oHTTP.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
oHTTP.setRequestHeader "CONTENT-LENGTH", CStr(Len(sParams))

' Info headers. CCP requests that you provide contact information via X-headers
' in order to contact you in case you're tool runs 'amok' on their servers.
' They might otherwise just ban your IP address from the API servers
oHTTP.setRequestHeader "X-Developer-Contact", "myemail@mydomain.test"
' Duplicate the tool information
oHTTP.setRequestHeader "X-Application-Info", "MyTool"
    
' Add the necessary parameters for the query
' i.e. keyID=MyAPIKeyID&vCode=MyVCode=&characterID=12345
oHTTP.send sParams

' Asynchronous sending of request to the web service
Do While oHTTP.readyState < eHTTPReadyState.Loaded
   
   DoEvents

   ' Count retries so we don't end up in an endless loop
   lRetry = lRetry + 1
   ' Keep waiting for the server's answer
   oHTTP.waitForResponse eHTTPTimeouts.ConnectTo
   
   If lRetry > 5 Then
      Exit Do
   End If
   
Loop

lRetry = 0

Do While oHTTP.readyState < eHTTPReadyState.Completed
   
   DoEvents

   ' Count retries so we don't end up in an endless loop
   lRetry = lRetry + 1
   ' Keep waiting for the server's answer
   oHTTP.waitForResponse eHTTPTimeouts.ReceiveTo

   If lRetry > 5 Then
      Exit Do
   End If
   
Loop

' Remember the web server's status answer
sHTTPStatus = CStr(oHTTP.Status) & vbNewLine & oHTTP.statusText

' We received a OK - 200?
If oHTTP.Status = 200 Then

   sResult = oHTTP.responseXML.XML
   
   ' We receive a response, but is there content?
   If Len(sResult) Then
      bolResult = True
   Else
      bolResult = False
   End If
   
Else
   
   ' Even though the server returned a status other than OK - 200, it still might
   ' send an XML response, see https://forums.eveonline.com/default.aspx?g=posts&t=287747&find=unread
   sResult = oHTTP.responseXML.XML
   
   If Len(sResult) Then
      bolResult = True
   Else
      bolResult = False
   End If

End If

'------------------
GetXMLErrExit:

Set oHTTP = Nothing
If bolResult = True Then
   ewaGetXML = sResult
Else
   ewaGetXML = "No results returned"
End If

On Error GoTo 0
Exit Function

'------------------
GetXMLErrHandler:

' ** Do some logging/error reporting here
bolResult = False
Resume GetXMLErrExit

End Function
'==============================================================================