unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, SHDocVw_EWB, EwbCore, EmbeddedWB;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Edit1: TEdit;
    EmbeddedWB1: TEmbeddedWB;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  IOUtils, CDO_TLB, ADODB_TLB;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  テスト用のウェブページを表示(開く)
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  AURL : String;
begin
  AURL := 'http://mrxray.on.coocan.jp/Delphi/plSamples/942_TEmbeddedWB.htm';
  EmbeddedWB1.Navigate(AURL);
end;

//-----------------------------------------------------------------------------
//  ウェブページを.MHT形式のファイルで保存するルーチン
//  url      : 保存するウェブページのアドレス
//  fileName : 保存ファイル名。フルパス
//  全てのウェブページが完全に保存できる保証はない
//
//  usesにCDO_TLB, ADODB_TLBが必要
//-----------------------------------------------------------------------------
procedure SaveURLasMHT(const url: String; const fileName: String);
var
  Limsg   : IMessage;
  Liconf  : IConfiguration;
  LStream : ADODB_TLB._Stream;
begin
  Limsg  := CoMessage.Create;
  Liconf := CoConfiguration.Create;

  try
    Limsg.Configuration := Liconf;
    Limsg.CreateMHTMLBody(url, cdoSuppressNone, '', '');
    LStream := Limsg.GetStream;
    LStream.SaveToFile(fileName, adSaveCreateOverWrite);
  finally
    Limsg   := nil;
    Liconf  := nil;
    LStream := nil;
  end;
end;

//=============================================================================
//  ウェブページをMHT形式のファイルで保存
//  TPathの使用にはusesにIOUtilsが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSavePath : String;
  LFileExt  : String;
begin
  //保存ファイル名の生成
  LSavePath := TPath.GetFileName(EmbeddedWB1.LocationURL);
  LSavePath := ExtractFilePath(Application.ExeName) + LSavePath;

  //拡張子が.htm,htmlでない場合は保存ファイル名を固定にする
  //ページのタイトルだとファイル名に使用不可の文字がある場合がある
  //このあたりは工夫が必要
  //保存ダイアログで保存ファイル名を設定した方がいいかも知れない
  LFileExt  := ExtractFileExt(LSavePath);
  if (UpperCase(LFileExt) <> '.HTM') and (UpperCase(LFileExt) <> '.HTML') then begin
    LSavePath := 'WebPageMHTFile.html';
  end;

  //拡張子を.mhtに変更
  LSavePath := ChangeFileExt(LSavePath, '.mht');

  //保存
  SaveURLasMHT(EmbeddedWB1.LocationURL, LSavePath);
end;

//=============================================================================
//  Edit1のOnKeyDownイベント
//  他のウェブページのテスト用
//  ページの移動は[Back]または[Shift]+[Back](EmbeddedWB1にフォーカスがある場合)
//=============================================================================
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  AURL : String;
begin
  if Key = VK_RETURN then begin
    AURL := Trim(Edit1.Text);
    EmbeddedWB1.Navigate(AURL);
   end;
end;

end.

//-----------------------------------------------------------------------------
//  ウェブページを.MHT形式のファイルで保存するルーチン
//  url      : 保存するウェブページのアドレス
//  fileName : 保存ファイル名。フルパス
//  全てのウェブページが完全に保存できる保証はない
//
//  usesにComObjが必要
//-----------------------------------------------------------------------------
procedure SaveURLasMHT(const url: String; const fileName: String);
var
  Lobjimsg   : OleVariant;
  Lobjiconf  : OleVariant;
  LobjStream : OleVariant;
begin
  Lobjimsg   := CreateOleObject('CDO.Message');
  Lobjiconf  := CreateOleObject('CDO.Configuration');
  LobjStream := CreateOleObject('ADODB.Stream');

  try
    LObjimsg.Configuration := Lobjiconf;
    Lobjimsg.CreateMHTMLBody(url, 0, '', '');
    LobjStream := Lobjimsg.GetStream;
    LobjStream.SaveToFile(fileName, 2);
  finally
    Lobjimsg   := Unassigned;
    Lobjiconf  := Unassigned;
    LobjStream := Unassigned;
  end;
end;