Ukázka kódu pro MS Excel

V následující ukázce je funkční kód pro MS Excel, který zajišťuje XML komunikaci se serverem pro předávání požadavků a získávání odpovědí, které je pak možné jiným kódem prezentovat v tabulce apod. Oproti předchozímu kódu pro OpenOffice, je kód pro MS Excel obsáhlejší a nejde o login, ale o propracovanější proceduru pro odesílání argumentem předaného XML uzlu s požadavkem, ověřování odpovědi a vracení opět již načteného XML do DOMu:

Public Function GetXMLFromServer(objReqNd As IXMLDOMElement) As IXMLDOMElement
'odeslání požadavku na server; funkce pro komunikaci se serverem vrací kmenový uzel načteného DOMu;
Dim objResDoc As New DOMDocument60
Dim i As Integer
mstrError = ""
'
'--- Odeslání požadavku ---
'připravíme dokument pro odeslání
objResDoc.async = False
mstrLastRespStatus = "": mintLastRespStatus = 0
'
' - provedeme opakovaný pokus pro případ prázdného výsledku
For i = 1 To 10
'objektový druh serveru využívající odkaz solve
mobjXhttp.Open "POST", FxnServerAddress + "/solve", False, mstrLogName, mstrLogPsw
mobjXhttp.setRequestHeader "Content-Type", "text/xml"
'
mobjXhttp.send objReqNd.XML
'ověříme výsledek
mintLastRespStatus = mobjXhttp.Status: mstrLastRespStatus = mobjXhttp.statusText
If mintLastRespStatus <> 408 Then Exit For
Next
'ověříme výsledek po ukončení cyklu
If mintLastRespStatus <> 200 Then _
Err.Raise 55, , "Chyba při HTTP komunikaci se serverem. Chyba č. " + CStr(mintLastRespStatus) + ", popis: " + _
mstrLastRespStatus + vbCrLf + vbCrLf + "Požadavek: " + vbCrLf + Left(objReqNd.XML, 3000)
'
'provedeme pokus o načtení vráceného XML a ověření jeho platnosti
objResDoc.loadXML mobjXhttp.ResponseText
If objResDoc.parseError.errorCode <> 0 Then _
Err.Raise "Chyba při načítání XML vráceného na požadavek <" + objReqNd.nodeName + "> ze serveru. " + vbCrLf + _
"Důvod: " + objResDoc.parseError.reason + "" + vbCrLf + "Řádek: " + CStr(objResDoc.parseError.Line) + _
", pozice: " + CStr(objResDoc.parseError.linepos) + vbCrLf + vbCrLf + "Response text: " + vbCrLf + _
Left(mobjXhttp.ResponseText, 1000)
'
'ověříme existenci uzlů
If IsNull(objResDoc.documentElement) Then _
Err.Raise 55, , "Na požadavek <" + objReqNd.nodeName + "> server nevrátil platný obsah odpovědi." + vbCrLf + vbCrLf + "Obsah odpovědi:" + vbCrLf + Left(mobjXhttp.ResponseText, 1000)
'
If objResDoc.documentElement.childNodes.Length = 0 Then _
Err.Raise 55, , "Na požadavek <" + objReqNd.nodeName + "> server nevrátil platný obsah odpovědi." + vbCrLf + vbCrLf + "Obsah odpovědi:" + vbCrLf + Left(mobjXhttp.ResponseText, 1000)
'
'ověříme, zda potomkem není hlášení chyby
Set objErrElm = objResDoc.selectSingleNode("/response/error")
If Not objErrElm Is Nothing Then _
Err.Raise 55, , "Server vrátil hlášení o chybě č. " + objErrElm.GetAttribute("number") + "." + vbCrLf + vbCrLf + _
"Server oznámil:" + vbCrLf + objErrElm.GetAttribute("detail")
'
'nastavíme návratovou hodnotu
Set GetXMLFromServer = objResDoc.documentElement
'
End Function