Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/fastphp/trunk/WebBrowserUtils.pas
Revision: 61
Committed: Tue Feb 25 20:39:22 2020 UTC (4 weeks, 6 days ago) by daniel-marschall
Content type: text/x-pascal
File size: 12283 byte(s)
Log Message:
FastPHP Browser: Meta tags can now be used to change the window title, width and height

File Contents

# Content
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.