source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/IEParser.pas

Last change on this file was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 35.4 KB
Line 
1//****************************************************
2// TIEParser *
3// For Delphi 5 - 2009 *
4// Freeware Component *
5// by *
6// *
7// Per Lindsø Larsen & *
8// Eran Bodankin (bsalsa) *
9// bsalsa@gmail.com *
10// *
11// Documentation and updated versions: *
12// http://www.bsalsa.com *
13//****************************************************
14
15{*******************************************************************************}
16{LICENSE:
17THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
18EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
19WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
20YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
21AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
22AND DocUMENTATION. BSALSA PRODUCTIONS DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
23OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
24OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
25INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
26OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SystemS,
27AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SystemS. BSALSA PRODUCTIONS SPECIFICALLY
28DISCLAIMS ANY EXPRES OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.
29
30You may use, change or modify the component under 4 conditions:
311. In your website, add a Link to "http://www.bsalsa.com"
322. In your application, add credits to "Embedded Web Browser"
333. Mail me (bsalsa@gmail.com) any code change in the unit
34 for the benefit of the other users.
354. Please consider donation in our web site!
36{*******************************************************************************}
37//$Id: IEParser.pas,v 1.3 2009/04/05 05:55:31 bsalsa Exp $
38
39unit IEParser;
40
41{$I EWB.inc}
42
43interface
44
45uses
46 Dialogs, ShlObj, ComObj, Windows, Mshtml_Ewb, ActiveX, Classes;
47
48type
49 TProxySettings = class(TPersistent)
50 private
51 FPort: Integer;
52 FServer: string;
53 FAutoLoadProxy: Boolean;
54 public
55 function SetProxy(const FullUserAgent, ProxyServer: string): Boolean;
56 published
57 property AutoLoadProxy: Boolean read FAutoLoadProxy write FAutoLoadProxy
58 default False;
59 property Port: Integer read FPort write FPort default 80;
60 property Server: string read FServer write FServer;
61 end;
62
63type
64 TElementInfo = record
65 ClassName: string;
66 Id: string;
67 InnerHTML: string;
68 InnerText: string;
69 Lang: string;
70 Language: string;
71 OffsetHeight: Integer;
72 OffsetLeft: Integer;
73 OffsetTop: Integer;
74 OffsetWIdth: Integer;
75 OuterHTML: string;
76 OuterText: string;
77 RecordNumber: OleVariant;
78 SourceIndex: Integer;
79 TagName: string;
80 Title: string;
81 end;
82
83 TDownloadControlOption = (
84 DownloadImages, DownloadVideos, DownloadBGSounds, DontExecuteScripts,
85 DontExecuteJava, DontExecuteActiveX, DontDownloadActiveX,
86 DownloadButDontDisplay, DontDownloadFrame, CheckPageResynchronize,
87 DownloadAndIgnoreCache, DontDownloadBehaviors, SuppressedMetaCharset,
88 DisableUrlIfEncodingUTF8, EnableUrlIfEncodingUTF8,
89 ForceOfflineMode, DontPerformClientPull, DownloadInSilentMode, WorkOffline);
90 TDownloadControlOptions = set of TDownloadControlOption;
91
92 TParserState = (psBusy, psReady, psStopped); {A state for Busy status}
93
94 TOnParseErrorEvent = procedure(Sender: TObject; const ErrorCode: integer; const
95 Url, stError: string) of object;
96 TOnParseDocumentEvent = procedure(Sender: TObject; const Res: HRESULT; stMessage: string) of object;
97 TOnStatusTextEvent = procedure(Sender: TObject; const Text: string) of object;
98 TOnDocInfoEvent = procedure(Sender: TObject; const Text: string) of object;
99 TOnParseCompleteEvent = procedure(Sender: TObject; Doc: IhtmlDocument2; All: IHtmlElementCollection) of object;
100 TOnBREvent = procedure(Sender: TObject; Clear: string; Element: TElementInfo) of object;
101 TOnHREvent = procedure(Sender: TObject; Align: string; Color, Width, Size:
102 OleVariant; NoShade: Boolean; Element: TElementInfo) of object;
103 TOnDIVEvent = procedure(Sender: TObject; Align: string; NoWrap: Boolean;
104 Element: TElementInfo) of object;
105 TOnScriptEvent = procedure(Sender: Tobject; Source: string; ScriptElement: IHTMLScriptElement; Element: TElementInfo) of object;
106 TOnFormEvent = procedure(Sender: TObject; Action, Dir, Encoding, Method, Target, Name: string;
107 Element: TElementInfo) of object;
108 TOnMarqueeEvent = procedure(Sender: TObject; bgColor, Width, Height: OleVariant;
109 Direction, Behavior: string; ScrollAmount, ScrollDelay, Loop, vSpace, hSpace:
110 Integer; Element: TElementInfo) of object;
111 TOnFontEvent = procedure(Sender: TObject; Color, Size: OleVariant; Face: string;
112 Element: TElementInfo) of object;
113 TOnBaseFontEvent = procedure(Sender: TObject; Color: OleVariant; Face: string;
114 Size: Integer; Element: TElementInfo) of object;
115 TOnBaseEvent = procedure(Sender: TObject; hRef, Target: string; Element: TElementInfo) of object;
116 TOnMetaEvent = procedure(Sender: TObject; HttpEquiv, Content, Name, URL, Charset:
117 string; Element: TElementInfo) of object;
118 TOnBodyEvent = procedure(Sender: TObject; Background, bgProperties: string; LeftMargin,
119 TopMargin, RightMargin, BottomMargin, bgColor, Text, Link, vLink, aLink: OleVariant;
120 NoWrap: Boolean; Element: TElementInfo) of object;
121{ TOnImageEvent = procedure(Sender: TObject; Source, LowSrc, Vrml, DynSrc, Alt, Align,
122 UseMap: string; IsMap: Boolean; Border, Loop: OleVariant; vSpace, hSpace, Width,
123 Height: Integer; Element: TElementInfo) of object; }
124
125 TOnImageEvent = procedure(Sender: TObject; Source: string; ImgElement: IHTMLImgElement; Element: TElementInfo) of object;
126
127 TOnAnchorEvent = procedure(Sender: TObject; hRef, Target, Rel, Rev, Urn, Methods, Name,
128 Host, HostName, PathName, Port, Protocol, Search, Hash, AccessKey, ProtocolLong,
129 MimeType, NameProp: string; Element: TElementInfo) of object;
130 TOnCommentEvent = procedure(sender: TObject; Text: string; Element: TElementInfo) of object;
131 TOnElementEvent = procedure(Sender: TObject; ElementInfo: TElementInfo) of object;
132 TNoFramesEvent = procedure(Sender: TObject; ELement: TElementInfo) of object;
133 TOnFrameEvent = procedure(Sender: TObject; Source, Name: OleVariant; Element:
134 TElementInfo) of object;
135 TOnFrameSetEvent = procedure(Sender: TObject; Rows, Cols, FrameBorder, Name:
136 WIdeString; Border, BorderColor, FrameSpacing: OleVariant; Element:
137 TelementInfo) of object;
138 TStateChangeEvent = procedure(Sender: TObject; const State: TParserState) of object;
139 TOnStartParsingEvent = procedure(Sender: TObject; const aUrl: WideString) of object;
140 TOnQueryInfoEvent = procedure(const MimeType, Encoding, Disposition: string) of object;
141
142 TIEParser = class(
143 TComponent,
144 IUnknown,
145 IDispatch,
146 IPropertyNotifySink,
147 IOleClientSite)
148
149 private
150 BoolWorking: Boolean;
151 Element: TElementInfo;
152 FAbout: string;
153 FAnchor: TOnAnchorEvent;
154 FBase: TOnBaseEvent;
155 FBaseFont: TOnBaseFontEvent;
156 FBody: TOnBodyEvent;
157 FBr: TOnBREvent;
158 FBusy: Boolean;
159 FComment: TOnCommentEvent;
160 FDiv: TOnDIVEvent;
161 FOnParseComplete: TOnParseCompleteEvent;
162 FDownloadControlOptions: TDownloadControlOptions;
163 FDownloadOnly: Boolean;
164 FElement: TOnElementEvent;
165 FFont: TOnFontEvent;
166 FForm: TOnFormEvent;
167 FHr: TOnHREvent;
168 FHtml: WIdeString;
169 FImage: TOnImageEvent;
170 FMarquee: TOnMarqueeEvent;
171 FMimeType: string;
172 FDisposition: string;
173 FEncoding: string;
174 FMeta: TOnMetaEvent;
175 FOnBusy: TNotifyEvent;
176 FOnDocInfo: TOnDocInfoEvent;
177 FOnFrame: TOnFrameEvent;
178 FOnFrameset: TOnFrameSetEvent;
179 FOnNoFrame: TNoFramesEvent;
180 FOnQueryInfo: TOnQueryInfoEvent;
181 FOnParseDocument: TOnParseDocumentEvent;
182 FOnParseError: TOnParseErrorEvent;
183 FOnStateChange: TStateChangeEvent;
184 FOnStartParsing: TOnStartParsingEvent;
185 FOnStatusText: TOnStatusTextEvent;
186 FParseNoFrames: Boolean;
187 FProxySettings: TProxySettings;
188 FScript: TOnScriptEvent;
189 FParserState: TParserState;
190 FUrl: string;
191 LoadingFromString: Boolean;
192 NoFramesFound: Boolean;
193 StartTick: Int64;
194 private
195 function UpdateDownloadControlValues: LongInt;
196 protected
197 function ProcessDoc(const aUrl: WideString): IHTMLDocument2;
198 function GetContainer(out container: IOleContainer): HRESULT; stdcall;
199 function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out mk: IMoniker): HRESULT; stdcall;
200 function Invoke(DispId: Integer; const IId: TGUId; LocaleId: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
201 function LoadFromString: HRESULT;
202 function LoadUrlFromMoniker(const aUrl: WideString): HRESULT;
203 function OnChanged(dispId: TDispId): HRESULT; stdcall;
204 function OnRequestEdit(dispId: TDispId): HRESULT; stdcall;
205 function OnShowWindow(fShow: BOOL): HRESULT; stdcall;
206 function RequestNewObjectLayout: HRESULT; stdcall;
207 function SaveObject: HRESULT; stdcall;
208 function ShowObject: HRESULT; stdcall;
209 procedure Finalize;
210 procedure GetPageProperties;
211 procedure Initialize;
212 procedure SetAbout(const Value: string);
213 procedure DoQueryInfo(const aUrl: string);
214 public
215 All: IHtmlElementCollection;
216 Doc: IHTMLDocument2;
217 constructor Create(Owner: Tcomponent); override;
218 destructor Destroy; override;
219 procedure BeforeDestruction; override;
220 procedure Parse(const aUrl: WideString);
221 procedure Stop;
222 procedure Loaded; override;
223 public
224 property Busy: Boolean read FBusy;
225 property ParserState: TParserState read FParserState;
226 property MimeType: string read FMimeType;
227 property Disposition: string read FDisposition;
228 property Encoding: string read FEncoding;
229 published
230 property About: string read FAbout write SetAbout;
231 property DownloadOnly: Boolean read FDownloadOnly write FDownloadOnly default false;
232 property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions
233 write FDownloadControlOptions default [DownloadImages, DownloadBGSounds,
234 DownloadVideos, DownloadButDontDisplay, DontExecuteScripts,
235 DontExecuteJava, DontExecuteActiveX, DontDownloadActiveX];
236 property Html: WIdeString read FHtml write FHtml;
237 property OnAnchor: TOnAnchorEvent read FAnchor write FAnchor;
238 property OnBase: TOnBaseEvent read FBase write FBase;
239 property OnBaseFont: TOnBaseFontEvent read FBaseFont write FBaseFont;
240 property OnBody: TOnBodyEvent read FBody write FBody;
241 property OnBR: TOnBREvent read FBr write FBr;
242 property OnBusyStateChange: TNotifyEvent read FOnBusy write FOnBusy;
243 property OnComment: TOnCommentEvent read FComment write FComment;
244 property OnDiv: TOnDIVEvent read FDiv write FDiv;
245 property OnDocInfo: TOnDocInfoEvent read FOnDocInfo write FOnDocInfo;
246 property OnParseComplete: TOnParseCompleteEvent read FOnParseComplete write FOnParseComplete;
247 property OnElement: TOnElementEvent read FElement write FElement;
248 property OnFont: TOnFontEvent read FFont write FFont;
249 property OnForm: TOnFormEvent read FForm write FForm;
250 property OnFrame: TOnFrameEvent read FOnFrame write FOnFrame;
251 property OnFrameSet: TOnFrameSetEvent read FOnFrameset write FOnFrameset;
252 property OnQueryInfo: TOnQueryInfoEvent read FOnQueryInfo write
253 FOnQueryInfo;
254 property OnHR: TOnHREvent read FHr write FHr;
255 property OnImage: TOnImageEvent read FImage write FImage;
256 property OnMarquee: TOnMarqueeEvent read FMarquee write FMarquee;
257 property OnMeta: TOnMetaEvent read FMeta write FMeta;
258 property OnNoFrame: TNoFramesEvent read FOnNoFrame write FOnNoFrame;
259 property OnParseDocument: TOnParseDocumentEvent read FOnParseDocument write FOnParseDocument;
260 property OnParseError: TOnParseErrorEvent read FOnParseError write FOnParseError;
261 property OnScript: TOnScriptEvent read FScript write FScript;
262 property OnStateChange: TStateChangeEvent read FOnStateChange write
263 FOnStateChange;
264 property OnStartParsing: TOnStartParsingEvent read FOnStartParsing write FOnStartParsing;
265 property OnStatusText: TOnStatusTextEvent read FOnStatusText write FOnStatusText;
266 property ParseNoFrames: Boolean read FParseNoFrames write FParseNoFrames default False;
267 property ProxySettings: TProxySettings read FProxySettings write FProxySettings;
268 property URL: string read FUrl write FUrl;
269 end;
270
271
272implementation
273
274uses
275 IEConst, IEDownloadStrings, IEDownloadTools, SysUtils, IeDownloadAcc, UrlMon, WinInet;
276
277
278function TIEParser.GetContainer(out container: IOleContainer): HRESULT;
279begin
280 Result := E_NOTIMPL;
281end;
282
283function TIEParser.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out mk:
284 IMoniker): HRESULT;
285begin
286 Result := E_NOTIMPL;
287end;
288
289function TIEParser.Invoke(DispId: Integer; const IId: TGUId; LocaleId: Integer;
290 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
291var
292 I: Integer;
293begin
294 if DispId = DISPID_AMBIENT_DLCONTROL then
295 begin
296 i := UpdateDownloadControlValues;
297 PVariant(VarResult)^ := I;
298 Result := S_OK;
299 end
300 else
301 Result := DISP_E_MEMBERNOTFOUND;
302end;
303
304function TIEParser.LoadFromString: HRESULT;
305var
306 V: OleVariant;
307 vDocument: OleVariant;
308 vMimeType: OleVariant;
309 vHtml: OleVariant;
310begin
311 if FHtml = '' then
312 begin
313 if Assigned(FOnParseError) then
314 FOnParseError(Self, E_FAIL, FUrl, Err_Load_Str + ResponseCodeToStr(E_FAIL));
315 Result := E_FAIL;
316 end else
317 try
318 if (Assigned(FOnParseDocument)) then
319 FOnParseDocument(Self, S_OK, Succ_Load_Str + ResponseCodeToStr(S_OK));
320
321 //Stop any actions - this is important!
322 // FWeb.Stop; no dealing with the Document directly
323 // Grab the Document
324 V := Doc;
325 vDocument := V.script.Document;
326 vMimeType := 'text/Html';
327 vHtml := FHtml;
328 vDocument.Open(vMimeType);
329 vDocument.Clear;
330 vDocument.Write(vHtml);
331 vDocument.Close;
332 Result := S_OK;
333 except
334 Result := E_FAIL;
335 end;
336end;
337
338function TIEParser.OnChanged(dispId: TDispId): HRESULT;
339var
340 DP: TDispParams;
341 vResult: OLEVariant;
342begin
343 Result := S_OK;
344 if Doc = nil then Exit;
345 if (DISPId_READYSTATE = DispId) then
346 if SUCCEEDED((Doc as IHtmlDocument2).Invoke(DISPId_READYSTATE, GUId_null,
347 LOCALE_System_DEFAULT, DISPATCH_PROPERTYGET, DP, @vResult, nil, nil)) then
348 if Integer(vResult) = READYSTATE_COMPLETE then
349 PostThreadMessage(GetCurrentThreadId(), WM_USER_STARTWALKING, 0, 0);
350end;
351
352function TIEParser.OnRequestEdit(dispId: TDispId): HRESULT;
353begin
354 Result := E_NOTIMPL;
355end;
356
357function TIEParser.OnShowWindow(fShow: BOOL): HRESULT;
358begin
359 Result := E_NOTIMPL;
360end;
361
362function TIEParser.RequestNewObjectLayout: HRESULT;
363begin
364 Result := E_NOTIMPL;
365end;
366
367function TIEParser.SaveObject: HRESULT;
368begin
369 Result := E_NOTIMPL;
370end;
371
372function TIEParser.ShowObject: HRESULT;
373begin
374 Result := E_NOTIMPL;
375end;
376
377function TIEParser.UpdateDownloadControlValues: LongInt;
378const
379 AcardDownloadControlValues: array[TDownloadControlOption] of Cardinal =
380 ($00000010, $00000020, $00000040, $00000080,
381 $00000100, $00000200, $00000400, $00000800,
382 $00001000, $00002000, $00004000, $00008000,
383 $00010000, $00020000, $00040000, $10000000,
384 $20000000, $40000000, $80000000);
385var
386 i: TDownloadControlOption;
387 j: Longint;
388begin
389 j := 0;
390 if (FDownloadControlOptions <> []) then
391 for i := Low(TDownloadControlOption) to High(TDownloadControlOption) do
392 if (i in FDownloadControlOptions) then
393 Inc(j, AcardDownloadControlValues[i]);
394 Result := j;
395end;
396
397constructor TIEParser.Create(Owner: Tcomponent);
398begin
399 inherited Create(Owner);
400 FAbout := 'TIEParser from: http://www.bsalsa.com';
401 DownloadOptions := [DownloadImages, DownloadBGSounds,
402 DownloadVideos, DownloadButDontDisplay, DontExecuteScripts,
403 DontExecuteJava, DontExecuteActiveX, DontDownloadActiveX];
404 FProxySettings := TProxySettings.Create;
405 FProxySettings.FPort := 80;
406 FParserState := psReady;
407end;
408
409procedure TIEParser.BeforeDestruction;
410begin
411 if FProxySettings.FAutoLoadProxy then
412 FProxySettings.SetProxy(EmptyStr, EmptyStr); {To restore proxy settings}
413 inherited BeforeDestruction;
414end;
415
416destructor TIEParser.Destroy;
417begin
418 if Assigned(Doc) then
419 Doc := nil;
420 if Assigned(All) then
421 All := nil;
422 FProxySettings.Free;
423 inherited Destroy;
424end;
425
426procedure TIEParser.Loaded;
427begin
428 inherited Loaded;
429 FBusy := False;
430 FParserState := psReady;
431 if (FProxySettings.FAutoLoadProxy) and (FProxySettings.FServer <> EmptyStr)
432 then
433 FProxySettings.SetProxy(USER_AGENT_IE6, FProxySettings.FServer + ':' +
434 IntToStr(FProxySettings.FPort));
435end;
436
437procedure TIEParser.SetAbout(const Value: string);
438begin
439 Exit;
440end;
441
442procedure TIEParser.GetPageProperties;
443begin
444 if (Doc <> nil) and (Assigned(Doc)) and (Doc.readyState = 'complete') then
445 begin
446 if (Assigned(FOnDocInfo)) then
447 begin
448 try
449 FOnDocInfo(Self, 'Title: ' + Doc.title);
450 FOnDocInfo(Self, 'Design Mode: ' + Doc.designMode);
451 FOnDocInfo(Self, 'State: ' + Doc.readyState);
452 FOnDocInfo(Self, 'Referrer: ' + Doc.Referrer);
453 FOnDocInfo(Self, 'Location: ' + Doc.location.href);
454 FOnDocInfo(Self, 'Last Modified: ' + Doc.lastModified);
455 FOnDocInfo(Self, 'URL: ' + Doc.url);
456 if FHTML <> '' then
457 FOnDocInfo(Self, 'Domain: ' + Doc.domain);
458 FOnDocInfo(Self, 'Cookie: ' + Doc.cookie);
459 FOnDocInfo(Self, 'Charset: ' + Doc.charset);
460 FOnDocInfo(Self, 'Default Charset: ' + Doc.defaultCharset);
461 FOnDocInfo(Self, 'File Updated Date: ' + Doc.fileUpdatedDate);
462 FOnDocInfo(Self, 'Security: ' + Doc.security);
463 FOnDocInfo(Self, 'Protocol: ' + Doc.protocol);
464 FOnDocInfo(Self, 'Name Property: ' + Doc.nameProp);
465 FOnDocInfo(Self, 'Path Name: ' + Doc.location.pathname);
466 FOnDocInfo(Self, 'Port: ' + Doc.location.port);
467 FOnDocInfo(Self, 'Protocol: ' + Doc.location.protocol);
468 FOnDocInfo(Self, 'Host: ' + Doc.location.host);
469 FOnDocInfo(Self, 'Hash: ' + Doc.location.hash);
470 FOnDocInfo(Self, 'Search: ' + Doc.location.search);
471 FOnDocInfo(Self, 'Language: ' + Doc.body.language);
472 FOnDocInfo(Self, 'Lang: ' + Doc.body.lang);
473 {I Disabled the following because it my cause AV on some sites}
474 //FOnDocInfo(Self,'MimeType: ' + Doc.MimeType);
475 //FOnDocInfo(Self,'File Size: '+ Doc.fileSize);
476 //FOnDocInfo(Self,'File Created Date: '+ Doc.fileCreatedDate);
477 //FOnDocInfo(Self,'File Modified Date: '+ Doc.fileModifiedDate);
478 except
479 end;
480 end;
481 end;
482end;
483
484function TIEParser.LoadUrlFromMoniker(const aUrl: WideString): HRESULT;
485var
486 FMoniker: IMoniker;
487 FBindCtx: IBindCTX;
488 HR: HRESULT;
489begin
490 HR := CreateURLMonikerEx(nil, PWideChar(aUrl), FMoniker, URL_MK_UNIFORM {URL_MK_LEGACY});
491 if Failed(HR) and Assigned(FOnParseError) then
492 FOnParseError(Self, GetLastError, FUrl, Err_URLMEx +
493 ResponseCodeToStr(HR))
494 else if (Assigned(FOnParseDocument)) then
495 FOnParseDocument(Self, HR, CreateURLMEx + ResponseCodeToStr(HR));
496
497 HR := CreateBindCtx(0, FBindCtx);
498 if Failed(HR) and Assigned(FOnParseError) then
499 FOnParseError(Self, GetLastError, FUrl, Err_AsyncBindCtx +
500 ResponseCodeToStr(HR))
501 else if (Assigned(FOnParseDocument)) then
502 FOnParseDocument(Self, HR, CreateABindCtx + ResponseCodeToStr(HR));
503
504 HR := (Doc as IpersistMoniker).Load(LongBool(0), FMoniker, FBindCtx, STGM_READ);
505 if Failed(HR) and Assigned(FOnParseError) then
506 FOnParseError(Self, GetLastError, FUrl, Err_IpersistMoniker_Load
507 + ResponseCodeToStr(HR))
508 else if (Assigned(FOnParseDocument)) then
509 FOnParseDocument(Self, HR, Succ_IpersistMoniker_Load + ResponseCodeToStr(HR));
510 Result := HR;
511end;
512
513function TIEParser.ProcessDoc(const aUrl: WideString): IHTMLDocument2;
514var
515 C: Integer;
516 ConnectionPoint: IConnectionPoint;
517 HR: HRESULT;
518begin
519 LoadingFromString := False;
520 if Assigned(FOnStartParsing) then
521 FOnStartParsing(Self, aUrl);
522 HR := CoCreateInstance(CLASS_HtmlDocument, nil, CLSCTX_INPROC_SERVER,
523 IHtmlDocument2, Doc);
524 if Failed(HR) and Assigned(FOnParseError) then
525 FOnParseError(Self, GetLastError, FUrl, Err_CoCreateInstance + ResponseCodeToStr(HR))
526 else if (Assigned(FOnParseDocument)) then
527 FOnParseDocument(Self, HR, Succ_CoCreateInstance + ResponseCodeToStr(HR));
528
529 HR := (Doc as IOleObject).SetClientSite(Self as IOleClientsite);
530 if Failed(HR) and Assigned(FOnParseError) then
531 FOnParseError(Self, GetLastError, FUrl, Err_Doc_AsSetClientSite + ResponseCodeToStr(HR))
532 else if (Assigned(FOnParseDocument)) then
533 FOnParseDocument(Self, HR, Doc_AsSetClientSite + ResponseCodeToStr(HR));
534
535 HR := (Doc as IOleControl).OnAmbientPropertyChange(DISPId_AMBIENT_DLCONTROL);
536 if Failed(HR) and Assigned(FOnParseError) then
537 FOnParseError(Self, GetLastError, FUrl, Err_Doc_AsAmbientPropertyChange + ResponseCodeToStr(HR))
538 else if (Assigned(FOnParseDocument)) then
539 FOnParseDocument(Self, HR, Doc_AsAmbientPropertyChange + ResponseCodeToStr(HR));
540
541 HR := (Doc as IConnectionPointContainer).FindConnectionPoint(IpropertyNotifySink, ConnectionPoint);
542 if Failed(HR) and Assigned(FOnParseError) then
543 FOnParseError(Self, GetLastError, FUrl, Err_Doc_AsPointContainer + ResponseCodeToStr(HR))
544 else if (Assigned(FOnParseDocument)) then
545 FOnParseDocument(Self, HR, Doc_AsPointContainer + ResponseCodeToStr(HR));
546
547 HR := (ConnectionPoint.Advise(Self as IPropertyNotifySink, C));
548 if Failed(HR) and Assigned(FOnParseError) then
549 FOnParseError(Self, GetLastError, FUrl, Err_Doc_AsAdvise + ResponseCodeToStr(HR))
550 else if (Assigned(FOnParseDocument)) then
551 FOnParseDocument(Self, HR, Doc_AsAdvise + ResponseCodeToStr(HR));
552 DoQueryInfo(FUrl);
553 Result := Doc;
554end;
555
556procedure TIEParser.DoQueryInfo(const aUrl: string);
557var
558 hInet: HINTERNET;
559 hConnect: HINTERNET;
560 infoBuffer: array[0..1024] of Char;
561 dwReserved: DWORD;
562 bufLen: DWORD;
563 lbResult: LongBool;
564begin
565 hInet := InternetOpen('TDownload',
566 INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY, nil, nil, 0);
567 if hInet <> nil then
568 begin
569 try
570 hConnect := InternetOpenUrl(hInet, PChar(Url), nil, 0, INTERNET_FLAG_NO_UI, 0);
571 if Assigned(hConnect) then
572 begin
573 try
574 dwReserved := 0;
575 bufLen := Length(infoBuffer);
576
577 lbResult := HttpQueryInfo(hConnect, HTTP_QUERY_CONTENT_TYPE, @infoBuffer[0], bufLen, dwReserved);
578 if lbResult then
579 FMimeType := infoBuffer
580 else
581 FMimeType := EmptyStr;
582
583 lbResult := HttpQueryInfo(hConnect, HTTP_QUERY_CONTENT_ENCODING, @infoBuffer, bufLen, dwReserved);
584 if lbResult then
585 FEncoding := Encoding
586 else
587 FEncoding := EmptyStr;
588
589 lbResult := HttpQueryInfo(hConnect, HTTP_QUERY_CONTENT_DISPOSITION, @infoBuffer, bufLen, dwReserved);
590 if lbResult then
591 FDisposition := Disposition
592 else
593 FDisposition := EmptyStr;
594
595 if Assigned(FOnQueryInfo) then
596 FOnQueryInfo(FMimeType, FEncoding, FDisposition);
597 finally
598 InternetCloseHandle(hConnect);
599 end;
600 end;
601 finally
602 InternetCloseHandle(hInet);
603 end;
604 end;
605end;
606
607procedure TIEParser.Initialize;
608begin
609 Doc := nil;
610 All := nil;
611 FBusy := True;
612 FParserState := psBusy;
613 if Assigned(FOnStateChange) then
614 FOnStateChange(Self, FParserState);
615 BoolWorking := True;
616 StartTick := GetTickCount;
617 FUrl := Url;
618 LoadingFromString := False;
619 NoFramesFound := False;
620 CoInitialize(nil);
621end;
622
623procedure TIEParser.Stop;
624begin
625 if Assigned(Doc) then
626 Doc := nil;
627 if Assigned(All) then
628 All := nil;
629 FreeAndNil(Element);
630 FUrl := EmptyStr;
631 FBusy := False;
632 Finalize;
633end;
634
635procedure TIEParser.Parse(const aUrl: WideString);
636 function ContainsAboutBlank(const s: string): Boolean;
637 begin
638 Result := Pos('about:blank', LowerCase(s)) > 0;
639 end;
640
641var
642 E: IHtmlElement;
643 X: Integer;
644 Msg: TMsg;
645 v, u: OleVariant;
646 ParseTime, NoFramesContent, Us: string;
647 HR: HRESULT;
648begin
649 Initialize;
650 FUrl := aUrl;
651 ProcessDoc(aUrl);
652 NoFramesContent := '';
653 if FUrl <> '' then
654 begin
655 HR := S_OK;
656 if IEDownloadTools.IsValidURL(FUrl) then
657 HR := LoadUrlFromMoniker(FUrl);
658 if Failed(HR) and Assigned(FOnParseError) then
659 FOnParseError(Self, GetLastError, FUrl, Err_Load_Mon + ResponseCodeToStr(HR))
660 else if (Assigned(FOnParseDocument)) then
661 FOnParseDocument(Self, HR, Succ_Load_Mon + ResponseCodeToStr(HR));
662 end
663 else
664 HR := LoadFromString;
665
666 if (Doc = nil) then
667 begin
668 if Failed(HR) and Assigned(FOnParseError) then
669 FOnParseError(Self, GetLastError, FUrl, Err_Load_Str + ResponseCodeToStr(HR));
670 Exit;
671 end
672
673 else
674 begin
675 while (BoolWorking and GetMessage(Msg, 0, 0, 0)) do
676 begin
677 if ((Msg.Message = WM_USER_STARTWALKING) and (Msg.hWnd = 0)) then
678 begin
679 BoolWorking := False;
680 All := Doc.Get_all;
681 if (All <> nil) and (All.length <= 4) then
682 begin
683 if Assigned(FOnParseError) then
684 FOnParseError(Self, E_FAIL, FUrl, Doc_Error + ResponseCodeToStr(E_FAIL));
685 Exit;
686 end;
687 if (All <> nil) and not FDownloadOnly then
688 for x := 0 to All.length - 1 do
689 begin
690 E := All.item(x, 0) as IHTMLElement;
691 with Element do
692 begin
693 ClassName := E.className;
694 Id := E.id;
695 TagName := E.tagName;
696 Title := E.title;
697 Language := E.language;
698 SourceIndex := E.sourceIndex;
699 RecordNumber := E.recordNumber;
700 Lang := E.lang;
701 OffsetLeft := E.offsetLeft;
702 OffsetTop := E.offsetTop;
703 OffsetWidth := E.offsetWidth;
704 OffsetHeight := E.offsetHeight;
705 InnerHtml := E.innerHtml;
706 InnerText := E.innerText;
707 OuterHtml := E.outerHtml;
708 OuterText := E.outerText;
709 end;
710 if Assigned(FElement) then
711 FElement(Self, Element);
712
713 case StrToCase(E.TagName, ['FRAMESET', 'FRAME', 'NOFRAMES', 'A', '!',
714 'COMMENT', 'IMG', 'BODY', 'BASE', 'BASEFONT', 'FONT', 'META', 'MARQUEE',
715 'FORM', 'SCRIPT', 'DIV', 'HR', 'BR']) of
716 0: // FRAMESET
717 begin
718 if Assigned(FOnFrameSet) then
719 with All.item(x, 0) as IHTMLFrameSetElement do
720 FOnFrameSet(Self, Rows, Cols, FrameBorder, Name,
721 Border, BorderColor, FrameSpacing, Element);
722 end;
723 1: // FRAME
724 begin
725 if Assigned(FOnFrame) then
726 begin
727 v := E.GetAttribute('Name', 0);
728 u := E.GetAttribute('Src', 0); // JohnS ('Source' -> 'Src')
729 Us := u;
730 if LoadingFromString and ContainsAboutBlank(Us) then
731 Delete(Us, 1, 11);
732 FOnFrame(Self, Us, v, Element);
733 end;
734 end;
735 2: // NOFRAMES
736 begin
737 NoFramesContent := E.InnerHtml;
738 if Assigned(FOnNoFrame) then
739 FOnNoFrame(Self, Element);
740 end;
741 3: // A
742 begin
743 if Assigned(FAnchor) then
744 with All.item(x, 0) as IHTMLAnchorElement do
745 begin
746 Us := hRef;
747 if LoadingFromString and ContainsAboutBlank(Us) then
748 Delete(Us, 1, 11);
749 FAnchor(Self, Us, target, rel, rev, Urn, Methods,
750 name, host, hostname, pathname, port, protocol,
751 Search, Hash, AccessKey,
752 ProtocolLong, MimeType, NameProp, Element);
753 end;
754 end;
755 4 or 5: // !, COMMENT
756 begin
757 if Assigned(FComment) then
758 with All.item(x, 0) as IHTMLCommentElement do
759 FComment(Self, Text, Element)
760 else
761 if (E.TagName = 'IMG') and Assigned(FImage) then
762 with All.item(x, 0) as IHtmlImgElement do
763 begin
764 Us := Src;
765 if LoadingFromString and ContainsAboutBlank(Us) then
766 Delete(Us, 1, 11);
767 FImage(Self, Us, All.item(x, 0) as IHTMLImgElement, Element);
768 end;
769 end;
770
771 6: // IMG
772 begin
773 if Assigned(FImage) then
774 with All.item(x, 0) as IHTMLImgElement do
775 begin
776 Us := Src;
777 if LoadingFromString and ContainsAboutBlank(Us) then
778 Delete(Us, 1, 11);
779 FImage(Self, Us, All.item(x, 0) as IHTMLImgElement, Element);
780 end;
781 end;
782 7: // BODY
783 begin
784 if Assigned(FBody) then
785 with All.item(x, 0) as IHTMLBodyElement do
786 FBody(Self, Background, bgProperties,
787 LeftMargin, TopMargin, RightMargin, BottomMargin, bgColor, Text, Link,
788 vLink, aLink, NoWrap, Element);
789 end;
790 8: // BASE
791 begin
792 if Assigned(FBase) then
793 with All.item(x, 0) as IHTMLBaseElement do
794 begin
795 Us := hRef;
796 if LoadingFromString and ContainsAboutBlank(Us) then
797 Delete(Us, 1, 11);
798 FBase(Self, Us, Target, Element);
799 end;
800 end;
801 9: // BASEFONT
802 begin
803 if Assigned(FBaseFont) then
804 with All.item(x, 0) as IHTMLBaseFontElement do
805 FBaseFont(Self, color, face, size, Element);
806 end;
807 10: // FONT
808 begin
809 if Assigned(FFont) then
810 with All.item(x, 0) as IHTMLFontElement do
811 FFont(Self, color, size, face, Element);
812 end;
813 11: // META
814 begin
815 if Assigned(FMeta) then
816 with All.item(x, 0) as IHTMLMetaElement do
817 FMeta(Self, httpEquiv, content, name, url,
818 charset, Element);
819 end;
820 12: // MARQUEE
821 begin
822 if Assigned(FMarquee) then
823 with All.item(x, 0) as IHTMLMarqueeElement do
824 FMarquee(Self, bgColor, Width, Height, Direction, Behavior,
825 ScrollAmount, ScrollDelay, Loop, vSpace, hSpace, Element);
826 end;
827 13: // FORM
828 begin
829 if Assigned(FForm) then
830 with All.item(x, 0) as IHTMLFormElement do
831 FForm(Self, Action, Dir, Encoding, Method,
832 Target, Name, Element);
833 end;
834 14: // SCRIPT
835 begin
836 if Assigned(FScript) then
837 with All.item(x, 0) as IHTMLScriptElement do
838 begin
839 Us := Src;
840 if LoadingFromString and ContainsAboutBlank(Us) then
841 Delete(Us, 1, 11);
842 FScript(Self, Us, All.item(x, 0) as IHTMLScriptElement, Element);
843 end;
844
845 end;
846 15: // DIV - containers
847 begin
848 if Assigned(FDiv) then
849 with All.item(x, 0) as IHTMLDivElement do
850 FDiv(Self, Align, NoWrap, Element);
851 end;
852 16: // HR - horizontal rule
853 begin
854 if Assigned(FHr) then
855 with All.item(x, 0) as IHTMLHRElement do
856 FHr(Self, Align, Color, Width, Size, NoShade, Element);
857 end;
858 17: // BR - line break
859 begin
860 if Assigned(FBr) then
861 with All.item(x, 0) as IHTMLBRElement do
862 FBr(Self, Clear, Element);
863
864 end;
865 end;
866 end;
867 GetPageProperties;
868 end
869 else
870 DispatchMessage(Msg);
871 end;
872 end;
873 FUrl := '';
874 if (NoFramesFound) and (ParseNoFrames) then
875 begin
876 FHtml := NoFramesContent;
877 Parse(Url);
878 end;
879 if Assigned(FOnParseComplete) then
880 FOnParseComplete(Self, Doc, All);
881 ParseTime := FormatTickToTime(GetTickCount - StartTick);
882 if (Assigned(FOnParseDocument)) then
883 FOnParseDocument(Self, S_OK, Done + ' Process Time: ' + ParseTime);
884 Finalize;
885end;
886
887procedure TIEParser.Finalize;
888begin
889 FHtml := '';
890 FBusy := False;
891 FParserState := psStopped;
892 CoUninitialize;
893 if Assigned(FOnStateChange) then
894 FOnStateChange(Self, FParserState);
895end;
896
897function TProxySettings.SetProxy(const FullUserAgent, ProxyServer: string):
898 Boolean;
899var
900 intList: INTERNET_PER_CONN_OPTION_List;
901 dwBufSize: DWORD;
902 hInternet: Pointer;
903 intOptions: array[1..3] of INTERNET_PER_CONN_OPTION;
904begin
905 Result := False;
906 dwBufSize := SizeOf(intList);
907 intList.dwSize := SizeOf(intList);
908 intList.pszConnection := nil;
909 intList.dwOptionCount := High(intOptions);
910 // the highest index of the array (in this case 3)
911 intOptions[1].dwOption := INTERNET_PER_CONN_FLAGS;
912 intOptions[1].Value.dwValue := PROXY_TYPE_DIRECT or PROXY_TYPE_PROXY;
913 intOptions[2].dwOption := INTERNET_PER_CONN_PROXY_SERVER;
914 intOptions[2].Value.pszValue := PChar(ProxyServer);
915 intOptions[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS;
916 intOptions[3].Value.pszValue := '<local>';
917 intList.intOptions := @intOptions;
918 hInternet := InternetOpen(PChar(FullUserAgent), INTERNET_OPEN_TYPE_DIRECT,
919 nil, nil, 0);
920 if hInternet <> nil then
921 try
922 Result := InternetSetOption(hInternet,
923 INTERNET_OPTION_PER_CONNECTION_OPTION,
924 @intList, dwBufSize);
925 Result := Result and InternetSetOption(hInternet, INTERNET_OPTION_REFRESH,
926 nil, 0);
927 finally
928 InternetCloseHandle(hInternet)
929 end;
930end;
931{End of Proxy Settings-----------------------------------------------------------}
932
933
934initialization
935 OleInitialize(nil);
936
937finalization
938 try
939 OleUninitialize;
940 except
941 end;
942
943end.
944
945
Note: See TracBrowser for help on using the repository browser.