UI_Less.pas：
1 unit UI_Less; 2 3 interface 4 5 uses 6 Windows, Classes, Messages, Forms, MsHtml, Urlmon, ActiveX; 7 8 const 9 WM_USER_STARTWALKING = WM_USER + 1; 10 DISPID_AMBIENT_DLCONTROL = (-5512); 11 READYSTATE_COMPLETE = $00000004; 12 13 DLCTL_DLIMAGES = $00000010; 14 DLCTL_VIDEOS = $00000020; 15 DLCTL_BGSOUNDS = $00000040; 16 DLCTL_NO_SCRIPTS = $00000080; 17 DLCTL_NO_JAVA = $00000100; 18 DLCTL_NO_RUNACTIVEXCTLS = $00000200; 19 DLCTL_NO_DLACTIVEXCTLS = $00000400; 20 DLCTL_DOWNLOADONLY = $00000800; 21 DLCTL_NO_FRAMEDOWNLOAD = $00001000; 22 DLCTL_RESYNCHRONIZE = $00002000; 23 DLCTL_PRAGMA_NO_CACHE = $00004000; 24 DLCTL_NO_BEHAVIORS = $00008000; 25 DLCTL_NO_METACHARSET = $00010000; 26 DLCTL_URL_ENCODING_DISABLE_UTF8 = $00020000; 27 DLCTL_URL_ENCODING_ENABLE_UTF8 = $00040000; 28 DLCTL_FORCEOFFLINE = $10000000; 29 DLCTL_NO_CLIENTPULL = $20000000; 30 DLCTL_SILENT = $40000000; 31 DLCTL_OFFLINEIFNOTCONNECTED = $80000000; 32 DLCTL_OFFLINE = DLCTL_OFFLINEIFNOTCONNECTED; 33 34 type 35 TUILess = class(TComponent, IUnknown, IDispatch, IPropertyNotifySink, 36 IOleClientSite) 37 private 38 FDocTitle: string; 39 FBodyText: TStrings; 40 FBodyHtml: TStrings; 41 protected 42 /// IDISPATCH 43 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; 44 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; 45 stdcall; 46 /// IPROPERTYNOTIFYSINK 47 function OnChanged(DispID: TDispID): HResult; stdcall; 48 function OnRequestEdit(DispID: TDispID): HResult; stdcall; 49 /// IOLECLIENTSITE 50 function SaveObject: HResult; stdcall; 51 function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; 52 out mk: IMoniker): HResult; stdcall; 53 function GetContainer(out container: IOleContainer): HResult; stdcall; 54 function ShowObject: HResult; stdcall; 55 function OnShowWindow(fShow: BOOL): HResult; stdcall; 56 function RequestNewObjectLayout: HResult; stdcall; 57 /// 58 function LoadUrlFromMoniker: HResult; 59 function LoadUrlFromFile: HResult; 60 // * We only use LoadUrlFromMoniker, but we could use LoadUrlFromFile instead. 61 62 public 63 constructor Create(AOwner: TComponent); override; 64 destructor Destroy; override; 65 property DocTitle: string read FDocTitle; 66 property BodyText: TStrings read FBodyText write FBodyText; 67 property BodyHtml: TStrings read FBodyHtml write FBodyHtml; 68 function Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean) 69 : IHTMLELEMENTCollection; 70 procedure GetAnchorList(IC: IHTMLELEMENTCollection; Anchorlist: TStrings); 71 procedure GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings); 72 end; 73 74 implementation 75 76 var 77 Doc: IhtmlDocument2; 78 _URL: PWidechar; 79 80 constructor TUILess.Create(AOwner: TComponent); 81 begin 82 inherited Create(AOwner); 83 FBodyText := TStringList.Create; 84 FBodyHtml := TStringList.Create; 85 end; 86 87 destructor TUILess.Destroy; 88 begin 89 if Assigned(FBodyText) then 90 FBodyText.Free; 91 if Assigned(FBodyHtml) then 92 FBodyHtml.Free; 93 inherited Destroy; 94 end; 95 96 /// CORE ---->>>>>>>>> 97 function TUILess.Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean) 98 : IHTMLELEMENTCollection; 99 var 100 Cookie: Integer; 101 CP: IConnectionPoint; 102 OleObject: IOleObject; 103 OleControl: IOleControl; 104 CPC: IConnectionPointContainer; 105 All: IHTMLElement; 106 Msg: TMsg; 107 hr: HResult; 108 begin 109 _URL := URL; 110 IsSucceed := false; 111 try 112 CoCreateInstance(CLASS_HTMLDocument, nil, CLSCTX_INPROC_SERVER, 113 IID_IHTMLDocument2, Doc); 114 OleObject := Doc as IOleObject; 115 OleObject.SetClientSite(self); 116 OleControl := Doc as IOleControl; 117 OleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL); 118 CPC := Doc as IConnectionPointContainer; 119 CPC.FindConnectionPoint(IPropertyNotifySink, CP); 120 CP.Advise(self, Cookie); 121 hr := LoadUrlFromMoniker; // alternative: Hr:= LoadUrlFromFile; 122 if ((SUCCEEDED(hr)) or (hr = E_PENDING)) then 123 while (GetMessage(Msg, 0, 0, 0)) do 124 begin 125 if ((Msg.message = WM_USER_STARTWALKING) and (Msg.hwnd = 0)) then 126 begin 127 PostQuitMessage(0); 128 result := Doc.Get_all; 129 All := Doc.Get_body; 130 FDocTitle := string(Doc.nameProp); 131 FBodyText.Text := string(All.outerText); 132 FBodyHtml.Text := string(All.outerHTML); 133 IsSucceed := true; 134 end 135 else 136 DispatchMessage(Msg); 137 if IsStop then 138 Exit; 139 end; 140 except 141 Exit; 142 end; 143 end; 144 145 function TUILess.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; 146 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; 147 var 148 I: Integer; 149 begin 150 if DISPID_AMBIENT_DLCONTROL = DispID then 151 begin 152 I := DLCTL_DOWNLOADONLY + DLCTL_NO_SCRIPTS + DLCTL_NO_JAVA + 153 DLCTL_NO_DLACTIVEXCTLS + DLCTL_NO_RUNACTIVEXCTLS; 154 PVariant(VarResult)^ := I; 155 result := S_OK; 156 end 157 else 158 result := DISP_E_MEMBERNOTFOUND; 159 end; 160 161 function TUILess.OnChanged(DispID: TDispID): HResult; 162 var 163 dp: TDispParams; 164 vResult: OleVariant; 165 begin 166 if (DISPID_READYSTATE = DispID) then 167 if SUCCEEDED((Doc as IhtmlDocument2).Invoke(DISPID_READYSTATE, GUID_null, 168 LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, dp, @vResult, nil, nil)) 169 then 170 if Integer(vResult) = READYSTATE_COMPLETE then 171 PostThreadMessage(GetCurrentThreadId(), WM_USER_STARTWALKING, 0, 0); 172 end; 173 174 function TUILess.LoadUrlFromMoniker: HResult; 175 var 176 Moniker: IMoniker; 177 BindCtx: IBindCTX; 178 PM: IPersistMoniker; 179 begin 180 createURLMoniker(nil, _URL, Moniker); 181 CreateBindCtx(0, BindCtx); 182 PM := Doc as IPersistMoniker; 183 result := PM.Load(LongBool(0), Moniker, BindCtx, STGM_READ) 184 end; 185 186 function TUILess.LoadUrlFromFile: HResult; 187 var 188 PF: IPersistfile; 189 begin 190 PF := Doc as IPersistfile; 191 result := PF.Load(_URL, 0); 192 end; 193 194 // 获取图像链接 195 procedure TUILess.GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings); 196 var 197 Image: IHTMLImgElement; 198 Disp: IDispatch; 199 x: Integer; 200 begin 201 if IC <> nil then 202 begin 203 for x := 0 to IC.Length - 1 do 204 begin 205 application.ProcessMessages; 206 Disp := IC.item(x, 0); 207 if SUCCEEDED(Disp.QueryInterface(IHTMLImgElement, Image)) then 208 ImageList.add(string(Image.src)); 209 end; 210 end; 211 end; 212 213 // 获取链接 214 procedure TUILess.GetAnchorList(IC: IHTMLELEMENTCollection; 215 Anchorlist: TStrings); 216 var 217 anchor: IHTMLAnchorElement; 218 Disp: IDispatch; 219 x: Integer; 220 begin 221 if IC <> nil then 222 begin 223 for x := 0 to IC.Length - 1 do 224 begin 225 application.ProcessMessages; 226 Disp := IC.item(x, 0); 227 if (SUCCEEDED(Disp.QueryInterface(IHTMLAnchorElement, anchor)) and 228 (anchor.href <> '')) then 229 Anchorlist.add(string(anchor.href)); 230 end; 231 end; 232 end; 233 234 /// Don't Care ------>>>>>>>>>>> 235 function TUILess.OnRequestEdit(DispID: TDispID): HResult; 236 begin 237 result := E_NOTIMPL; 238 end; 239 240 function TUILess.SaveObject: HResult; 241 begin 242 result := E_NOTIMPL; 243 end; 244 245 function TUILess.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; 246 out mk: IMoniker): HResult; 247 begin 248 result := E_NOTIMPL; 249 end; 250 251 function TUILess.GetContainer(out container: IOleContainer): HResult; 252 begin 253 result := E_NOTIMPL; 254 end; 255 256 function TUILess.ShowObject: HResult; 257 begin 258 result := E_NOTIMPL; 259 end; 260 261 function TUILess.OnShowWindow(fShow: BOOL): HResult; 262 begin 263 result := E_NOTIMPL; 264 end; 265 266 function TUILess.RequestNewObjectLayout: HResult; 267 begin 268 result := E_NOTIMPL; 269 end; 270 271 end.
Unit3.pas：
1 unit Unit3; 2 3 interface 4 5 uses 6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 Dialogs, StdCtrls; 8 9 type 10 TForm3 = class(TForm) 11 Button1: TButton; 12 Edit1: TEdit; 13 Memo1: TMemo; 14 Button2: TButton; 15 Button3: TButton; 16 Button4: TButton; 17 procedure Button1Click(Sender: TObject); 18 procedure Button2Click(Sender: TObject); 19 procedure Button3Click(Sender: TObject); 20 procedure Button4Click(Sender: TObject); 21 private 22 { Private declarations } 23 procedure into(i: Word); 24 public 25 { Public declarations } 26 end; 27 28 var 29 Form3: TForm3; 30 31 implementation 32 uses UI_Less; 33 34 {$R *.dfm} 35 36 function DoStrToWideChar(s: string): PWideChar; 37 var 38 // s:sting; 39 pwc: PWidechar; 40 len: integer; 41 begin 42 // s:= 'abcdefg '; 43 len := length(s) + 1; 44 pwc := AllocMem(len * sizeof(widechar)); 45 stringtowidechar(s, pwc, len); 46 // showmessage(widechartostring(pwc)); 47 48 result := pwc; 49 // FreeMem(pwc); 50 end; 51 52 53 54 procedure TForm3.into(i: Word); 55 var 56 sh: TUILess; 57 su: boolean; // 是否获取成功 58 // isstop: boolean; //设全局变量可以中断连接 ,避免出错 59 surl: PWideChar; 60 begin 61 surl := DoStrToWideChar(Trim(Edit1.Text)); 62 sh := TUILess.Create(nil); 63 try 64 Memo1.Clear; 65 case i of 66 1: 67 sh.GetAnchorList(sh.get(surl, su, False), Memo1.Lines); 68 2: 69 sh.GetImageList(sh.get(surl, su, False), Memo1.Lines); 70 3: 71 begin 72 sh.get(surl, su, False); 73 Memo1.Lines := sh.BodyText; 74 end; 75 4: 76 begin 77 sh.get(surl, su, False); 78 Memo1.Lines := sh.BodyHtml; 79 end; 80 end; 81 finally 82 //sh.Free; 83 end; 84 end; 85 86 procedure TForm3.Button1Click(Sender: TObject); 87 begin 88 into(1); 89 end; 90 91 procedure TForm3.Button2Click(Sender: TObject); 92 begin 93 into(2); 94 end; 95 96 procedure TForm3.Button3Click(Sender: TObject); 97 begin 98 into(3); 99 end; 100 101 procedure TForm3.Button4Click(Sender: TObject); 102 begin 103 into(4); 104 end; 105 106 end.