'//-----------------------------------------------------------------------
'//
'//  Copyright 2002 AGAT Software Solutions.  All Rights Reserved.
'//
'//  File:         XmlClient.vbs
'//
'//  Description:  This script allows web authors to load Xml From ASP page 
'//                and get error by the standart Err Object	
'//
'//  Version 1.0
'//----------------------------------------------------------------------
option explicit
'____________________________________________________________________

'************************************
' Load xml to Dom
'************************************
sub loadXml (url, dom)
	dim intr

	dom.async = false
	dom.load url
	
	Do While cstr(dom.readyState) <> "4" and cstr(dom.readyState) <> "complete"
		intr=window.setInterval (GetRef("a"), 1000)
	Loop
	window.clearInterval intr
	
	if dom.xml="" then
		xmlHttp url,""
	elseif ucase(dom.documentelement.nodename)="ERROR" or dom.documentelement.nodename="ExceptionInformation" then
		raiseError(dom)
	end if
end sub
'____________________________________________________________________

'************************************
' Load xml to XmlHttp Object from web service
'************************************

function xmlHttp (url,sRequest)
	dim objXmlhttp
	set objXmlhttp = createobject("Msxml2.XMLHTTP")
	xmlHttp = xmlHttpWithObj (objXmlhttp,url,sRequest)
	set objXmlhttp = nothing
end function

