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

名前

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

本文

作り直したやつに 作り直す前の Button3 追加しちゃうと Button3 で　LIst.Free しているから おかしくなる

さらに作り直したやつ
----------------
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)
    ComboBox1: TComboBox;
    FavoriteButton1: TButton;
    GoBackButton1: TButton;
    UpdateButton1: TButton;
    Panel1: TPanel;
    EdgeBrowser1: TEdgeBrowser;
    EdgeBrowser2: TEdgeBrowser;
    StatusBar1: TStatusBar;
    IdHTTP1: TIdHTTP;
    IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
    procedure FavoriteButton1Click(Sender: TObject);
     procedure ComboBox1KeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure EdgeBrowser1NavigationStarting(Sender: TCustomEdgeBrowser;
      Args: TNavigationStartingEventArgs);
    procedure EdgeBrowser1NavigationCompleted(Sender: TCustomEdgeBrowser;
      IsSuccess: Boolean; WebErrorStatus: TOleEnum);
    procedure EdgeBrowser1ExecuteScript(Sender: TCustomEdgeBrowser;
      AResult: HRESULT; const AResultObjectAsJson: string);
    procedure EdgeBrowser2NavigationStarting(Sender: TCustomEdgeBrowser;
      Args: TNavigationStartingEventArgs);
    procedure ComboBox1Select(Sender: TObject);
    procedure ComboBox1CloseUp(Sender: TObject);
    procedure EdgeBrowser1DocumentTitleChanged(Sender: TCustomEdgeBrowser;
      const ADocumentTitle: string);
    procedure EdgeBrowser1SourceChanged(Sender: TCustomEdgeBrowser;
      IsNewDocument: Boolean);
    procedure GoBackButton1Click(Sender: TObject);
    procedure UpdateButton1Click(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;
  CloseUp: Boolean;

implementation

{$R *.dfm}

procedure TForm1.ADD_favorite;
var
    DATA: TWEB_DATA;
    I,J: Integer;
begin

if (WEB_TITLE <> '') and (WEB_URL <> '') then
    begin
      J := -1;
      for I:=0 to LIST.Count -1 do
      begin
        DATA := LIST[I];
        if DATA.URL = WEB_URL then
        begin
          J := I;
        end;
      end;

if J = -1 then
      begin
        DATA := TWEB_DATA.Create;
        DATA.TITLE   := WEB_TITLE;
        DATA.URL     := WEB_URL;
        DATA.FAVICON := WEB_FAVICON;
        LIST.Add(DATA);
      end
      else
      begin
        DATA := LIST[J];
        DATA.TITLE   := WEB_TITLE;
        DATA.FAVICON := WEB_FAVICON;
      end;

end;
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.GoBackButton1Click(Sender: TObject);
begin
    EdgeBrowser1.GoBack;
end;

//更新
procedure TForm1.UpdateButton1Click(Sender: TObject);
begin
    EdgeBrowser1.Navigate(EdgeBrowser1.LocationURL);
end;

//お気に入り登録
procedure TForm1.FavoriteButton1Click(Sender: TObject);
begin
    ADD_favorite;
    VIEW_favorite;
end;

procedure TForm1.ComboBox1KeyPress(Sender: TObject; var Key: Char);
var
    I: Integer;
begin
    if Key = Char(13) then
    begin
      I := ComboBox1.Items.IndexOf(ComboBox1.Text);
      if I = -1 then ComboBox1.Items.Add(ComboBox1.Text);
      EdgeBrowser1.Navigate(ComboBox1.Text);
    end;
end;

procedure TForm1.ComboBox1CloseUp(Sender: TObject);
begin
    CloseUp := True;
end;

procedure TForm1.ComboBox1Select(Sender: TObject);
begin
    if CloseUp = True then EdgeBrowser1.Navigate(ComboBox1.Text);
    CloseUp := False;
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;
   FavoriteButton1.Enabled := True;
end;

procedure TForm1.EdgeBrowser1DocumentTitleChanged(Sender: TCustomEdgeBrowser;
  const ADocumentTitle: string);
begin
    WEB_TITLE := TEdgeBrowser(SEnder).DocumentTitle;
    Caption := WEB_TITLE;
end;

procedure TForm1.EdgeBrowser1SourceChanged(Sender: TCustomEdgeBrowser;
  IsNewDocument: Boolean);
begin
    WEB_URL   := TEdgeBrowser(SEnder).LocationURL;
end;

procedure TForm1.EdgeBrowser1NavigationStarting(Sender: TCustomEdgeBrowser;
  Args: TNavigationStartingEventArgs);
var
    P:PWideChar;
begin
    WEB_TITLE := TEdgeBrowser(SEnder).DocumentTitle;
    FavoriteButton1.Enabled := False;
    Args.ArgsInterface.Get_uri(P);
    WEB_URL := StrPas(P);
    ComboBox1.Text := WEB_URL;
end;

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

//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);
var
    Buffer: array[0..255] of Char;
    I,J: Integer;
    INI: String;
    DATA: TWEB_DATA;
begin

//EdgeBrowser1  通常
    //EdgeBrowser2  お気に入り
    IMG_DIR   := ExtractFilePath(ParamStr(0)) + 'IMG\';　　　　//IMG_DIRに directory.ico を作成しておく
    TEMP_HTML := ExtractFilePath(ParamStr(0)) + 'favorite.html';

IdHTTP1.IOHandler := IdSSLIOHandlerSocketOpenSSL1;
    IdSSLIOHandlerSocketOpenSSL1.SSLOptions.Method := sslvSSLv23;
    IdSSLIOHandlerSocketOpenSSL1.SSLOptions.SSLVersions := [sslvSSLv2,sslvSSLv3,sslvTLSv1,sslvTLSv1_1,sslvTLSv1_2];
    EdgeBrowser1.OnExecuteScript       := EdgeBrowser1ExecuteScript;
    EdgeBrowser1.OnNavigationStarting  := EdgeBrowser1NavigationStarting;
    EdgeBrowser1.OnNavigationCompleted := EdgeBrowser1NavigationCompleted;
    EdgeBrowser2.OnNavigationStarting  := EdgeBrowser2NavigationStarting;
    ComboBox1.OnKeyPress               := ComboBox1KeyPress;

EdgeBrowser2.Align := alRight;
    EdgeBrowser2.Width := 300;
    EdgeBrowser1.Align := alClient;

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

EdgeBrowser1.CreateWebView;
    EdgeBrowser2.CreateWebView;

try
      MkDir (IMG_DIR);
    except
    end;

INI := ChangeFileExt(ParamStr(0),'.ini');
    LIST := TLIST.Create;
    J := GetPrivateProFileInt('SYS','COUNT',0,PWideChar(INI));
    for I:=0 to J-1 do
    begin
      DATA := TWEB_DATA.Create;
      GetPrivateProFileString(PWideChar(IntToStr(I)),'TITLE'  ,'',Buffer,SizeOf(Buffer),PWideChar(INI));
      DATA.TITLE   := StrPas(Buffer);
      GetPrivateProFileString(PWideChar(IntToStr(I)),'URL'    ,'',Buffer,SizeOf(Buffer),PWideChar(INI));
      DATA.URL     := StrPas(Buffer);
      GetPrivateProFileString(PWideChar(IntToStr(I)),'FAVICON','',Buffer,SizeOf(Buffer),PWideChar(INI));
      DATA.FAVICON := StrPas(Buffer);
      LIST.Add(DATA);
    end;

INI := ChangeFileExt(ParamStr(0),'.txt');
    if FileExists(INI) = True then ComboBox1.Items.LoadFromFile(INI);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
    I: Integer;
    DATA: TWEB_DATA;
    INI: String;
begin
    INI := ChangeFileExt(ParamStr(0),'.ini');

WritePrivateProFileString('SYS','COUNT',PWideChar(IntToStr(LIST.Count)),PWideChar(INI));
    for I:=0 to LIST.Count -1 do
    begin
      DATA := LIST[I];
      WritePrivateProFileString(PWideChar(IntToStr(I)),'TITLE'  ,PWideChar(DATA.TITLE)  ,PWideChar(INI));
      WritePrivateProFileString(PWideChar(IntToStr(I)),'URL'    ,PWideChar(DATA.URL)    ,PWideChar(INI));
      WritePrivateProFileString(PWideChar(IntToStr(I)),'FAVICON',PWideChar(DATA.FAVICON),PWideChar(INI));
      DATA.Free;
    end;
    LIST.Free;

INI := ChangeFileExt(ParamStr(0),'.txt');
    ComboBox1.Items.SaveToFile(INI);
    Exit;
end;

end.

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

戻る