webshower.pas

DELPHI 访问.net的WEB SERVICE的例子

{***************************************************************
 *
 * Project Name: XJGTest -- WebShower
 * Typist:       XJG([e-mail])
 * Purpose:      手工载入数据到WebBrowser
 *               http://msdn.microsoft.com/library/default.asp?url=/workshop/networking/pluggable/pluggable.asp
 * Comment Time: 2003-5-3 11:54:50
 * History:      Create by xjg. 2003-5-3 11:54:50
 *
 ****************************************************************}

unit WebShower;

interface

uses
  Classes, Windows, SysUtils, ActiveX, UrlMon;

type
  TGetStreamEvent = procedure(const AUrl, AFile: string; const AStream: TMemoryStream;
    var AHandled: Boolean) of object;
  TWebShower = class(TComponent, IInternetProtocol)
  private
    { Private declarations }
    Factory: IClassFactory;
    InternetSession: IInternetSession;
    FNameSpace: string;
    FActive: Boolean;
    FOnGetStream: TGetStreamEvent;
    procedure SetNameSpace(const Value: string);
    procedure SetActive(const Value: Boolean);
  private
    FUrl: string;
    Written, TotalSize: Integer;
    ProtSink: IInternetProtocolSink;
    DataStream: IStream;
    function GetDataStream(var DataStream: IStream): Integer;
  protected
    // IInternetProtocol Methods
    function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
      OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HRESULT; stdcall;
    function Continue(const ProtocolData: TProtocolData): HRESULT; stdcall;
    function Abort(hrReason: HRESULT; dwOptions: DWORD): HRESULT; stdcall;
    function Terminate(dwOptions: DWORD): HRESULT; stdcall;
    function Suspend: HRESULT; stdcall;
    function Resume: HRESULT; stdcall;
    function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HRESULT; stdcall;
    function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
      out libNewPosition: ULARGE_INTEGER): HRESULT; stdcall;
    function LockRequest(dwOptions: DWORD): HRESULT; stdcall;
    function UnlockRequest: HRESULT; stdcall;
  protected
    procedure GetWebContent(const AUrl, AFile: string; const AStream: TMemoryStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Active: Boolean read FActive write SetActive;
    property NameSpace: string read FNameSpace write SetNameSpace;
    property OnGetStream: TGetStreamEvent read FOnGetStream write FOnGetStream;
  end;

  TWebShowerClass = class of TWebShower;

var
  G_WSClass: TWebShowerClass = TWebShower;

implementation

uses
  AxCtrls, ComObj, ComServ;

const
  IID_NSHandler: TGUID = '{A562A5BC-F3C8-4968-8FA8-996B45223990}';

var
  G_WebShower: TWebShower;

type
  TNSHandler = class(TComObject, IInternetProtocol)
  private
    FWebShower: TWebShower;
  protected
    // IInternetProtocol Methods
    function Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
      OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HRESULT; stdcall;
    function Continue(const ProtocolData: TProtocolData): HRESULT; stdcall;
    function Abort(hrReason: HRESULT; dwOptions: DWORD): HRESULT; stdcall;
    function Terminate(dwOptions: DWORD): HRESULT; stdcall;
    function Suspend: HRESULT; stdcall;
    function Resume: HRESULT; stdcall;
    function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HRESULT; stdcall;
    function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
      out libNewPosition: ULARGE_INTEGER): HRESULT; stdcall;
    function LockRequest(dwOptions: DWORD): HRESULT; stdcall;
    function UnlockRequest: HRESULT; stdcall;
  public
    destructor Destroy; override;
    procedure Initialize; override;
  end;

  { TNSHandler }

function TNSHandler.Start(szUrl: PWideChar; OIProtSink: IInternetProtocolSink;
  OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HRESULT; stdcall;
begin
  Result := FWebShower.Start(szUrl, OIProtSink, OIBindInfo, grfPI, dwReserved);
end;

function TNSHandler.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HRESULT;
begin
  Result := FWebShower.Read(pv, cb, cbRead);
end;

function TNSHandler.Terminate(dwOptions: DWORD): HRESULT; stdcall;
begin
  Result := FWebShower.Terminate(dwOptions);
end;

function TNSHandler.LockRequest(dwOptions: DWORD): HRESULT; stdcall;
begin
  Result := FWebShower.LockRequest(dwOptions);
end;

function TNSHandler.UnlockRequest: HRESULT;
begin
  Result := FWebShower.UnlockRequest;
end;

function TNSHandler.Continue(const ProtocolData: TProtocolData): HRESULT;
begin
  Result := FWebShower.Continue(ProtocolData);
end;

function TNSHandler.Abort(hrReason: HRESULT; dwOptions: DWORD): HRESULT; stdcall;
begin
  Result := FWebShower.Abort(hrReason, dwOptions);
end;

function TNSHandler.Suspend: HRESULT; stdcall;
begin
  Result := FWebShower.Suspend;
end;

function TNSHandler.Resume: HRESULT; stdcall;
begin
  Result := FWebShower.Resume;
end;

function TNSHandler.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
  out libNewPosition: ULARGE_INTEGER): HRESULT;
begin
  Result := FWebShower.Seek(dlibMove, dwOrigin, libNewPosition);
end;

destructor TNSHandler.Destroy;
begin
  FWebShower.Free;
  inherited;
end;

procedure TNSHandler.Initialize;
begin
  inherited;
  FWebShower := G_WSClass.Create(nil);
  FWebShower.Assign(G_WebShower);
