K210.ORG

unit DynamicNS_D3;

{

Dynamic Protocol For Delphi 3 or High.

-------------------------------------------- 

Create Time : 2001.12.6

Update Time : 2002.7.9

Version : Release 3

Author : JoJo

-------------------------------------------- 

Copyright 1996-2001 Think Space Soft

-------------------------------------------- 

Note : If use in Delphi 3, you must update urlmon unit.

}

 

interface

uses

  Classes, Windows, Forms, Axctrls, dialogs, SysUtils, ComObj, ActiveX,

UrlMon;

 

const

  Class_DynamicNS: TGUID = '{C379EAD1-CB34-4B09-AF6B-7E587F8BCD80}';

 

type

  TDynamicNS = class(TComObject, IInternetProtocol)

  private

    Url: string;

    HaveData : Boolean;

    Written, TotalSize: Integer;

    ProtSink: IInternetProtocolSink;

    DataStream: IStream;

  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;

    //Load Data Function

    function LoadData(URL:String):Boolean;

  end;

 

 

  TAcceptEvent = procedure (const URL:String;var Accept:Boolean) of object;

  TContentEvent = procedure (const URL:String;var Stream:TStream) of object;

 

  TDynamicProtocol = class(TObject)

  private

    Factory: IClassFactory;

    InternetSession: IInternetSession;

    FOnAccept : TAcceptEvent;

    FOnGetContent : TContentEvent;

 

    FProtocolName : String;

    FEnabled : Boolean;

    function GetProtocolName : String;

    procedure SetProtocolName(const Value:String);

    function GetEnabled : Boolean;

    procedure SetEnabled(const Value:Boolean);

    procedure StartProtocol;

    procedure StopProtocol;

  protected

    function Accept(const URL:String):Boolean;

    function LoadContent(const URL:String):TStream;

  public

    constructor Create;

    destructor Destroy; override;

    property ProtocolName : String read GetProtocolName

      write SetProtocolName;

    property Enabled : Boolean read GetEnabled

      write SetEnabled;

 

    property OnAccept : TAcceptEvent read FOnAccept

      write FOnAccept;

    property OnGetContent : TContentEvent read FOnGetContent

      write FOnGetContent;

  end;

 

var

  DynamicProtocol : TDynamicProtocol;

 

implementation

 

uses

  comserv;

 

 

function TDynamicNS.Start(szUrl: PWideChar; OIProtSink:

IInternetProtocolSink;

  OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult;

stdcall;

begin

  Url := SzUrl;

  written := 0;

  HaveData := False;

// ShowMessage(URL);

  //Load data here

  if not LoadData(URL) then Result := S_FALSE else begin

  HaveData := True;

  ProtSink := OIProtSink;

  ProtSink.ReportData(BSCF_FIRSTDATANOTIFICATION or

        BSCF_LASTDATANOTIFICATION or BSCF_DATAFULLYAVAILABLE, TotalSize,

TotalSize);

  ProtSink.ReportResult(S_OK, S_OK, nil);

  Result := S_OK; end;

end;

 

 

function TDynamicNS.Read(pv: Pointer; cb: ULONG; out cbRead: ULONG):

HResult;

begin

  DataStream.Read(pv, cb, @cbRead);

  Inc(written, cbread);

  if (written = totalSize) then result := S_FALSE else Result := E_PENDING;

end;

 

 

function TDynamicNS.Terminate(dwOptions: DWORD): HResult; stdcall;

begin

  if HaveData then

    begin

      DataStream._Release;

      Protsink._Release;

    end;

  result := S_OK;

end;

 

function TDynamicNS.LockRequest(dwOptions: DWORD): HResult; stdcall;

begin

  result := S_OK;

end;

 

function TDynamicNS.UnlockRequest: HResult;

begin

  result := S_OK;

end;

 

function TDynamicNS.Continue(const ProtocolData: TProtocolData): HResult;

begin

  result := S_OK;

end;

 

function TDynamicNS.Abort(hrReason: HResult; dwOptions: DWORD): HResult;

stdcall;

begin

  result := E_NOTIMPL;

end;

 

function TDynamicNS.Suspend: HResult; stdcall;

begin

  result := E_NOTIMPL;

end;

 

function TDynamicNS.Resume: HResult; stdcall;

begin

  result := E_NOTIMPL;

end;

 

function TDynamicNS.Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD;

  out libNewPosition: ULARGE_INTEGER): HResult;

