XmlHttpRequest.bas

#ifndef unicode
#define unicode
#endif

#include once "windows.bi"
#include once "win\objbase.bi"

Const ProgID_XmlHttpRequest = "Microsoft.XmlHttp"
Const UserName = "UserName"
Const Password = "Password"
Const EmptyWString = ""

' Const HttpMethod = "GET"
Const HttpMethod = "PUT"

Const HttpUrl = "http://localhost:8080/bbb.txt"

Const HeaderContentType = "Content-Type"
Const HeaderContentTypeValue = "text/plain"

Const SendPutFileData2 = "Это данные для отправки на сервер"
Dim SendPutFileData As WString * 512 = Any
Scope
	' UTF-16 LE BOM
	Dim pBytes As UByte Ptr = CPtr(UByte Ptr, @SendPutFileData)
	pBytes[0] = 255
	pBytes[1] = 254
End Scope
lstrcpy(@SendPutFileData[1], @SendPutFileData2)

Dim varFalse As VARIANT = Any
With varFalse
	.vt = VT_BOOL
	.boolVal = VARIANT_FALSE
End With

Dim varEmptyBSTR As VARIANT = Any
With varEmptyBSTR
	.vt = VT_BSTR
	.bstrVal = SysAllocString(@EmptyWString)
End With

Dim varUserNameBSTR As VARIANT = Any
With varUserNameBSTR
	.vt = VT_BSTR
	.bstrVal = SysAllocString(@UserName)
End With

Dim varPasswordBSTR As VARIANT = Any
With varPasswordBSTR
	.vt = VT_BSTR
	.bstrVal = SysAllocString(@Password)
End With

Dim varSendPutFileDataBSTR As VARIANT = Any
With varSendPutFileDataBSTR
	.vt = VT_BSTR
	.bstrVal = SysAllocString(@SendPutFileData)
End With

Dim bstrMethod As BSTR = SysAllocString(@HttpMethod)
Dim bstrUrl As BSTR = SysAllocString(@HttpUrl)
Dim bstrHeaderContentType As BSTR = SysAllocString(@HeaderContentType)
Dim bstrHeaderContentTypeValue As BSTR = SysAllocString(@HeaderContentTypeValue)


If CoInitialize(0) <> S_OK Then
	Print "Не могу инициализировать COM."
	End(0)
End If

Dim idclsidXmlHttpRequest As CLSID
Dim hr As HRESULT = CLSIDFromProgID(@ProgID_XmlHttpRequest, @idclsidXmlHttpRequest)

If FAILED(hr) Then
	Print "Не могу разрешить CLSID по ProgID", Hex(hr)
	End(1)
End If


Dim pClassFactory As IClassFactory Ptr = NULL
hr = CoGetClassObject(@idclsidXmlHttpRequest, CLSCTX_INPROC, NULL, @IID_IClassFactory, @pClassFactory)

If FAILED(hr) Then
	Print "Ошибка в CoGetClassObject", Hex(hr)
	End(1)
End If

Dim pRequest As IXMLHttpRequest Ptr = NULL
hr = pClassFactory->lpVtbl->CreateInstance(pClassFactory, NULL, @IID_IXmlHttpRequest, @pRequest)
If FAILED(hr) Then
	Print "Не могу создать XmlHttpRequest", Hex(hr)
Else
	
	Scope
		hr = pRequest->lpVtbl->Open(pRequest, bstrMethod, bstrUrl, varFalse, varUserNameBSTR, varPasswordBSTR)
		If FAILED(hr) Then
			Print "Не могу запустить метод Open из XmlHttpRequest", Hex(hr)
		End If
		
		hr = pRequest->lpVtbl->setRequestHeader(pRequest, bstrHeaderContentType, bstrHeaderContentTypeValue)
		If FAILED(hr) Then
			Print "Не могу запустить метод setRequestHeader из XmlHttpRequest", Hex(hr)
		End If
		
		' Отправка тела запроса
		hr = pRequest->lpVtbl->Send(pRequest, varSendPutFileDataBSTR)
		' Отправка запроса без тела
		' hr = pRequest->lpVtbl->Send(pRequest, varEmptyBSTR)
		If FAILED(hr) Then
			Print "Не могу запустить метод Send из XmlHttpRequest", Hex(hr)
		End If
	End Scope
	
	Scope
		Dim StatusCode As Long
		hr = pRequest->lpVtbl->get_status(pRequest, @StatusCode)
		If FAILED(hr) Then
			Print "Не могу получить get_status из XmlHttpRequest", Hex(hr)
		Else
			Print "Код состояния", StatusCode
		End If
	End Scope
	
	Scope
		Dim bstrHeaders As BSTR
		hr = pRequest->lpVtbl->getAllResponseHeaders(pRequest, @bstrHeaders)
		If FAILED(hr) Then
			Print "Не могу получить getAllResponseHeaders из XmlHttpRequest", Hex(hr)
		Else
			If bstrHeaders <> 0 Then
				Dim HeadersValue As WString Ptr = @bstrHeaders[0]
				Print "Заголовки ответа"
				Print *HeadersValue
				SysFreeString(bstrHeaders)
			End If
		End If
	End Scope
	
	Scope
		Dim bstrResponseText As BSTR
		hr = pRequest->lpVtbl->get_responseText(pRequest, @bstrResponseText)
		If FAILED(hr) Then
			Print "Не могу получить get_responseText из XmlHttpRequest", Hex(hr)
		Else
			If bstrResponseText <> 0 Then
				Dim ResponseText As WString Ptr = @bstrResponseText[0]
				Print "Текст ответа"
				Print *ResponseText
				SysFreeString(bstrResponseText)
			End If
		End If
	End Scope
	
	pRequest->lpVtbl->Release(pRequest)
End If

pClassFactory->lpVtbl->Release(pClassFactory)

CoUninitialize()

SysFreeString(bstrHeaderContentTypeValue)
SysFreeString(bstrHeaderContentType)

VariantClear(@varSendPutFileDataBSTR)
VariantClear(@varPasswordBSTR)
VariantClear(@varUserNameBSTR)
VariantClear(@varEmptyBSTR)
VariantClear(@varFalse)

SysFreeString(bstrUrl)
SysFreeString(bstrMethod)