end;

{ TWebShower }

function TWebShower.Abort(hrReason: HRESULT; dwOptions: DWORD): HRESULT;
begin
  Result := E_NOTIMPL;
end;

procedure TWebShower.Assign(Source: TPersistent);
begin
  if Source is TWebShower then
  begin
    with TWebShower(Source) do
    begin
      Self.NameSpace := NameSpace;
      Self.OnGetStream := OnGetStream;
    end;
  end
  else
    inherited;
end;

function TWebShower.Continue(const ProtocolData: TProtocolData): HRESULT;
begin
  Result := S_OK;
end;

constructor TWebShower.Create(AOwner: TComponent);
begin
  inherited;
  FNameSpace := 'test';
  if G_WebShower = nil then
    G_WebShower := Self;
end;

destructor TWebShower.Destroy;
begin
  if Active then
    Active := False;
  if G_WebShower = Self then
    G_WebShower := nil;
  inherited;
end;

function TWebShower.GetDataStream(var DataStream: IStream): Integer;
var
  F: TMemoryStream;
  Dummy: Int64;
  AFileName, AErrorMsg: string;
  AHandled: Boolean;
begin
  F := TMemoryStream.Create;
  try
    try
      AFileName := Copy(FUrl, Pos(FNameSpace, FUrl) + Length(FNameSpace) + 1, Length(FUrl));
      AHandled := False;
      if Assigned(FOnGetStream) then
        FOnGetStream(FUrl, AFileName, F, AHandled);
      if not AHandled then
        GetWebContent(FUrl, AFileName, F);
    except
      on E: Exception do
      begin
        AErrorMsg := Format('<html><body><font style="font-size:11pt;color:red;bold">%s</font></body></html>',
          [E.Message]);
        F.Size := Length(AErrorMsg);
        Move(Pointer(AErrorMsg)^, F.Memory^, F.Size);
      end;
    end;
    CreateStreamOnHGlobal(0, True, DataStream);
    F.Position := 0;
    TOleStream.Create(DataStream).CopyFrom(F, F.Size);
    DataStream.Seek(0, STREAM_SEEK_SET, Dummy);
    Result := F.Size;
  finally
    F.Free;
  end;
end;

procedure TWebShower.GetWebContent(const AUrl, AFile: string;
  const AStream: TMemoryStream);
begin
  //
end;

function TWebShower.LockRequest(dwOptions: DWORD): HRESULT;
begin
  Result := S_OK;
end;

function TWebShower.Read(pv: Pointer; cb: ULONG;
  out cbRead: ULONG): HRESULT;
begin
  if (totalSize = 0) or (DataStream = nil) then
  begin
    Result := S_FALSE;
    Exit;
  end;
  {Read Data from DataStream to Browser/URLMON }
  DataStream.Read(pv, cb, @cbRead);
  Inc(written, cbRead);
  if (written = totalSize) then
    Result := S_FALSE
  else
    Result := HRESULT(E_PENDING);
end;

function TWebShower.Resume: HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TWebShower.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;
  out libNewPosition: ULARGE_INTEGER): HRESULT;
begin
  Result := E_NOTIMPL;
end;

procedure TWebShower.SetActive(const Value: Boolean);
begin
  if FActive <> Value then
  begin
    if Value then
    begin
      CoGetClassObject(IID_NSHandler, CLSCTX_SERVER, nil, IClassFactory, Factory);
      CoInternetGetSession(0, InternetSession, 0);
      InternetSession.RegisterNameSpace(Factory, IID_NSHandler, 'http', 0, nil, 0);
    end
    else
      InternetSession.UnregisterNameSpace(Factory, 'http');
    FActive := Value;
  end;
end;

procedure TWebShower.SetNameSpace(const Value: string);
begin
  FNameSpace := Value;
end;

function TWebShower.Start(szUrl: PWideChar;
  OIProtSink: IInternetProtocolSink; OIBindInfo: IInternetBindInfo; grfPI,
  dwReserved: DWORD): HRESULT;
begin
  if Pos(Format('http://%s/', [LowerCase(FNameSpace)]), szUrl) <> 1 then
    Result := INET_E_USE_DEFAULT_PROTOCOLHANDLER
  else
  begin
    FUrl := SzUrl;
    written := 0;
    ProtSink := OIProtSink; //Get interface to Transaction handlers IInternetnetProtocolSink
    { Now get the data and load it in DataStream }
    TotalSize := GetDataStream(DataStream);
    {Inform Transaction handler that all data is ready }
    ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or
      BSCF_LASTDATANOTIFICATION or BSCF_DATAFULLYAVAILABLE, TotalSize, TotalSize);
    { -> Here our Read Method is called by transaction handler}
    ProtSink.ReportResult(S_OK, S_OK, nil);
    { Report result to transaction handler. Our Terminate method will be called }
    Result := S_OK;
  end;
end;

function TWebShower.Suspend: HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TWebShower.Terminate(dwOptions: DWORD): HRESULT;
begin
  if Assigned(DataStream) then
    DataStream._Release;
  if Assigned(Protsink) then
    Protsink._Release;
  Result := S_OK;
end;

function TWebShower.UnlockRequest: HRESULT;
begin
  Result := S_OK;
end;

initialization
  TComObjectFactory.Create(ComServer, TNSHandler, IID_NSHandler,
    'NSHandler', 'NSHandler', ciMultiInstance, tmApartment);

end.