Subversion Repositories fastphp

Rev

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