TEdgeBroWserのブックマークの実装について (ID:150653)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

ちょっと作り直し
---------------------------------------------------------------------------------------------
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.WebView2, Winapi.ActiveX,
  Vcl.Edge, Vcl.StdCtrls, Vcl.ComCtrls, System.NetEncoding,
  Vcl.OleCtrls, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL,
  IdSSLOpenSSL, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, Vcl.ToolWin, Vcl.ExtCtrls;

type
  TWEB_DATA = class
  public
    TITLE: String;
    URL: String;
    FAVICON: String;
  end;

TForm1 = class(TForm)
    EdgeBrowser1: TEdgeBrowser;
    IdHTTP1: TIdHTTP;
    IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
    Panel1: TPanel;
    Edit1: TEdit;
    Button2: TButton;
    Button1: TButton;
    StatusBar1: TStatusBar;
    ToolBar1: TToolBar;
    EdgeBrowser2: TEdgeBrowser;
    procedure EdgeBrowser1NewWindowRequested(Sender: TCustomEdgeBrowser;
      Args: TNewWindowRequestedEventArgs);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure EdgeBrowser1NavigationCompleted(Sender: TCustomEdgeBrowser;
      IsSuccess: Boolean; WebErrorStatus: TOleEnum);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure EdgeBrowser1ExecuteScript(Sender: TCustomEdgeBrowser;
      AResult: HRESULT; const AResultObjectAsJson: string);
    procedure EdgeBrowser2NavigationStarting(Sender: TCustomEdgeBrowser;
      Args: TNavigationStartingEventArgs);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    procedure ADD_favorite;
    procedure VIEW_favorite;
  end;

var
  Form1: TForm1;

WEB_TITLE: String;
  WEB_URL: String;
  WEB_FAVICON: String;
  WEB_ICON: String;
  IMG_DIR: String;
  TEMP_HTML: String;
   LIST: TList;

implementation

{$R *.dfm}

procedure TForm1.ADD_favorite;
var
    DATA: TWEB_DATA;
begin
    DATA := TWEB_DATA.Create;
    DATA.TITLE   := WEB_TITLE;
    DATA.URL     := WEB_URL;
    DATA.FAVICON := WEB_FAVICON;
    LIST.Add(DATA);
end;

procedure TForm1.VIEW_favorite;
var
    I: Integer;
    S: TStringList;

DATA: TWEB_DATA;
    S1,S2: String;
    ICON: TICON;
begin
    S1 := 'onMouseover="this.style.backgroundColor=''#AAAAAA''" onMouseOut="this.style.backgroundColor=''#FFFFFF''" ';

S := TStringList.Create;
    S.Add('<!DOCTYPE html>');
    S.Add('<html lang="ja">');
    S.Add('<head>');
    S.Add('<meta charset="SHIFT-JIS">');
    S.Add('<META http-equiv="Content-Script-Type" content="text/javascript">');
    S.Add('<script type="text/javascript">');
    S.Add('function visibility( $id )');
    S.Add('{');
    S.Add('  if ( document.getElementById( $id ).style.display == "none" )');
    S.Add('  {');
    S.Add('    document.getElementById( $id ).style.display="block";');
    S.Add('  }');
    S.Add('   else');
    S.Add('  {');
    S.Add('    document.getElementById( $id ).style.display="none";');
    S.Add('  }');
    S.Add('}');
    S.Add('</script>');
    S.Add('</head>');
    S.Add('');
    S.Add('<body>');

S.Add('<div style="cursor:pointer;" ' + S1 + ' onClick="visibility(''bookmark'')"><img style="width:24px; height:24px" src="' + IMG_DIR + 'directory.ico">ブックマーク</div>');
    //ブックマーク</h3>');

S.Add('<div id="bookmark">');
    S.Add('<table style="width:100%; border-spacing:0px;">');
    for I:=0 to LIST.Count -1 do
    begin
      DATA := LIST[I];
      S2 := '<img style="width:24px; height:24px;" src="' + DATA.FAVICON + '">';
      S.Add('<tr ' + S1 + '><td style="width:32px;"></td><td style="width:32px">' + S2 + '</td><td ' + S1 + '><a href="' + DATA.URL + ' ">' + DATA.TITLE + '</a></td><tr>');
      ICON.Free;
    end;

S.Add('</table>');
    S.Add('</div>');
    S.Add('</body>');
    S.Add('</html>');

//EdgeBrowser1.NavigateToString(S.TEXT);
    S.SaveToFile(TEMP_HTML);
    EdgeBrowser2.Navigate(TEMP_HTML);

S.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    EdgeBrowser1.Navigate(Edit1.Text);
end;

//お気に入り登録

