Subversion Repositories fastphp

Compare Revisions

Regard whitespace Rev 7 → Rev 8

/trunk/WebBrowserUtils.pas
0,0 → 1,327
unit WebBrowserUtils;
 
interface
 
uses
// In case ShDocVw_TLB can't be found, use ShDocVw
Windows, ShDocVw_TLB, SysUtils, Forms;
 
procedure WaitForBrowser(AWebBrowser: TWebbrowser);
 
function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
const AFakeURL: string=''): boolean;
 
type
TWebBrowserEx = class helper for TWebBrowser
public
procedure Clear;
procedure Wait;
function LoadHTML(const HTML: string; const AFakeURL: string=''): boolean;
end;
 
implementation
 
uses
ActiveX, urlmon;
 
type
(*
ILoadHTMLMoniker = interface(IMoniker)
['{DCAE3F41-9B38-40EB-B7D0-4AF0FBFBE5AB}']
procedure InitLoader(sContent, sBaseUrl: string);
end;
*)
TLoadHTMLMoniker = class (TInterfacedObject, IMoniker{, ILoadHTMLMoniker})
private
m_stream: IStream;
m_sBaseName: string;
public
procedure InitLoader(sContent, sBaseUrl: string);
{$REGION 'IMoniker members'}
function BindToObject(const bc: IBindCtx; const mkToLeft: IMoniker;
const iidResult: TIID; out vResult): HResult; stdcall;
function BindToStorage(const bc: IBindCtx; const mkToLeft: IMoniker;
const iid: TIID; out vObj): HResult; stdcall;
function Reduce(const bc: IBindCtx; dwReduceHowFar: Longint;
mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult; stdcall;
function ComposeWith(const mkRight: IMoniker; fOnlyIfNotGeneric: BOOL;
out mkComposite: IMoniker): HResult; stdcall;
function Enum(fForward: BOOL; out enumMoniker: IEnumMoniker): HResult;
stdcall;
function IsEqual(const mkOtherMoniker: IMoniker): HResult; stdcall;
function Hash(out dwHash: Longint): HResult; stdcall;
function IsRunning(const bc: IBindCtx; const mkToLeft: IMoniker;
const mkNewlyRunning: IMoniker): HResult; stdcall;
function GetTimeOfLastChange(const bc: IBindCtx; const mkToLeft: IMoniker;
out filetime: TFileTime): HResult; stdcall;
function Inverse(out mk: IMoniker): HResult; stdcall;
function CommonPrefixWith(const mkOther: IMoniker;
out mkPrefix: IMoniker): HResult; stdcall;
function RelativePathTo(const mkOther: IMoniker;
out mkRelPath: IMoniker): HResult; stdcall;
function GetDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
out pszDisplayName: POleStr): HResult; stdcall;
function ParseDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
pszDisplayName: POleStr; out chEaten: Longint;
out mkOut: IMoniker): HResult; stdcall;
function IsSystemMoniker(out dwMksys: Longint): HResult; stdcall;
{$ENDREGION}
 
{$REGION 'IPersistStream members'}
function IsDirty: HResult; stdcall;
function Load(const stm: IStream): HResult; stdcall;
function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
{$ENDREGION}
 
{$REGION 'IPersist members'}
function GetClassID(out classID: TCLSID): HResult; stdcall;
{$ENDREGION}
end;
 
 
// http://stackoverflow.com/questions/12605323/globalalloc-causes-my-delphi-app-hang
function StrToGlobalHandle(const aText: string): HGLOBAL;
var
ptr: PChar;
begin
Result := 0;
if aText <> '' then
begin
Result := GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT, (length(aText) + 1) * SizeOf(Char));
if Result <> 0 then
begin
ptr := GlobalLock(Result);
if Assigned(ptr) then
begin
StrCopy(ptr, PChar(aText));
GlobalUnlock(Result);
end
end;
end;
end;
 
procedure WaitForBrowser(AWebBrowser: TWebbrowser);
begin
while (AWebBrowser.ReadyState <> READYSTATE_COMPLETE) and
(not Assigned(Application) or not Application.Terminated) do
begin
if Assigned(Application) then Application.ProcessMessages;
Sleep(50);
end;
end;
 
function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
const AFakeURL: string=''): boolean;
var
bindctx: IBindCtx;
pPM: IPersistMoniker;
loader: TLoadHTMLMoniker;
url: string;
begin
if AFakeURL <> '' then
url := AFakeURL
else if AWebBrowser.LocationURL <> '' then
url := AWebBrowser.LocationURL
else
url := 'about:blank';
 
if AWebBrowser.Document = nil then
begin
AWebBrowser.Navigate('about:blank');
WaitForBrowser(AWebBrowser);
end;
 
