お世話になります。
TEdgeブラウザでお気に入り登録（ブックマーク）を実装したいと思っています。
現状では、単純にComboBoxにURLのみを登録する形にしています。
起動時にURLテキストを読み込んで、終了時に書込みしています。
ページtitle（は抽出出来ています）とセットで登録したいと思っています。
GoogleChromeのブックマークのようなものは実装は可能なのでしょうか？
以上、よろしくお願いいたします。
可能です。
表示されたurlを保存するだけですので、それほど難しいことではありません。
コードエディタの補完ウィンドウで、tedgebrowserのプロパティやメソッドを表示させて、titleやurlといった単語を入力すると、それらしいプロパティが見つかるでしょう。
それを保存するだけです。
あ さん
貴重なアドバイスありがとうございます。
EdgeBrowser1.DocumentTitle でTitleが取得出来ることを知らずに、
HTML分からTitle部分を自前で抽出していました。
Option := [roIgnoreCase, roSingleLine];//改行対策、複数行も検索
s := IdHTTP1.Get(ComboBox2.text); //アドレスからHTMLを取得
mm := TRegex.Match(s, '<title>(.*)</title>',Option); //title部分を抽出
Titleの取得はEdgeBrowser1.DocumentTitleを利用させていただきます。
URLは既にEdgeBrowser1.LocationURで利用をしていました。
ちょっと表現が足りなかったのですが、title とURL をComboBoxに記録させる方法については
出来ていますが、GoogleChromeのブックマークのようなブックマークを階層で記録し、
編集もしたいと思っています。私にはハードルが高いかもしれないのですが、
もし、ご存知でしたらご教授くださればありがたく存じます。
EdgeBrowser はお気に入り用に別に用意する
TWEB_DATA = class
public
TITLE: String;
URL: String;
ICON: String;
end;
//お気に入り表示
procedure TForm1.Button7Click(Sender: TObject);
var
I: Integer;
S: TStringList;
LIST: TList;
DATA: TWEB_DATA;
S1,S2: String;
ICON: TICON;
SS: String;
begin
SS := ExtractFilePath(ParamStr(0)) + 'IMG\';
LIST := TLIST.Create;
//仮データ
DATA := TWEB_DATA.Create;
DATA.TITLE := 'Yahoo! JAPAN';
DATA.URL := 'https://www.yahoo.co.jp';
DATA.ICON := 'Yahoo! JAPAN.ico';
LIST.Add(DATA);
DATA := TWEB_DATA.Create;
DATA.TITLE := 'YouTube';
DATA.URL := 'https://www.youtube.com/';
DATA.ICON := 'YouTube.ico';
LIST.Add(DATA);
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="' + SS + '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];
ICON := TICON.Create;
S2 := '';
if FileExists('IMG\' + DATA.ICON) = True then
begin
S2 := '<img style="width:24px; height:24px;" src="' + SS + DATA.ICON + '">'
end
else
begin
S2 := '■';
end;
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>');
for I:=0 to List.Count -1 do
begin
DATA := LIST[I];
DATA.Free;
end;
//EdgeBrowser1.NavigateToString(S.TEXT); //こっちだとイメージがブロックされる
S.SaveToFile(FAV);
EdgeBrowser2.Navigate(FAV);
LIST.Free;
S.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 NEWURL <> '' then
begin
Args.ArgsInterface.Set_Cancel(1);
EdgeBrowser1.Navigate(NEWURL);
end;
end;
end;
//アイコン取得
procedure TForm1.EdgeBrowser1NavigationCompleted(Sender: TCustomEdgeBrowser;
IsSuccess: Boolean; WebErrorStatus: TOleEnum);
var
P: PWideChar;
MemoryStream: TMemoryStream;
ICON: TICON;
TITLE: String;
SS: String;
begin
//WEB_URL := TEdgeBrowser(SEnder).LocationURL;
TITLE := TEdgeBrowser(SEnder).DocumentTitle;
SS := ExtractFilePath(ParamStr(0)) + 'IMG\';
//ICON 取得 (
//<link rel=icon type=image/x-icon で設定されてい場合ソース解読かな？
MemoryStream := TMemoryStream.Create;
try
IdHTTP1.Get(WEB_URL + '/favicon.ico',MemoryStream);
if MemoryStream.Position <> 0 then
begin
ICON := TICON.Create;
MemoryStream.Position := 0;
ICON.LoadFromStream(MemoryStream);
ICON.SaveToFile(SS + TITLE + '.ico');
ICON.Free;
end;
except
end;
MemoryStream.Free;
end;
ちょっと作り直し
---------------------------------------------------------------------------------------------
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;
//------------------------------------------------------------------------------
AAAAAさん
素晴らしいコードありがとうございます。
Javascriptを活用して作成するのですね。
一部エラー等が出たので変えました。
WinApi.WebView2 →WebView2
FV →TEMP_HTML
EdgeBrowser1で表示されたものをButton2をクリックするとブックマークが表示されました。
Button3を押すと事前に登録していたYahoo,Youtube のブックマークが表示されました。
ただ、以下のような症状があります。
①EdgeBrowse1はComboBoxに最初に入力したアドレスを入れた以降、別のURLを
入れても、画面遷移は全くしません。原因は全く不明です。
②アイコンの取得が出来ていないようです。
③プログラムがフリーズしてしまいます。
ーーーーーーー
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 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;
ICON: 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;
Button3: TButton;
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);
procedure Button3Click(Sender: TObject);
procedure EdgeBrowser1NavigationStarting(Sender: TCustomEdgeBrowser;
Args: TNavigationStartingEventArgs);
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.Button3Click(Sender: TObject);
var
I: Integer;
S: TStringList;
LIST: TList;
DATA: TWEB_DATA;
S1,S2: String;
ICON: TICON;
SS: String;
begin
SS := ExtractFilePath(ParamStr(0)) + 'IMG\';
LIST := TLIST.Create;
//仮データ
DATA := TWEB_DATA.Create;
DATA.TITLE := 'Yahoo! JAPAN';
DATA.URL := 'https://www.yahoo.co.jp';
DATA.ICON := 'Yahoo! JAPAN.ico';
LIST.Add(DATA);
DATA := TWEB_DATA.Create;
DATA.TITLE := 'YouTube';
DATA.URL := 'https://www.youtube.com/';
DATA.ICON := 'YouTube.ico';
LIST.Add(DATA);
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="' + SS + '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];
ICON := TICON.Create;
S2 := '';
if FileExists('IMG\' + DATA.ICON) = True then
begin
S2 := '<img style="width:24px; height:24px;" src="' + SS + DATA.ICON + '">'
end
else
begin
S2 := '■';
end;
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>');
for I:=0 to List.Count -1 do
begin
DATA := LIST[I];
DATA.Free;
end;
//EdgeBrowser1.NavigateToString(S.TEXT); //こっちだとイメージがブロックされる
// S.SaveToFile(FAV);
// EdgeBrowser2.Navigate(FAV);
S.SaveToFile(TEMP_HTML);
EdgeBrowser2.Navigate(TEMP_HTML);
LIST.Free;
S.Free;
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.EdgeBrowser1NavigationStarting(Sender: TCustomEdgeBrowser;
Args: TNavigationStartingEventArgs);
var
OLDURL: String;
NEWURL: PWideChar;
begin
Args.ArgsInterface.Get_uri(NEWURL);
OLDURL := TEdgeBrowser(SEnder).LocationURL;
if OLDURL <> '' then
begin
if NEWURL <> '' then
begin
Args.ArgsInterface.Set_Cancel(1);
EdgeBrowser1.Navigate(NEWURL);
end;
end;
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;
end.
作り直したやつに 作り直す前の 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.
AAAAA様
度々ありがとうございます。
再度、上記コードで再構築しました。
初回起動時：エラーもなくコンパイルができ、ブックマークの登録もできました。
２回目の起動：でFavorite.Buttonを押すと、「アドレスFEC3F7F1でアドレスFEC3F7F1の読み取り違反がおきました」と出ました。
Edge１の方で画面遷移は出来ますが、ページによって画面の読込完了してもFavaritte.Buttonボタンはグレー表記（FavoriteButton1.Enabled := False;）のまま。
FavoriteButton1.Enabled := True;となるページを見つけてFavorite.Buttonを押すと、今度は「読み取り違反が置きました」と出ます。
その後、再度、コンパイルをするがコンパイルはそのままエラーも出ず完了しますが、
今度はフォームが表示されなくなるという不思議な症状が出ています。試しに別のプロジェクトを起動し、コンパイルすると正常に表示されます。
Ctrl+Alt+DELでタスクマネージャーを起動してみますが、このアプリの起動はされていない状況です。
上記の内容は、無視してください。(^_^;)
プログラムで使用する関連ファイル等を開いたままにしていたことが原因でした。
改めて、EXEの削除,iniファイル、Favorite.html等を削除して
再度コンパイルは出来るようにはなりましたが、引き続き以下の症状が出ます。
初回起動ページから遷移する際に、モジュール FvBmark.exeのアドレス 006D09F9 でアドレス0000000に対する読み取り違反がおきました。
その後、ページ遷移が出来なくなります。
２回目のコンパイル起動、新しいURLをブックマーク登録しようとすると「無効なポインタ操作」と出て、Favaritte.ButtonはHideとなり
ボタンが表示されなくなりました。
３回目のコンパイル起動、２回目と同じです。
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;
EdgeBrowser1.ExecuteScript('encodeURI(document.documentElement.innerHTML)');
を try - except の外へ
AAAAAさん
ありがとうございます。
コードを更新してコンパイルは完了していますが、フォームが表示されないという不思議な症状が出ています。
これ以上の追求は私のレベルでは難しいので、
別途簡易的なブックマークで完成させようと思います。
一旦、解決とさせていただきます。
AAAAAさん、重ねてのアドバイスありがとうございました。
右側に出るブックマークブラウザー表示にしたけど
Google Chromeは
右側に出るブックマークはWinコントロールで作ってる（作るなら ListBox かな)
こっちのポップアップは Window からはみ出す
chrome://bookmarks/ で出るブックマークは ブラウザーで表示してる
こっちのポップアップは ポップアップ上で右クリックすると webページ上で表示されるポップアップが表示される