procedure TForm1.Button2Click(Sender: TObject);
begin
    //EdgeBrowser1ExecuteScript 処理終了前に登録すると前のデータで登録される
    ADD_favorite;
    VIEW_favorite;
end;

procedure TForm1.EdgeBrowser1ExecuteScript(Sender: TCustomEdgeBrowser;
  AResult: HRESULT; const AResultObjectAsJson: string);
var
    I,I1,I2: Integer;
    S: String;
    B: Boolean;
    S1,S2: String;
    REL,HREF: String;
begin
   if AResultObjectAsJson <> 'null' then
   begin
     S := TNetEncoding.URL.Decode(AResultObjectAsJson).DeQuotedString('"');

//HEAD取得
     I := Pos('<head>',S);
     S := Copy(S,I);
     I := Pos('</head>',S);
     S := Copy(S,1,I+6);

//<link 取得
     B := True;
     while B = True do
     begin
       I := Pos('<link',S);
       if I <> 0 then
       begin
         S  := Copy(S,I);
         I  := Pos('>',S);
         S1 := Copy(S,1,I);

I1 := Pos('rel=',S1);
         if I1 <> 0 then
         begin
           S1 := Copy(S1,I1+4); //rel=以降
           if S1[1] = '"' then
           begin
             S1  := Copy(S1,2);
             I2  := Pos('"',S1);
             REL := Copy(S1,I2-1);
           end
           else
           begin
             I2 := Pos(' ',S1);
             REL := Copy(S1,1,I2-1);
           end;

I1 := Pos('href=',S1);
           if I1 <> 0 then
           begin
             S1 := Copy(S1,I1+5);      //<href=以降

if S1[1] = '"' then
             begin
               S1 := Copy(S1,2);
               I2 := Pos('"',S1);
               S2 := Copy(S1,I2-1);
             end
             else
             begin
               HREF := '';
               I2 := Pos(' ',S1);
               if I2 <> 0 then HREF := Copy(S1,1,I2-1);
               if HREF = '' then
               begin
                 I2 := Pos('>',S1);
                 if I2 <> 0 then HREF := Copy(S1,1,I2-1);
               end;

if (REL = 'icon') or (REL = 'shortcut icon') then
               begin
                 WEB_FAVICON := HREF;
               end;

end;
           end
           else
           begin
             //href が存在しない
           end;
         end
         else
         begin
           //rel=が存在しない
         end;

S := Copy(S,I);
       end
       else
       begin
         B := False;
       end;
     end;

end;
end;

procedure TForm1.EdgeBrowser1NavigationCompleted(Sender: TCustomEdgeBrowser;
  IsSuccess: Boolean; WebErrorStatus: TOleEnum);
var
    P: PWideChar;
    MemoryStream: TMemoryStream;
begin
    WEB_URL   := TEdgeBrowser(SEnder).LocationURL;
    WEB_TITLE := TEdgeBrowser(SEnder).DocumentTitle;

//ICON 取得
    MemoryStream := TMemoryStream.Create;
    try
      IdHTTP1.Get(WEB_URL + '/favicon.ico',MemoryStream);
      if MemoryStream.Position <> 0 then
      begin
        WEB_FAVICON := WEB_URL + 'favicon.ico';
      end;
      EdgeBrowser1.ExecuteScript('encodeURI(document.documentElement.innerHTML)');
    except
    end;
    MemoryStream.Free;
end;

procedure TForm1.EdgeBrowser2NavigationStarting(Sender: TCustomEdgeBrowser;
  Args: TNavigationStartingEventArgs);
var
    OLDURL: String;
    NEWURL: PWideChar;
begin
    Args.ArgsInterface.Get_uri(NEWURL);
    OLDURL := TEdgeBrowser(SEnder).LocationURL;
    if OLDURL <> '' then
    begin
      if Copy(StrPas(NEWURL),1,5) <> 'file:' then
      begin
        Args.ArgsInterface.Set_Cancel(1);
        EdgeBrowser1.Navigate(NEWURL);
      end;
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    //EdgeBrowser1  通常
    //EdgeBrowser2  お気に入り

EdgeBrowser1.UserDataFolder := ExtractFileDir(Application.ExeName);
    EdgeBrowser2.UserDataFolder := ExtractFileDir(Application.ExeName);

IMG_DIR   := ExtractFilePath(ParamStr(0)) + 'IMG\';　　　　//IMG_DIRに directory.ico を作成しておく
    TEMP_HTML := ExtractFilePath(ParamStr(0)) + 'TEMP.HTML';

EdgeBrowser1.CreateWebView;
    EdgeBrowser2.CreateWebView;

LIST := TLIST.Create;

try
      MkDir (IMG_DIR);
    except
    end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    LIST.Free;
    Exit;
end;

//------------------------------------------------------------------------------

←解決時は質問者本人がここをチェックしてください。

戻る