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.