function xmlHttpWithObj (objXmlhttp,url,sRequest)
	dim intr
	dim strRequest
	dim oXmlTmp
	dim sCharSet
	dim sXml,btXml
	dim i,i1,i2
	const OK_STATUS=200
	
	on error resume next

	set oXmlTmp=nothing
	strRequest=trim(sRequest)
	objXmlhttp.Open "POST", url,false
	
	if not(left(strRequest,1)="<" or lcase(left(strRequest,3))="%3c") then
		objXmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
		objXmlhttp.setRequestHeader "Content-Length", Len(strRequest)
	end if

	if strRequest <> "" then
		objXmlhttp.Send strRequest
	else
		objXmlhttp.Send
	end if 

	Do While cstr(objXmlhttp.readyState) <> "4" and cstr(objXmlhttp.readyState) <> "complete"
		intr=window.setInterval (GetRef("a"), 1000)
	Loop
	window.clearInterval intr

	if objXmlhttp.status<>OK_STATUS then '200 OK
		Err.Raise objXmlhttp.status,url,objXmlhttp.statusText & vbNewLine & objXmlhttp.responseText
	elseif objXmlhttp.responseXML.XML = "" then
		sXml=objXmlhttp.responseText
		set oXmlTmp=CreateObject("MSXML2.DOMDocument")
		oXmlTmp.loadXML(sXml)
		
		if oXmlTmp.xml="" then
			i=instr(1,sXml,"encoding",1)
			if i>0 then
				i1=instr(i,sResText,"""")
				i2=instr(i1+1,sResText,"""")
				sCharSet=mid(sResText,i1+1,i2-i1-1)
				btXml=BufferToString(objXmlhttp.responseBody,sCharSet)
				oXmlTmp.loadXML(btXml)
			end if
		end if

		if oXmlTmp.xml="" then _
			oXmlTmp.loadXML(ReplaceInvalidChars(sXml))
		
		if oXmlTmp.xml="" then
			raiseError(objXmlhttp.responseXML)
		elseif ucase(oXmlTmp.documentElement.nodeName)="ERROR" or oXmlTmp.documentElement.nodeName="ExceptionInformation" then
			raiseError(oXmlTmp)
		end if
	elseif ucase(objXmlhttp.responseXML.documentelement.nodename)="ERROR" or objXmlhttp.responseXML.documentelement.nodename="ExceptionInformation" then
		raiseError(objXmlhttp.responseXML)
	end if 

	if objXmlhttp.status=OK_STATUS then
		if oXmlTmp is nothing then
			xmlHttpWithObj =objXmlhttp.responseXML.documentelement.xml
		else
			xmlHttpWithObj=oXmlTmp.documentElement.xml
			set oXmlTmp=nothing
		end if
	end if

end function
'____________________________________________________________________

function xmlHttpToAsmx (url,sRequest)
	xmlHttpToAsmx=xmlHttp(url,sRequest)
end function
'____________________________________________________________________

'************************************
' Raise Error object
'************************************
private sub raiseError (errDom)
	on error resume next
	dim num,source,des
	
	if errDom.xml = "" then
		if errDom.parseError.errorCode <> 0 then
			num = Clng(errDom.parseError.errorCode)
			des = Cstr(errDom.parseError.reason)
			source = Cstr(errDom.parseError.url)
		end if
	elseif errDom.documentelement.nodename="ExceptionInformation" then
		num = vbObjectError + 999
		des = errDom.documentElement.xml
		source = "Dot.Net server side error"
	else
		num = errDom.documentElement.childnodes(0).attributes.getNamedItem("Number").text
		des = errDom.documentElement.childnodes(0).attributes.getNamedItem("Description").text
		source = errDom.documentElement.childnodes(0).attributes.getNamedItem("Source").text
	end if
	
	Err.Raise num,source,ReplaceInvalidChars(des)
	
end sub

sub a()
end sub
'____________________________________________________________________

'2003 Antonin Foller, http://www.motobit.com
Function BufferToString(Binary, CharSet)
  Const adTypeText = 2
  Const adTypeBinary = 1
  
  'Create Stream object
  Dim BinaryStream 'As New Stream
  Set BinaryStream = CreateObject("ADODB.Stream")
  
  'Specify stream type - we want To save text/string data.
  BinaryStream.Type = adTypeBinary
  
  'Open the stream And write text/string data To the object
  BinaryStream.Open
  BinaryStream.Write Binary
  
  
  'Change stream type To binary
  BinaryStream.Position = 0
  BinaryStream.Type = adTypeText
  
  'Specify charset For the source text (unicode) data.
  If Len(CharSet) > 0 Then
    BinaryStream.CharSet = CharSet
  Else
    BinaryStream.CharSet = "us-ascii"
  End If
  
  'Open the stream And get binary data from the object
  BufferToString = BinaryStream.ReadText
End Function
'____________________________________________________________________

function ReplaceInvalidChars(str)
	dim i
	dim newStr
	
	newStr=str
	for i=1 to 31
		if i<>9 and i<>10 and i<>13 then
			newStr=Replace(newStr,"&#" & CStr(i) & ";","{chr(" & CStr(i) & ")}")
			newStr=Replace(newStr,"&#x" & Hex(i) & ";","{chr(" & CStr(i) & ")}",1,-1,1)
			newStr=Replace(newStr,chr(i),"{chr(" & CStr(i) & ")}")
		end if
	next
	ReplaceInvalidChars=newStr
end function
'____________________________________________________________________

function Escape2(str)
	Escape2=Replace(Replace(Escape(str),"+","%2B")," ","%20")
end function
'____________________________________________________________________

Function CXmlSyntax(sXml) 	
		sXml = Replace(sXml, "&", "&amp;")    'must be first
        sXml = Replace(sXml, "<", "&lt;")
        sXml = Replace(sXml, ">", "&gt;")
        sXml = Replace(sXml, "'", "&apos;")
        sXml = Replace(sXml, """", "&quot;")
        CXmlSyntax = sXml     		
End Function
'____________________________________________________________________

Function CXmlFromSyntax(sXml) 	
		sXml = Replace(sXml, "&amp;", "&")
        sXml = Replace(sXml, "&lt;", "<")
        sXml = Replace(sXml, "&gt;", ">")
        sXml = Replace(sXml, "&apos;", "'")
        sXml = Replace(sXml, "&quot;", """")
        CXmlFromSyntax = sXml     		
End Function