Subversion Repositories fastphp

Rev

Rev 56 | Show entire file | Regard whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 56 Rev 61
Line 4... Line 4...
4 
 
 4 
 
5 
interface
 5 
interface
6 
 
 6 
 
7 
uses
 7 
uses
8 
  // TODO: "{$IFDEF USE_SHDOCVW_TLB}ShDocVw_TLB{$ELSE}ShDocVw{$ENDIF}" does not work with Delphi 10.2
 8 
  // TODO: "{$IFDEF USE_SHDOCVW_TLB}ShDocVw_TLB{$ELSE}ShDocVw{$ENDIF}" does not work with Delphi 10.2
9 
  Windows, ShDocVw, SysUtils, Forms;
 9 
  Windows, ShDocVw, SysUtils, Forms, Classes;
10 
 
 10 
 
11 
procedure WaitForBrowser(AWebBrowser: TWebbrowser);
 11 
procedure WaitForBrowser(AWebBrowser: TWebbrowser);
12 
 
 12 
 
13 
function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
 13 
function WebBrowserLoadHTML(AWebBrowser: TWebBrowser; const AHTML: string;
14 
                            const AFakeURL: string=''): boolean;
 14 
                            const AFakeURL: string=''): boolean;
- 
 
 15 
function WebBrowserLoadStream(AWebBrowser: TWebBrowser; const AStream: TStream;
- 
 
 16 
                            const AFakeURL: string=''): boolean;
15 
 
 17 
 
16 
type
 18 
type
17 
  TWebBrowserEx = class helper for TWebBrowser
 19 
  TWebBrowserEx = class helper for TWebBrowser
18 
  public
 20 
  public
19 
    procedure Clear;
 21 
    procedure Clear;
20 
    procedure Wait;
 22 
    procedure Wait;
21 
    function LoadHTML(const HTML: string; const AFakeURL: string=''): boolean;
 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);
22 
  end;
 26 
  end;
23 
 
 27 
 
24 
implementation
 28 
implementation
25 
 
 29 
 
26 
uses
 30 
uses
Line 37... Line 41...
37 
  private
 41 
  private
38 
    m_stream: IStream;
 42 
    m_stream: IStream;
39 
    m_sBaseName: string;
 43 
    m_sBaseName: string;
40 
  public
 44 
  public
41 
    procedure InitLoader(sContent, sBaseUrl: string);
 45 
    procedure InitLoader(sContent, sBaseUrl: string);
- 
 
 46 
    procedure InitLoaderStream(sStream: TStream; sBaseUrl: string);
42 
    {$REGION 'IMoniker members'}
 47 
    {$REGION 'IMoniker members'}
43 
    function BindToObject(const bc: IBindCtx; const mkToLeft: IMoniker;
 48 
    function BindToObject(const bc: IBindCtx; const mkToLeft: IMoniker;
44 
      const iidResult: TIID; out vResult): HResult; stdcall;
 49 
      const iidResult: TIID; out vResult): HResult; stdcall;
45 
    function BindToStorage(const bc: IBindCtx; const mkToLeft: IMoniker;
 50 
    function BindToStorage(const bc: IBindCtx; const mkToLeft: IMoniker;
46 
      const iid: TIID; out vObj): HResult; stdcall;
 51 
      const iid: TIID; out vObj): HResult; stdcall;
Line 150... Line 155...
150 
  end;
 155 
  end;
151 
 
 156 
 
152 
  try
 157 
  try
153 
    // TODO: Delphi2007 and FastMM4 say that here we have a memory leak
 158 
    // TODO: Delphi2007 and FastMM4 say that here we have a memory leak
154 
    loader := TLoadHTMLMoniker.Create;
 159 
    loader := TLoadHTMLMoniker.Create;
155 
 
 - 
 
156 
    loader.InitLoader(AHTML, url);
 160 
    loader.InitLoader(AHTML, url);
157 
  except
 161 
  except
158 
    if Assigned(loader) then FreeAndNil(loader);
 162 
    if Assigned(loader) then FreeAndNil(loader);
159 
    result := false;
 163 
    result := false;
160 
    exit;
 164 
    exit;
Line 163... Line 167...
163 
  result := pPM.Load(true, loader, bindctx, STGM_READ) = S_OK;
 167 
  result := pPM.Load(true, loader, bindctx, STGM_READ) = S_OK;
164 
 
 168 
 
165 
  if not result and Assigned(loader) then FreeAndNil(loader);
 169 
  if not result and Assigned(loader) then FreeAndNil(loader);
166 
end;
 170 
end;
167 
 
 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 
 
168 
{ TLoadHTMLMoniker }
 223 
{ TLoadHTMLMoniker }
169 
 
 224 
 
170 
// TLoadHTMLMoniker. Translated from C# to Delphi by Daniel Marschall
 225 
// TLoadHTMLMoniker. Translated from C# to Delphi by Daniel Marschall
171 
// Resources:
 226 
// Resources:
172 
// - http://stackoverflow.com/questions/40927080/relative-urls-in-a-twebbrowser-containing-custom-html-code
 227 
// - http://stackoverflow.com/questions/40927080/relative-urls-in-a-twebbrowser-containing-custom-html-code
Line 182... Line 237...
182 
  m_sBaseName := sBaseUrl;
 237 
  m_sBaseName := sBaseUrl;
183 
  hr := CreateStreamOnHGlobal(StrToGlobalHandle(sContent), true, m_stream);
 238 
  hr := CreateStreamOnHGlobal(StrToGlobalHandle(sContent), true, m_stream);
184 
  if ((hr <> S_OK) or (m_stream = nil)) then raise Exception.Create(SCannotAllocMemory);
 239 
  if ((hr <> S_OK) or (m_stream = nil)) then raise Exception.Create(SCannotAllocMemory);
185 
end;
 240 
end;
186 
 
 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 
 
187 
function TLoadHTMLMoniker.GetDisplayName(const bc: IBindCtx;
 251 
function TLoadHTMLMoniker.GetDisplayName(const bc: IBindCtx;
188 
  const mkToLeft: IMoniker; out pszDisplayName: POleStr): HResult;
 252 
  const mkToLeft: IMoniker; out pszDisplayName: POleStr): HResult;
189 
var
 253 
var
190 
  bufSize: integer;
 254 
  bufSize: integer;
191 
  wTest: WideString;
 255 
  wTest: WideString;
Line 331... Line 395...
331 
begin
 395 
begin
332 
  result := WebBrowserLoadHTML(Self, HTML, AFakeURL);
 396 
  result := WebBrowserLoadHTML(Self, HTML, AFakeURL);
333 
  Self.Wait;
 397 
  Self.Wait;
334 
end;
 398 
end;
335 
 
 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 
 
336 
procedure TWebBrowserEx.Clear;
 425 
procedure TWebBrowserEx.Clear;
337 
begin
 426 
begin
338 
  Self.LoadHTML('', 'about:blank');
 427 
  Self.LoadHTML('', 'about:blank');
339 
end;
 428 
end;
340 
 
 429