给你贴个代码吧
{ How to use example ....
Uses UI_less;
procedure TForm1.Button1Click(Sender: TObject);
var
sh: TUILess;
begin
sh := TUILess.Create(nil);
GetAnchorList(sh.get('http://www.microsoft.com'),memo1.lines);
end;
}
unit UI_Less;
interface
uses
MsHtml_tlb, Urlmon, ActiveX, Windows, Messages, Classes;
const
WM_USER_STARTWALKING = WM_USER + 1;
DISPID_AMBIENT_DLCONTROL = (-5512);
READYSTATE_COMPLETE = $00000004;
DLCTL_DLIMAGES = $00000010;
DLCTL_VIDEOS = $00000020;
DLCTL_BGSOUNDS = $00000040;
DLCTL_NO_SCRIPTS = $00000080;
DLCTL_NO_JAVA = $00000100;
DLCTL_NO_RUNACTIVEXCTLS = $00000200;
DLCTL_NO_DLACTIVEXCTLS = $00000400;
DLCTL_DOWNLOADONLY = $00000800;
DLCTL_NO_FRAMEDOWNLOAD = $00001000;
DLCTL_RESYNCHRONIZE = $00002000;
DLCTL_PRAGMA_NO_CACHE = $00004000;
DLCTL_NO_BEHAVIORS = $00008000;
DLCTL_NO_METACHARSET = $00010000;
DLCTL_URL_ENCODING_DISABLE_UTF8 = $00020000;
DLCTL_URL_ENCODING_ENABLE_UTF8 = $00040000;
DLCTL_FORCEOFFLINE = $10000000;
DLCTL_NO_CLIENTPULL = $20000000;
DLCTL_SILENT = $40000000;
DLCTL_OFFLINEIFNOTCONNECTED = $80000000;
DLCTL_OFFLINE = DLCTL_OFFLINEIFNOTCONNECTED;
type
TUILess = class(TComponent, IUnknown,IDispatch, IPropertyNotifySink, IOleClientSite)
protected
/// IDISPATCH
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
/// IPROPERTYNOTIFYSINK
function OnChanged(dispid: TDispID): HResult; stdcall;
function OnRequestEdit(dispid: TDispID): HResult; stdcall;
/// IOLECLIENTSITE
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
function Get(URL: PWidechar): IHTMLELEMENTCollection;
end;
/// Utils
procedure GetAnchorList(IC: IHTMLElementCollection; Anchorlist: TStrings);
procedure GetImageList(IC: IHTMLElementCollection; ImageList: TStrings);
implementation
var
Doc: IhtmlDocument2;
_URL: PwideChar;
/// CORE ---->>>>>>>>>
function TUILess.Get(Url: Pwidechar): IHtmlElementCollection;
var
Cookie: Integer;
CP: IConnectionPoint;
OleObject: IOleObject;
OleControl: IOleControl;
CPC : IConnectionPointContainer;
Msg: TMsg;
hr: HRESULT;
begin
_Url:=Url;
CoCreateInstance(CLASS_HTMLDocument, nil, CLSCTX_INPROC_SERVER, IID_IHTMLDocument2, Doc);
OleObject:=Doc as IOleObject;
OleObject.SetClientSite(self);
OleControl:=Doc as IOleControl;
OleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
CPC:=Doc 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);
result := Doc.Get_all;
end else DispatchMessage(msg);
end;
function TUILess.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
I: Integer;
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;
end else
Result := DISP_E_MEMBERNOTFOUND;
end;
function TUILess.OnChanged(dispid: TDispID): HResult;
var
dp: TDispParams;
vResult: OleVariant;
begin
if (DISPID_READYSTATE = Dispid) then
if SUCCEEDED((Doc 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;
function TUILess.LoadUrlFromMoniker: HResult;
var
Moniker: IMoniker;
BindCtx: IBindCTX;
PM: IPersistMoniker;
begin
createURLMoniker( nil, _Url, Moniker);
CreateBindCtx(0, BindCtx);
PM:=Doc as IPersistMoniker;
Result := PM.Load(LongBool(0), Moniker, BindCtx, STGM_READ)
end;
function TUILess.LoadUrlFromFile: HResult;
var
PF: IPersistfile;
begin
PF:=Doc as IPersistfile;
Result := PF.Load(_URL, 0);
end;
/// UTILILIES ---------- >>>>>>>>>>>>>>>>>>>>>
procedure GetImageList(IC: IHtmlElementCollection; ImageList: TStrings);
var
Image: IHTMLImgElement;
Disp: IDispatch;
x: Integer;
begin
if IC <> nil then begin
for x := 0 to IC.length - 1 do begin
Disp := IC.item(x, 0);
if SUCCEEDED(Disp.QueryInterface(IHTMLImgElement, Image))
then ImageList.add(Image.src);
end;
end;
end;
procedure GetAnchorList(Ic: IHTMLElementCollection; Anchorlist: TStrings);
var
Anchor: IHTMLAnchorElement;
Disp: IDispatch;
x: Integer;
begin
if IC <> nil then begin
for x := 0 to IC.length - 1 do begin
Disp := IC.item(x, 0);
if SUCCEEDED(Disp.QueryInterface(IHTMLAnchorElement, Anchor))
and (anchor.href <> '')
then Anchorlist.add(Anchor.href);
end;
end;
end;
/// Don't Care ------>>>>>>>>>>>
function TUILess.OnRequestEdit(dispid: TDispID): HResult;
begin
RESULT := E_NOTIMPL;
end;
function TUILess.SaveObject: HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
out mk: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.GetContainer(out container: IOleContainer): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.ShowObject: HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.OnShowWindow(fShow: BOOL): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.RequestNewObjectLayout: HResult;
begin
result := E_NOTIMPL;
end;
end.
