Unit WebHelper;
{
Unit: WebHelper
Developer: ase, nsX-gteX
Compiler: Delphi, v7.0 Build 4453
Date: 07.05.2003 19:00 --> 08.05.2003 00:15
Classes: TWebHelper -> This class provides capabilities to add
HTML text
to a TWebBrowser component without creating temprary
files or stuff.
Usage: See implementation part.
Comments: Have fun with it!
License: No license. Use it or leave it. My name in your copyright is not
required. A copy of your program would be nice but although, is not
required.
}
Interface
Uses Classes, ComObj, MSHTML, SHDocVw, Variants, SyncObjs;
Type TWebHelper = Class;
TWebHelper = Class(TInterfacedObject)
Private
FBrowser: TWebBrowser;
FIsReady: WordBool;
FClear: WordBool;
FSave: TCriticalSection;
FLineBreak: WordBool;
Function Get_CanPost: WordBool;
Protected
Procedure Event_DocumentComplete(Sender: TObject;
Const pDisp: IDispatch; Var
URL: OleVariant);
Procedure ScrollDown();
Public
Constructor Create(ABrowser: TWebBrowser);
Destructor Destroy; Override;
Procedure LoadFromStrings(AStrings: TStrings);
Procedure WriteOneString(Const Msg: WideString);
Property WebBrowser: TWebBrowser read FBrowser;
Property CanPost: WordBool read Get_CanPost;
Property ClearBeforePost: WordBool read FClear write FClear;
Property LineBreak: WordBool read FLineBreak write FLineBreak;
End;
Implementation
Uses SysUtils,
ActiveX;
ResourceString sLineBreakStr = '
';
sNotReady = 'Cannot display
HTML code yet. Control not initialized.';
sAboutBlank = 'about
:blank';
{
TWebHelper - Usage
Property WebBrowser: Read-Only. Returns the TWebBrowser component, TWebHelper
actually controlls. You specify this control in the
constructor of TWebHelper.
Property CanPost: TWebHelper needs to initialize the TWebBrowser control.
This initialization step is done ASYNCHRONOUSLY by the
control itself. If done, the control will notify TWebHelper
and from there you will be able to post data. If you try
to post data wheater TWebHelper is not ready, an
exception
is raised. The property getter is thread safe.
Property ClearBeforePost:
Determined if TWebHelper should clear the browser control
before adding new data. If FALSE, the new data is simply
added to the browser control.
Property LineBreak: If TRUE, TWebHelper will add a
(sLineBreakStr) to
every post.
Procedure LoadFromStrings(AStrings: TStrings)
This method will add the strings in AStrings to the
browser control. If CanPost is FALSE, an
exception is raised.
Always encapsulate this call in a Try..Except block!
The method does _not_
handle exceptions. The AStrings
parameter will be handled as read-only an will not be
changed.
Procedure WriteOneString(Const Msg: WideString)
With that nice trick you can add a single line to the
Browser control. Usefull for administrator messages.
If CanPost is FALSE, an
exception is raised.
Always encapsulate this call in a Try..Except block!
The method does _not_
handle exceptions.
}
Constructor TWebHelper.Create(ABrowser: TWebBrowser);
Var v: OleVariant;
Begin
Inherited Create;
// private initialization...
FIsReady := False;
FSave := TCriticalSection.Create;
FClear := False;
FLineBreak := True;
// Init the browser. We need to do this step to prevent the browser from
// setting FBrowser.Document to NIL. We need the document property. The browser
// will initialize it only if he has a valid document. 'ABOUT
:BLANK' is valid.
// Search www.msdn.micro$oft.com for more details.
FBrowser := ABrowser;
FBrowser.OnDocumentComplete := Event_DocumentComplete;
v := sAboutBlank;
FBrowser.Navigate2(v);
End;
Procedure TWebHelper.Event_DocumentComplete(Sender: TObject; Const pDisp: IDispatch;
Var
URL: OleVariant);
Begin
// Browser calls us that he has finished his initialization. Fine!
Try
FSave.Enter;
FIsReady := True;
Finally
FSave.Leave;
End;
End;
Procedure TWebHelper.WriteOneString(Const Msg: WideString);
Var Doc: IHTMLDocument2;
v: OleVariant;
Begin
// Are we ready?
If not CanPost then
Raise
Exception.Create(sNotReady);
Try
// Get the Document interface.
OleCheck(FBrowser.DefaultInterface.Document.QueryInterface(IHTMLDocument2, Doc));
// Do we have to clear the page?
If FClear then
Doc.close;
// Create the array with only one element. Attention: varOleStr does not work.
// Only God knows why because it should:
MSDN.
v := VarArrayCreate([0, 0], varVariant);
If FLineBreak then
v[0] := Msg + sLineBreakStr
Else
v[0] := Msg;
// Send the data to the browser.
Doc.write(PSafeArray(TVarData(v).VArray));
ScrollDown();
Finally
// clear the array and release the document.
v := Unassigned;
Doc := Nil;
End;
End;
Function TWebHelper.Get_CanPost: WordBool;
Begin
Try
// Thread save.
FSave.Enter;
Result := FIsReady;
Finally
FSave.Leave;
End;
End;
Procedure TWebHelper.LoadFromStrings(AStrings: TStrings);
Var Doc: IHTMLDocument2;
v: OleVariant;
i: Integer;
Begin
// Are we ready?
If not CanPost then
Raise
Exception.Create(sNotReady);
Try
// Get document interface
OleCheck(FBrowser.DefaultInterface.Document.QueryInterface(IHTMLDocument2, Doc));
// Clear the window if neccessary.
If FClear then
Doc.close;
// Create the array and copy the string list into it.
v := VarArrayCreate([0, AStrings.Count - 1], varVariant);
For i := 0 to AStrings.Count - 1 do
If (i = AStrings.Count - 1) and FLineBreak then
v[i] := AStrings[i] + sLineBreakStr
Else
v[i] := AStrings[i];
// Send the data.
Doc.write(PSafeArray(TVarData(v).VArray));
doc.close;
ScrollDown();
Finally
// free the array and release the interface pointer.
v := Unassigned;
Doc := Nil;
End;
End;
Procedure TWebHelper.ScrollDown();
Var doc: IHTMLDocument2;
Begin
// Are we ready?
If not CanPost then
Raise
Exception.Create(sNotReady);
Try
// Get document interface
OleCheck(FBrowser.DefaultInterface.Document.QueryInterface(IHTMLDocument2, Doc));
Doc.parentWindow.scroll(0, 0);
Doc.parentWindow.scroll(0, MaxInt);
Finally
Doc := Nil;
End;
End;
Destructor TWebHelper.Destroy;
Begin
// we do _NOT_ free the browser. this is the
VCL's job guy!
FBrowser := Nil;
// But the CS is ours...
FSave.Free;
Inherited Destroy;
End;
End.
// GREETZ!