pPM := AWebBrowser.Document as IPersistMoniker;
if (pPM = nil) then Exit(false);
 
bindctx := nil;
CreateBindCtx(0, bindctx);
if (bindctx = nil) then Exit(false);
 
try
loader := TLoadHTMLMoniker.Create;
loader.InitLoader(AHTML, url);
except
Exit(false);
end;
 
result := pPM.Load(true, loader, bindctx, STGM_READ) = S_OK;
 
if not result and Assigned(loader) then FreeAndNil(loader);
end;
 
{ TLoadHTMLMoniker }
 
// TLoadHTMLMoniker. Translated from C# to Delphi by Daniel Marschall
// Resources:
// - http://stackoverflow.com/questions/40927080/relative-urls-in-a-twebbrowser-containing-custom-html-code
// - https://github.com/kuza55/csexwb2/blob/master/General_Classes/LoadHTMLMoniker.cs
// - https://github.com/kuza55/csexwb2/blob/master/cEXWB.cs#L1769
 
procedure TLoadHTMLMoniker.InitLoader(sContent, sBaseUrl: string);
resourcestring
SCannotAllocMemory = 'Cannot create IStream.';
var
hr: integer;
begin
m_sBaseName := sBaseUrl;
hr := CreateStreamOnHGlobal(StrToGlobalHandle(sContent), true, m_stream);
if ((hr <> S_OK) or (m_stream = nil)) then raise Exception.Create(SCannotAllocMemory);
end;
 
function TLoadHTMLMoniker.GetDisplayName(const bc: IBindCtx;
const mkToLeft: IMoniker; out pszDisplayName: POleStr): HResult;
var
bufSize: integer;
wTest: WideString;
begin
// pszDisplayName := PWideChar(WideString(m_sBaseName));
 
// I am not sure if that is correct......
bufSize := (Length(m_sBaseName)+1) * SizeOf(WideChar);
pszDisplayName := CoTaskMemAlloc(bufSize);
wTest := m_sBaseName;
CopyMemory(pszDisplayName, PWideChar(wTest), bufSize);
 
result := S_OK;
end;
 
function TLoadHTMLMoniker.BindToStorage(const bc: IBindCtx;
const mkToLeft: IMoniker; const iid: TIID; out vObj): HResult;
const
IID_IStream: TGUID = '{0000000C-0000-0000-C000-000000000046}';
begin
if IsEqualIID(iid, IID_IStream) then
begin
IStream(vObj) := m_stream;
result := S_OK;
end
else
begin
IStream(vObj) := nil;
result := E_NOINTERFACE;
end;
end;
 
{$REGION 'Not implemented'}
function TLoadHTMLMoniker.BindToObject(const bc: IBindCtx;
const mkToLeft: IMoniker; const iidResult: TIID; out vResult): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.CommonPrefixWith(const mkOther: IMoniker;
out mkPrefix: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.ComposeWith(const mkRight: IMoniker;
fOnlyIfNotGeneric: BOOL; out mkComposite: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Enum(fForward: BOOL;
out enumMoniker: IEnumMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.GetClassID(out classID: TCLSID): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.GetSizeMax(out cbSize: Largeint): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.GetTimeOfLastChange(const bc: IBindCtx;
const mkToLeft: IMoniker; out filetime: TFileTime): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Hash(out dwHash: Integer): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Inverse(out mk: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.IsDirty: HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.IsEqual(const mkOtherMoniker: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.IsRunning(const bc: IBindCtx; const mkToLeft,
mkNewlyRunning: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.IsSystemMoniker(out dwMksys: Integer): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Load(const stm: IStream): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.ParseDisplayName(const bc: IBindCtx;
const mkToLeft: IMoniker; pszDisplayName: POleStr; out chEaten: Integer;
out mkOut: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Reduce(const bc: IBindCtx; dwReduceHowFar: Integer;
mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.RelativePathTo(const mkOther: IMoniker;
out mkRelPath: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
 
function TLoadHTMLMoniker.Save(const stm: IStream; fClearDirty: BOOL): HResult;
begin
result := E_NOTIMPL;
end;
{$ENDREGION}
 
{ TWebBrowserEx }
 
procedure TWebBrowserEx.Wait;
begin
WaitForBrowser(Self);
end;
 
function TWebBrowserEx.LoadHTML(const HTML: string; const AFakeURL: string=''): boolean;
begin
result := WebBrowserLoadHTML(Self, HTML, AFakeURL);
Self.Wait;
end;
 
procedure TWebBrowserEx.Clear;
begin
Self.LoadHTML('', 'about:blank');
end;
 
end.