Subversion Repositories fastphp

Rev

Rev 45 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  1. unit WebBrowserUtils;
  2.  
  3. {$Include 'FastPHP.inc'}
  4.  
  5. interface
  6.  
  7. uses
  8.   // TODO: "{$IFDEF USE_SHDOCVW_TLB}ShDocVw_TLB{$ELSE}ShDocVw{$ENDIF}" does not work with Delphi 10.2
  9.   Windows, ShDocVw, SysUtils, Forms;
  10.  
  11. procedure WaitForBrowser(AWebBrowser: TWebbrowser);
  12.  
  13. function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
  14.                             const AFakeURL: string=''): boolean;
  15.  
  16. type
  17.   TWebBrowserEx = class helper for TWebBrowser
  18.   public
  19.     procedure Clear;
  20.     procedure Wait;
  21.     function LoadHTML(const HTML: string; const AFakeURL: string=''): boolean;
  22.   end;
  23.  
  24. implementation
  25.  
  26. uses
  27.   ActiveX, urlmon;
  28.  
  29. type
  30.   (*
  31.   ILoadHTMLMoniker = interface(IMoniker)
  32.     ['{DCAE3F41-9B38-40EB-B7D0-4AF0FBFBE5AB}']
  33.     procedure InitLoader(sContent, sBaseUrl: string);
  34.   end;
  35.   *)
  36.   TLoadHTMLMoniker = class (TInterfacedObject, IMoniker{, ILoadHTMLMoniker})
  37.   private
  38.     m_stream: IStream;
  39.     m_sBaseName: string;
  40.   public
  41.     procedure InitLoader(sContent, sBaseUrl: string);
  42.     {$REGION 'IMoniker members'}
  43.     function BindToObject(const bc: IBindCtx; const mkToLeft: IMoniker;
  44.       const iidResult: TIID; out vResult): HResult; stdcall;
  45.     function BindToStorage(const bc: IBindCtx; const mkToLeft: IMoniker;
  46.       const iid: TIID; out vObj): HResult; stdcall;
  47.     function Reduce(const bc: IBindCtx; dwReduceHowFar: Longint;
  48.       mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult; stdcall;
  49.     function ComposeWith(const mkRight: IMoniker; fOnlyIfNotGeneric: BOOL;
  50.       out mkComposite: IMoniker): HResult; stdcall;
  51.     function Enum(fForward: BOOL; out enumMoniker: IEnumMoniker): HResult;
  52.       stdcall;
  53.     function IsEqual(const mkOtherMoniker: IMoniker): HResult; stdcall;
  54.     function Hash(out dwHash: Longint): HResult; stdcall;
  55.     function IsRunning(const bc: IBindCtx; const mkToLeft: IMoniker;
  56.       const mkNewlyRunning: IMoniker): HResult; stdcall;
  57.     function GetTimeOfLastChange(const bc: IBindCtx; const mkToLeft: IMoniker;
  58.       out filetime: TFileTime): HResult; stdcall;
  59.     function Inverse(out mk: IMoniker): HResult; stdcall;
  60.     function CommonPrefixWith(const mkOther: IMoniker;
  61.       out mkPrefix: IMoniker): HResult; stdcall;
  62.     function RelativePathTo(const mkOther: IMoniker;
  63.       out mkRelPath: IMoniker): HResult; stdcall;
  64.     function GetDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
  65.       out pszDisplayName: POleStr): HResult; stdcall;
  66.     function ParseDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
  67.       pszDisplayName: POleStr; out chEaten: Longint;
  68.       out mkOut: IMoniker): HResult; stdcall;
  69.     function IsSystemMoniker(out dwMksys: Longint): HResult; stdcall;
  70.     {$ENDREGION}
  71.  
  72.     {$REGION 'IPersistStream members'}
  73.     function IsDirty: HResult; stdcall;
  74.     function Load(const stm: IStream): HResult; stdcall;
  75.     function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
  76.     function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
  77.     {$ENDREGION}
  78.  
  79.     {$REGION 'IPersist members'}
  80.     function GetClassID(out classID: TCLSID): HResult; stdcall;
  81.     {$ENDREGION}
  82.   end;
  83.  
  84.  
  85. // http://stackoverflow.com/questions/12605323/globalalloc-causes-my-delphi-app-hang
  86. function StrToGlobalHandle(const aText: string): HGLOBAL;
  87. var
  88.   ptr: PChar;
  89. begin
  90.   Result := 0;
  91.   if aText <> '' then
  92.   begin
  93.     Result := GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT, (length(aText) + 1) * SizeOf(Char));
  94.     if Result <> 0 then
  95.     begin
  96.       ptr := GlobalLock(Result);
  97.       if Assigned(ptr) then
  98.       begin
  99.         StrCopy(ptr, PChar(aText));
  100.         GlobalUnlock(Result);
  101.       end
  102.     end;
  103.   end;
  104. end;
  105.  
  106. procedure WaitForBrowser(AWebBrowser: TWebbrowser);
  107. begin
  108.   while (AWebBrowser.ReadyState <> READYSTATE_COMPLETE) and
  109.         (not Assigned(Application) or not Application.Terminated) do
  110.   begin
  111.     if Assigned(Application) then Application.ProcessMessages;
  112.     Sleep(50);
  113.   end;
  114. end;
  115.  
  116. function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
  117.                             const AFakeURL: string=''): boolean;
  118. var
  119.   bindctx: IBindCtx;
  120.   pPM: IPersistMoniker;
  121.   loader: TLoadHTMLMoniker;
  122.   url: string;
  123. begin
  124.   if AFakeURL <> '' then
  125.     url := AFakeURL
  126.   else if AWebBrowser.LocationURL <> '' then
  127.     url := AWebBrowser.LocationURL
  128.   else
  129.     url := 'about:blank';
  130.  
  131.   if AWebBrowser.Document = nil then
  132.   begin
  133.     AWebBrowser.Navigate('about:blank');
  134.     WaitForBrowser(AWebBrowser);
  135.   end;
  136.  
  137.   pPM := AWebBrowser.Document as IPersistMoniker;
  138.   if (pPM = nil) then
  139.   begin
  140.     result := false;
  141.     exit;
  142.   end;
  143.  
  144.   bindctx := nil;
  145.   CreateBindCtx(0, bindctx);
  146.   if (bindctx = nil) then
  147.   begin
  148.     result := false;
  149.     exit;
  150.   end;
  151.  
  152.   try
  153.     // TODO: Delphi2007 and FastMM4 say that here we have a memory leak
  154.     loader := TLoadHTMLMoniker.Create;
  155.  
  156.     loader.InitLoader(AHTML, url);
  157.   except
  158.     if Assigned(loader) then FreeAndNil(loader);
  159.     result := false;
  160.     exit;
  161.   end;
  162.  
  163.   result := pPM.Load(true, loader, bindctx, STGM_READ) = S_OK;
  164.  
  165.   if not result and Assigned(loader) then FreeAndNil(loader);
  166. end;
  167.  
  168. { TLoadHTMLMoniker }
  169.  
  170. // TLoadHTMLMoniker. Translated from C# to Delphi by Daniel Marschall
  171. // Resources:
  172. // - http://stackoverflow.com/questions/40927080/relative-urls-in-a-twebbrowser-containing-custom-html-code
  173. // - https://github.com/kuza55/csexwb2/blob/master/General_Classes/LoadHTMLMoniker.cs
  174. // - https://github.com/kuza55/csexwb2/blob/master/cEXWB.cs#L1769
  175.  
  176. procedure TLoadHTMLMoniker.InitLoader(sContent, sBaseUrl: string);
  177. resourcestring
  178.   SCannotAllocMemory = 'Cannot create IStream.';
  179. var
  180.   hr: integer;
  181. begin
  182.   m_sBaseName := sBaseUrl;
  183.   hr := CreateStreamOnHGlobal(StrToGlobalHandle(sContent), true, m_stream);
  184.   if ((hr <> S_OK) or (m_stream = nil)) then raise Exception.Create(SCannotAllocMemory);
  185. end;
  186.  
  187. function TLoadHTMLMoniker.GetDisplayName(const bc: IBindCtx;
  188.   const mkToLeft: IMoniker; out pszDisplayName: POleStr): HResult;
  189. var
  190.   bufSize: integer;
  191.   wTest: WideString;
  192. begin
  193. //  pszDisplayName := PWideChar(WideString(m_sBaseName));
  194.  
  195.   // I am not sure if that is correct......
  196.   bufSize := (Length(m_sBaseName)+1) * SizeOf(WideChar);
  197.   pszDisplayName := CoTaskMemAlloc(bufSize);
  198.   wTest := m_sBaseName;
  199.   CopyMemory(pszDisplayName, PWideChar(wTest), bufSize);
  200.  
  201.   result := S_OK;
  202. end;
  203.  
  204. function TLoadHTMLMoniker.BindToStorage(const bc: IBindCtx;
  205.   const mkToLeft: IMoniker; const iid: TIID; out vObj): HResult;
  206. const
  207.   IID_IStream: TGUID = '{0000000C-0000-0000-C000-000000000046}';
  208. begin
  209.   if IsEqualIID(iid, IID_IStream) then
  210.   begin
  211.     IStream(vObj) := m_stream;
  212.     result := S_OK;
  213.   end
  214.   else
  215.   begin
  216.     IStream(vObj) := nil;
  217.     result := E_NOINTERFACE;
  218.   end;
  219. end;
  220.  
  221. {$REGION 'Not implemented'}
  222. function TLoadHTMLMoniker.BindToObject(const bc: IBindCtx;
  223.   const mkToLeft: IMoniker; const iidResult: TIID; out vResult): HResult;
  224. begin
  225.   result := E_NOTIMPL;
  226. end;
  227.  
  228. function TLoadHTMLMoniker.CommonPrefixWith(const mkOther: IMoniker;
  229.   out mkPrefix: IMoniker): HResult;
  230. begin
  231.   result := E_NOTIMPL;
  232. end;
  233.  
  234. function TLoadHTMLMoniker.ComposeWith(const mkRight: IMoniker;
  235.   fOnlyIfNotGeneric: BOOL; out mkComposite: IMoniker): HResult;
  236. begin
  237.   result := E_NOTIMPL;
  238. end;
  239.  
  240. function TLoadHTMLMoniker.Enum(fForward: BOOL;
  241.   out enumMoniker: IEnumMoniker): HResult;
  242. begin
  243.   result := E_NOTIMPL;
  244. end;
  245.  
  246. function TLoadHTMLMoniker.GetClassID(out classID: TCLSID): HResult;
  247. begin
  248.   result := E_NOTIMPL;
  249. end;
  250.  
  251. function TLoadHTMLMoniker.GetSizeMax(out cbSize: Largeint): HResult;
  252. begin
  253.   result := E_NOTIMPL;
  254. end;
  255.  
  256. function TLoadHTMLMoniker.GetTimeOfLastChange(const bc: IBindCtx;
  257.   const mkToLeft: IMoniker; out filetime: TFileTime): HResult;
  258. begin
  259.   result := E_NOTIMPL;
  260. end;
  261.  
  262. function TLoadHTMLMoniker.Hash(out dwHash: Integer): HResult;
  263. begin
  264.   result := E_NOTIMPL;
  265. end;
  266.  
  267. function TLoadHTMLMoniker.Inverse(out mk: IMoniker): HResult;
  268. begin
  269.   result := E_NOTIMPL;
  270. end;
  271.  
  272. function TLoadHTMLMoniker.IsDirty: HResult;
  273. begin
  274.   result := E_NOTIMPL;
  275. end;
  276.  
  277. function TLoadHTMLMoniker.IsEqual(const mkOtherMoniker: IMoniker): HResult;
  278. begin
  279.   result := E_NOTIMPL;
  280. end;
  281.  
  282. function TLoadHTMLMoniker.IsRunning(const bc: IBindCtx; const mkToLeft,
  283.   mkNewlyRunning: IMoniker): HResult;
  284. begin
  285.   result := E_NOTIMPL;
  286. end;
  287.  
  288. function TLoadHTMLMoniker.IsSystemMoniker(out dwMksys: Integer): HResult;
  289. begin
  290.   result := E_NOTIMPL;
  291. end;
  292.  
  293. function TLoadHTMLMoniker.Load(const stm: IStream): HResult;
  294. begin
  295.   result := E_NOTIMPL;
  296. end;
  297.  
  298. function TLoadHTMLMoniker.ParseDisplayName(const bc: IBindCtx;
  299.   const mkToLeft: IMoniker; pszDisplayName: POleStr; out chEaten: Integer;
  300.   out mkOut: IMoniker): HResult;
  301. begin
  302.   result := E_NOTIMPL;
  303. end;
  304.  
  305. function TLoadHTMLMoniker.Reduce(const bc: IBindCtx; dwReduceHowFar: Integer;
  306.   mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult;
  307. begin
  308.   result := E_NOTIMPL;
  309. end;
  310.  
  311. function TLoadHTMLMoniker.RelativePathTo(const mkOther: IMoniker;
  312.   out mkRelPath: IMoniker): HResult;
  313. begin
  314.   result := E_NOTIMPL;
  315. end;
  316.  
  317. function TLoadHTMLMoniker.Save(const stm: IStream; fClearDirty: BOOL): HResult;
  318. begin
  319.   result := E_NOTIMPL;
  320. end;
  321. {$ENDREGION}
  322.  
  323. { TWebBrowserEx }
  324.  
  325. procedure TWebBrowserEx.Wait;
  326. begin
  327.   WaitForBrowser(Self);
  328. end;
  329.  
  330. function TWebBrowserEx.LoadHTML(const HTML: string; const AFakeURL: string=''): boolean;
  331. begin
  332.   result := WebBrowserLoadHTML(Self, HTML, AFakeURL);
  333.   Self.Wait;
  334. end;
  335.  
  336. procedure TWebBrowserEx.Clear;
  337. begin
  338.   Self.LoadHTML('', 'about:blank');
  339. end;
  340.  
  341. end.
  342.