Mega Code Archive
HTMLXML async request via POSTGET
<![CDATA[
Title: HTML/XML async request via POST/GET
Question: Component that use HttpXMLRequest to communicate with web server.
Answer:
complete source with example::
http://www.piramida-sistem.com/dax/TXMLTest.zip
unit XMLRequestAsync;
interface
uses
SysUtils, Classes,variants,msxml;
type RequestStringArray=array of string;
type eRequestType=(POST,GET,HEAD);
IOnReadyStateChange=interface;
TXMLRequestAsync = class;
TEventObject=class(TInterfacedObject,IDispatch)
private
sObj:XMLHttpRequest;
sEventCallback:IOnReadyStateChange;
value:integer;
RT:eRequestType;
public
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
end;
IOnReadyStateChange = interface
procedure OnReadyStateChange (const XMLHttp_obj:XMLHttpRequest;const EventObject:TEventObject);
end;
TRequestNotifyEvent = procedure(Sender:TObject;requestValue:integer;requestType:eRequestType;respondStatus:integer) of object;
TXMLRequestAsync = class(TComponent,IOnReadyStateChange)
private
{ Private declarations }
XMLHTTP:XMLHttpRequest;
HR:TRequestNotifyEvent;
nParamNames,nParamValues:RequestStringArray;
function IsBusy():longbool;
function GetDoc():IXMLDOMDocument;
function GetReq():XMLHttpRequest;
protected
{ Protected declarations }
procedure OnReadyStateChange (const XMLHttp_obj:XMLHttpRequest;const EventObject:TEventObject);
procedure InitRequest(rType:eRequestType;const URL,USR,PWD:string);
function ChangeURLChars(const nS:string):string;
function GetParameters():string;
procedure SendRequest(const rData:string);
public
{ Public declarations }
function SendHTTPRequest(rType:eRequestType;RequestValue:integer;const Url:string;const Username:string='';const Password:string=''):longbool;
property Busy:longbool read IsBusy;
property Document:IXMLDOMDocument read GetDoc;
property Request:XMLHttpRequest read GetReq;
property ParamNames:RequestStringArray read nParamNames write nParamNames;
property ParamValues:RequestStringArray read nParamValues write nParamValues;
published
{ Published declarations }
property OnHTTPRespond :TRequestNotifyEvent read HR write HR;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Dodatne kontrole', [TXMLRequestAsync]);
end;
{ TEventObject }
function TEventObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
end;
function TEventObject.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
end;
function TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
end;
function TEventObject.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
sEventCallback.OnReadyStateChange(sObj,self);
result:=-1;
end;
{ TXMLRequestAsync }
function TXMLRequestAsync.ChangeURLChars(const nS: string): string;
begin
result:=stringreplace(nS,'+','%2B',[rfReplaceAll]);
result:=stringreplace(result,'&','%26',[rfReplaceAll]);
result:=stringreplace(result,' ','%20',[rfReplaceAll]);
result:=stringreplace(result,'=','%3D',[rfReplaceAll]);
end;
function TXMLRequestAsync.GetDoc: IXMLDOMDocument;
begin
result:=nil;
if (XMLHTTPnil) and (XMLHTTP.readyState=4) then result:=IXMLDOMDocument(XMLHTTP.responseXML);
end;
function TXMLRequestAsync.GetReq: XMLHttpRequest;
begin
result:=nil;
if (XMLHTTPnil) then result:=XMLHTTP;
end;
procedure TXMLRequestAsync.InitRequest(rType:eRequestType;const URL,USR,PWD:string);
var
nT:string;
cURL:string;
cP:string;
begin
if rType=POST then nT:='POST'
else if rType=GET then nT:='GET'
else if rType=HEAD then nT:='HEAD';
if rType=GET then
begin
cURL:=URL;
cP:=GetParameters();
if length(cP)0 then cURL:=cURL+'?'+cP;
XMLHttp.open(nT,cURL,true,USR,PWD);
end
else
XMLHttp.open(nT,URL,true,USR,PWD);
XMLHttp.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded');
end;
function TXMLRequestAsync.IsBusy: longbool;
begin
if (XMLHTTP=nil) or (XMLHTTP.readyState in [0,4]) then
result:=false
else
result:=true;
end;
procedure TXMLRequestAsync.OnReadyStateChange(
const XMLHttp_obj: XMLHttpRequest; const EventObject: TEventObject);
begin
if XMLHttp_obj.readyState=4 then
begin
if assigned(HR) then HR(TObject(Self),EventObject.Value,EventObject.RT,XMLHttp_obj.status);
XMLHttp_obj.onreadystatechange:=pointer(0); /////-----makni event! ina?e se pojavljuje memory leaking !
end;
end;
function TXMLRequestAsync.SendHTTPRequest(rType:eRequestType;RequestValue:integer;const Url:string;const Username:string='';const Password:string=''):longbool;
var
EventObject:TEventObject;
begin
result:=false;
if (length(nParamNames)length(nParamValues)) or (length(URL)=0) then exit;
try
XMLHttp:=XMLHttpRequest(CoXMLHTTPRequest.Create());
EventObject:=TEventObject.Create;
EventObject.sObj:=XMLHttp;
EventObject.sEventCallback:=self;
EventObject.RT:=rType;
EventObject.Value:=RequestValue;
XMLHttp.onreadystatechange:= IDispatch(EventObject);
InitRequest(rType,Url,Username,Password);
if rType=GET then
SendRequest('')
else
SendRequest(GetParameters());
result:=true;
except
EventObject.FreeInstance;
EventObject:=nil;
end;
end;
function TXMLRequestAsync.GetParameters():string;
var
x:integer;
begin
setlength(result,0);
for x:=0 to high(nParamNames) do begin
result:=result+nParamNames[x]+'='+ChangeURLChars(nParamValues[x]);
if x=high(nParamNames) then break;
result:=result+'&';
end;
end;
procedure TXMLRequestAsync.SendRequest(const rData:string);
begin
XMLHTTP.send(rData);
end;
end.
]]>