Subversion Repositories fastphp

Rev

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