begin

  result := E_NOTIMPL;

end;

 

function TDynamicNS.LoadData(URL:String): Boolean;

var

  F:TStream;

  Dummy: LONGLONG;

begin

  Result := False;

  if Assigned(DynamicProtocol) then

    begin

      Result := DynamicProtocol.Accept(URL);

      if Result then

        begin

          F := DynamicProtocol.LoadContent(URL);

          CreateStreamOnHGlobal(0, True, DataStream);

          TOleStream.Create(DataStream).CopyFrom(F, F.Size);

          DataStream.Seek(0, STREAM_SEEK_SET, Dummy);

          TotalSize := F.Size;

          F.Free;

        end;

    end;

end;

 

{ TDynamicProtocol }

 

function TDynamicProtocol.Accept(const URL: String): Boolean;

begin

  Result := False;

  if Assigned(FOnAccept) then

    FOnAccept(URL,Result);

end;

 

constructor TDynamicProtocol.Create;

begin

  inherited;

  FEnabled := False;

  FProtocolName := 'local';

end;

 

destructor TDynamicProtocol.Destroy;

begin

  if FEnabled then

    StopProtocol;

  inherited;

end;

 

function TDynamicProtocol.GetEnabled: Boolean;

begin

  Result := FEnabled;

end;

 

function TDynamicProtocol.GetProtocolName: String;

begin

  Result := FProtocolName;

end;

 

function TDynamicProtocol.LoadContent(const URL: String):TStream;

begin

  //І»їЙТФ·µ»ШїХµДБч

  if Assigned(FOnGetContent) then

    begin

      Result := TStringStream.Create('');

      FOnGetContent(URL,Result);

      Result.Position :=0;

      if Result.Size = 0 then

        (Result as TStringStream).WriteString(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));

    end

  else

    Result := TStringStream.Create(Format('<html><body><h3>Load %s Error.</h3></body></html>',[URL]));

end;

 

procedure TDynamicProtocol.SetEnabled(const Value: Boolean);

begin

  if FEnabled <> Value then

    begin

      FEnabled := Value;

      if FEnabled then

        StartProtocol

      else

        StopProtocol;

    end;

end;

 

procedure TDynamicProtocol.SetProtocolName(const Value: String);

begin

  if FEnabled then exit;

  if FProtocolName <> Value then

    FProtocolName := Value;

end;

 

procedure TDynamicProtocol.StartProtocol;

begin

  CoGetClassObject(Class_DynamicNS, CLSCTX_SERVER, nil, IClassFactory,

Factory);

  CoInternetGetSession(0, InternetSession, 0);

  InternetSession.RegisterNameSpace(Factory, Class_DynamicNS,

PWideChar(WideString(FProtocolName)), 0, nil, 0);

end;

 

procedure TDynamicProtocol.StopProtocol;

begin

  InternetSession.UnregisterNameSpace(Factory,

PWideChar(WideString(FProtocolName)));

end;

 

initialization

  TComObjectFactory.Create(ComServer, TDynamicNS, Class_DynamicNS,

      'DynamicNS', 'DynamicNS', ciMultiInstance);//, tmApartment);

  DynamicProtocol := TDynamicProtocol.Create;

finalization

  DynamicProtocol.Free;

end.

 

 

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, DynamicNS_D3, OleCtrls, SHDocVw;

 

type

  TForm1 = class(TForm)

    wb: TWebBrowser;

    procedure FormCreate(Sender: TObject);

  private

    { Private declarations }

    procedure OnContent(const url:String; var Stream:TStream);

    procedure Accept(const URL:String;var Accept:Boolean);

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

{ TForm1 }

 

procedure TForm1.OnContent(const url: String; var Stream: TStream);

begin

  with Stream as TStringStream do

    WriteString(url);

end;

 

procedure TForm1.Accept(const URL: String; var Accept: Boolean);

begin

  Accept := True;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  DynamicProtocol.ProtocolName := 'myhttp';

  DynamicProtocol.Enabled := True;

  DynamicProtocol.OnGetContent := OnContent;

  DynamicProtocol.OnAccept := Accept;

  wb.Navigate('myhttp://hello');

end;

 

end.