html网页采集

UI_Less.pas：

 unit UI_Less;

 interface

 uses

   Windows, Classes, Messages, Forms, MsHtml, Urlmon, ActiveX;

 const

   WM_USER_STARTWALKING = WM_USER + ;

   DISPID_AMBIENT_DLCONTROL = (-);

   READYSTATE_COMPLETE = $;

   DLCTL_DLIMAGES = $;

   DLCTL_VIDEOS = $;

   DLCTL_BGSOUNDS = $;

   DLCTL_NO_SCRIPTS = $;

   DLCTL_NO_JAVA = $;

   DLCTL_NO_RUNACTIVEXCTLS = $;

   DLCTL_NO_DLACTIVEXCTLS = $;

   DLCTL_DOWNLOADONLY = $;

   DLCTL_NO_FRAMEDOWNLOAD = $;

   DLCTL_RESYNCHRONIZE = $;

   DLCTL_PRAGMA_NO_CACHE = $;

   DLCTL_NO_BEHAVIORS = $;

   DLCTL_NO_METACHARSET = $;

   DLCTL_URL_ENCODING_DISABLE_UTF8 = $;

   DLCTL_URL_ENCODING_ENABLE_UTF8 = $;

   DLCTL_FORCEOFFLINE = $;

   DLCTL_NO_CLIENTPULL = $;

   DLCTL_SILENT = $;

   DLCTL_OFFLINEIFNOTCONNECTED = $;

   DLCTL_OFFLINE = DLCTL_OFFLINEIFNOTCONNECTED;

 type

   TUILess = class(TComponent, IUnknown, IDispatch, IPropertyNotifySink,

     IOleClientSite)

   private

     FDocTitle: string;

     FBodyText: TStrings;

     FBodyHtml: TStrings;

   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

     constructor Create(AOwner: TComponent); override;

     destructor Destroy; override;

     property DocTitle: string read FDocTitle;

     property BodyText: TStrings read FBodyText write FBodyText;

     property BodyHtml: TStrings read FBodyHtml write FBodyHtml;

     function Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean)

       : IHTMLELEMENTCollection;

     procedure GetAnchorList(IC: IHTMLELEMENTCollection; Anchorlist: TStrings);

     procedure GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings);

   end;

 implementation

 var

   Doc: IhtmlDocument2;

   _URL: PWidechar;

 constructor TUILess.Create(AOwner: TComponent);

 begin

   inherited Create(AOwner);

   FBodyText := TStringList.Create;

   FBodyHtml := TStringList.Create;

 end;

 destructor TUILess.Destroy;

 begin

   if Assigned(FBodyText) then

     FBodyText.Free;

   if Assigned(FBodyHtml) then

     FBodyHtml.Free;

   inherited Destroy;

 end;

 /// CORE ---->>>>>>>>>

 function TUILess.Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean)

   : IHTMLELEMENTCollection;

 var

   Cookie: Integer;

   CP: IConnectionPoint;

   OleObject: IOleObject;

   OleControl: IOleControl;

   CPC: IConnectionPointContainer;

   All: IHTMLElement;

   Msg: TMsg;

   hr: HResult;

 begin

   _URL := URL;

   IsSucceed := false;

   try

     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, , , )) do

       begin

         if ((Msg.message = WM_USER_STARTWALKING) and (Msg.hwnd = )) then

         begin

           PostQuitMessage();

           result := Doc.Get_all;

           All := Doc.Get_body;

           FDocTitle := string(Doc.nameProp);

           FBodyText.Text := string(All.outerText);

           FBodyHtml.Text := string(All.outerHTML);

           IsSucceed := true;

         end

         else

           DispatchMessage(Msg);

         if IsStop then

           Exit;

       end;

   except

     Exit;

   end;

 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, , );

 end;

 function TUILess.LoadUrlFromMoniker: HResult;

 var

   Moniker: IMoniker;

   BindCtx: IBindCTX;

   PM: IPersistMoniker;

 begin

   createURLMoniker(nil, _URL, Moniker);

   CreateBindCtx(, BindCtx);

   PM := Doc as IPersistMoniker;

   result := PM.Load(LongBool(), Moniker, BindCtx, STGM_READ)

 end;

 function TUILess.LoadUrlFromFile: HResult;

 var

   PF: IPersistfile;

 begin

   PF := Doc as IPersistfile;

   result := PF.Load(_URL, );

 end;

 // 获取图像链接

 procedure TUILess.GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings);

 var

   Image: IHTMLImgElement;

   Disp: IDispatch;

   x: Integer;

 begin

   if IC <> nil then

   begin

     for x :=  to IC.Length -  do

     begin

       application.ProcessMessages;

       Disp := IC.item(x, );

       if SUCCEEDED(Disp.QueryInterface(IHTMLImgElement, Image)) then

         ImageList.add(string(Image.src));

     end;

   end;

 end;

 // 获取链接

 procedure TUILess.GetAnchorList(IC: IHTMLELEMENTCollection;

   Anchorlist: TStrings);

 var

   anchor: IHTMLAnchorElement;

   Disp: IDispatch;

   x: Integer;

 begin

   if IC <> nil then

   begin

     for x :=  to IC.Length -  do

     begin

       application.ProcessMessages;

       Disp := IC.item(x, );

       if (SUCCEEDED(Disp.QueryInterface(IHTMLAnchorElement, anchor)) and

           (anchor.href <> '')) then

         Anchorlist.add(string(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.

Unit3.pas：

 unit Unit3;

 interface

 uses

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

   Dialogs, StdCtrls;

 type

   TForm3 = class(TForm)

     Button1: TButton;

     Edit1: TEdit;

     Memo1: TMemo;

     Button2: TButton;

     Button3: TButton;

     Button4: TButton;

     procedure Button1Click(Sender: TObject);

     procedure Button2Click(Sender: TObject);

     procedure Button3Click(Sender: TObject);

     procedure Button4Click(Sender: TObject);

   private

     { Private declarations }

     procedure into(i: Word);

   public

     { Public declarations }

   end;

 var

   Form3: TForm3;

 implementation

 uses UI_Less;

 {$R *.dfm}

 function DoStrToWideChar(s: string): PWideChar;

 var

  //   s:sting;

   pwc: PWidechar;

   len: integer;

 begin

   //  s:= 'abcdefg ';

   len := length(s) + ;

   pwc := AllocMem(len * sizeof(widechar));

   stringtowidechar(s, pwc, len);

    // showmessage(widechartostring(pwc));

   result := pwc;

    //  FreeMem(pwc);

 end;

 procedure TForm3.into(i: Word);

 var

   sh: TUILess;

   su: boolean; // 是否获取成功

   // isstop: boolean; //设全局变量可以中断连接 ,避免出错

   surl: PWideChar;

 begin

   surl := DoStrToWideChar(Trim(Edit1.Text));

   sh := TUILess.Create(nil);

   try

     Memo1.Clear;

     case i of

       :

         sh.GetAnchorList(sh.get(surl, su, False), Memo1.Lines);

       :

         sh.GetImageList(sh.get(surl, su, False), Memo1.Lines);

       :

         begin

           sh.get(surl, su, False);

           Memo1.Lines := sh.BodyText;

         end;

       :

         begin

           sh.get(surl, su, False);

           Memo1.Lines := sh.BodyHtml;

         end;

     end;

   finally

     //sh.Free;

   end;

 end;

 procedure TForm3.Button1Click(Sender: TObject);

 begin

   into();

 end;

 procedure TForm3.Button2Click(Sender: TObject);

 begin

   into();

 end;

 procedure TForm3.Button3Click(Sender: TObject);

 begin

   into();

 end;

 procedure TForm3.Button4Click(Sender: TObject);

 begin

   into();

 end;

 end.