{******************************************************************}
{ HtmlPrsr.pas                                                     }
{                                                                  }
{ Author    : A.Nasir Senturk                                      }
{ Home Page : http://www.shenturk.com                              }
{ Email     : shenturk@gmail.com                                   }
{                                                                  }
{ Date      : 03.01.2007                                           }
{                                                                  }
{ Based on UI_Less.pas (Per Lindsų Larsen)                         }
{ http://www.euromind.com/ieDelphi                                 }
{ lindsoe@po.ia.dk                                                 }
{                                                                  }
{ Sizden iki žey rica edicem:                                      }
{ 1. Lutfen bu baslik kismini kaldirmayiniz.                       }
{ 2. Mumkunse bagis yapiniz.                                       }
{ *****************************************************************}

unit HtmlPrsr;

interface

uses MsHtml7{MsHtml_EWB}, Urlmon, ActiveX, Windows, Messages, Classes, SysUtils, Variants;

const
  WM_USER_STARTWALKING      = WM_USER + 1;
  DISPID_AMBIENT_DLCONTROL  = (-5512);
  READYSTATE_COMPLETE       = $00000004;

type
  TInvokeEvent = function(DispID: Integer; const IID: TGUID; LocaleID: Integer;
    Flags: Word; var Params: TagDispParams; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT of object;

  THtmlParser = class(TComponent, IUnknown, IDispatch, IPropertyNotifySink, IOleClientSite)
  private
    FOnInvoke: TInvokeEvent;
    FEnabled: Boolean;
  protected
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    function OnChanged(dispid: TDispID): HResult; stdcall;
    function OnRequestEdit(dispid: TDispID): HResult; stdcall;
    function SaveObject: HResult; stdcall;
    function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
       out mk: IMoniker): HResult; stdcall;
    function GetContainer(out container: IOleContainer): HResult; stdcall;
    function ShowObject: HResult; stdcall;
    function OnShowWindow(fShow: BOOL): HResult; stdcall;
    function RequestNewObjectLayout: HResult; stdcall;
    function LoadUrlFromMoniker: HResult;
    function LoadUrlFromFile: HResult;
  // * We only use LoadUrlFromMoniker, but we could use LoadUrlFromFile instead.
  public
    HtmlElementCollection: IHtmlElementCollection;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Go(URL: WideString): IHTMLELEMENTCollection;
    function LoadFromFile(URL: WideString): IHTMLELEMENTCollection;
  published
    property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
    property Enabled: Boolean read FEnabled write FEnabled default True;
  end;

implementation

var
  HTMLDocument: IHTMLDocument2;
  _URL: WideString;

constructor THtmlParser.Create(AOwner: TComponent);
begin
  FEnabled := True;
  inherited Create(AOwner);
end;

destructor THtmlParser.Destroy;
begin
  inherited Destroy;
end;

function THtmlParser.Go(URL: WideString): IHtmlElementCollection;
var
  Cookie: Integer;
  CP: IConnectionPoint;
  OleObject: IOleObject;
  OleControl: IOleControl;
  CPC: IConnectionPointContainer;
  Msg: TMsg;
  hr: HRESULT;
begin
  if FEnabled then
  begin
    _URL := Url;
    CoCreateInstance(CLASS_HTMLDocument, nil, CLSCTX_INPROC_SERVER,
      IID_IHTMLDocument2, HTMLDocument);
    OleObject := HTMLDocument as IOleObject;
    OleObject.SetClientSite(self);
    OleControl := HTMLDocument as IOleControl;
    OleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
    CPC := HTMLDocument as IConnectionPointContainer;
    CPC.FindConnectionPoint(IpropertyNotifySink, CP);
    CP.Advise(self, Cookie);
    HR := LoadUrlFromMoniker; // alternative: Hr:= LoadUrlFromFile;

    if ((SUCCEEDED(HR)) or (HR = E_PENDING)) then
      while (GetMessage(msg, 0, 0, 0)) do
        if ((msg.message = WM_USER_STARTWALKING) and (msg.hwnd = 0)) then
        begin
          PostQuitMessage(0);
          HtmlElementCollection := HTMLDocument.Get_all();
          Result := HtmlElementCollection;
        end
        else DispatchMessage(msg);
  end;
end;

function THtmlParser.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
const
  DLCTL_NO_SCRIPTS        = $00000080;
  DLCTL_NO_JAVA           = $00000100;
  DLCTL_NO_RUNACTIVEXCTLS = $00000200;
  DLCTL_NO_DLACTIVEXCTLS  = $00000400;
  DLCTL_DOWNLOADONLY      = $00000800;

var
  I: Integer;
begin
  Result := E_FAIL;
  if FEnabled then
  begin
    if DISPID_AMBIENT_DLCONTROL = DispID then
    begin
      I := DLCTL_DOWNLOADONLY + DLCTL_NO_SCRIPTS +
           DLCTL_NO_JAVA + DLCTL_NO_DLACTIVEXCTLS +
           DLCTL_NO_RUNACTIVEXCTLS;
      PVariant(VarResult)^ := I;
      Result := S_OK;
      if Assigned(FOnInvoke) then
        FOnInvoke(DispID, IID, LocaleID, Flags, TagDispParams(Params),
          VarResult, ExcepInfo, ArgErr)
    end
    else Result := DISP_E_MEMBERNOTFOUND;
  end;
end;

function THtmlParser.OnChanged(dispid: TDispID): HResult;
var
  dp: TDispParams;
  vResult: OleVariant;
begin
  Result := E_FAIL;
  if FEnabled then
  begin
    if (DISPID_READYSTATE = Dispid) then
    begin
      if SUCCEEDED((HTMLDocument as IHTMLdocument2).Invoke(DISPID_READYSTATE, GUID_NULL,
        LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, dp, @vResult, nil, nil)) then
        if Integer(vResult) = READYSTATE_COMPLETE then
          PostThreadMessage(GetCurrentThreadId(), WM_USER_STARTWALKING, 0, 0);
    end;
  end;
end;

function THtmlParser.LoadUrlFromMoniker: HResult;
var
  Moniker: IMoniker;
  BindCtx: IBindCTX;
  PM: IPersistMoniker;
begin
  Result := E_FAIL;
  if FEnabled then
  begin
    CreateURLMoniker(nil, PWideChar(_URL), Moniker);
    CreateBindCtx(0, BindCtx);
    PM := HTMLDocument as IPersistMoniker;
    Result := PM.Load(LongBool(0), Moniker, BindCtx, STGM_READ);
  end;
end;

function THtmlParser.LoadUrlFromFile: HResult;
var
  PF: IPersistFile;
begin
  Result := E_FAIL;
  if FEnabled then
  begin
    PF := HTMLDocument as IPersistFile;
    Result := PF.Load(PWideChar(_URL), 0);
  end;
end;

function THtmlParser.OnRequestEdit(dispid: TDispID): HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.SaveObject: HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  out mk: IMoniker): HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.GetContainer(out container: IOleContainer): HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.ShowObject: HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.OnShowWindow(fShow: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.RequestNewObjectLayout: HResult;
begin
  Result := E_NOTIMPL;
end;

function THtmlParser.LoadFromFile(URL: WideString): IHTMLELEMENTCollection;
var
  Cookie: Integer;
  CP: IConnectionPoint;
  OleObject: IOleObject;
  OleControl: IOleControl;
  CPC: IConnectionPointContainer;
  Msg: TMsg;
  HR: HRESULT;
begin
  if FEnabled then
  begin
    _URL := Url;
    CoCreateInstance(CLASS_HTMLDocument, nil, CLSCTX_INPROC_SERVER,
      IID_IHTMLDocument2, HTMLDocument);
    OleObject := HTMLDocument as IOleObject;
    OleObject.SetClientSite(Self);
    OleControl := HTMLDocument as IOleControl;
    OleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
    CPC := HTMLDocument as IConnectionPointContainer;
    CPC.FindConnectionPoint(IpropertyNotifySink, CP);
    CP.Advise(self, Cookie);
    HR:= LoadUrlFromFile;

    if ((SUCCEEDED(HR)) or (HR = E_PENDING)) then
      while (GetMessage(msg, 0, 0, 0)) do
        if ((msg.message = WM_USER_STARTWALKING) and (msg.hwnd = 0)) then
        begin
          PostQuitMessage(0);
          HtmlElementCollection := HTMLDocument.Get_all();
          Result := HtmlElementCollection;
        end
        else DispatchMessage(msg);
  end;
end;

end.