Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2015年05月18日] [更新 2020年10月17日] Delphi サンプルプログラム集
   
766_ウェブブラウザを使用しない Web ページの保存
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro + Indy 10.5.7 + IE 10, IE 11
Delphi 用正規表現ユニット SkRegExp 3.0.7
766_SaveWebPage.zip [3,7 KB] 2020年10月17日版(EXE同梱)



  • 2020年10月17日 (これ以前の履歴は省略)
  • IHTMLDocument2.readyState の判定を loading で行うコードに変更
  • ウェブページを階層的に保存するプログラムの記事だけにした




ウェブブラウザを使用しないウェブページの保存


IE には [ファイル] [名前を付けて保存] の [Web ページ 完全] の機能があります.
ブラウザや,IE コンポーネントであれば,そのドキュメントから IHTMLDocument2 オブジェクトのインスタンスが取得できます.ブラウザを使用しない場合は,HTML コードを取得して,そのテキストコードから IHTMLDocument2 オブジェクトのインスタンスを取得して操作します.あるいは正規表現等を使用して HTML コードを解析します.



ウェブページの保存については,The Internet archive (インターネット・アーカイブ) というアメリカの団体が,ウェブアーカイブを運営しています.以下を参考にしてください.



[備考]
ウェブサイトから HTML のコード等を取得する操作のことをクローリング,クローリングによって,ウェブサイトのタイトルやテキストを取り出すことをスクレイピングということがあります.また,HTML コードを解析することを HTML のバースと呼ぶことがあります.





01_ウェブページを階層的に保存するプログラム


実際にウェブページを階層的に保存するサンプルを作成してみました.全ての形式のウェブページに対応することはできませんが,少しだけ本格的に作ってみました.
このプログラムでは,以下のユニット類を使用します.これらをライブラリのパスの通った場所に置いて使用します.ファイルのダウンロードには WinInet を使用することにしました.

  • 小宮秀一氏作 の Delphi 用正規表現ユニット SkRegExp
  • タイプライブラリの取り込みで作成した添付の MultiLanguage_TLB ユニット
  • 添付の plHtmlUtiltsEx ユニット

当サイトのように,ページを表示するために必要な画像等のファイルが階層的に,サーバの同じホスト内に保存されているウェブページが対象です.これを便宜上「階層式のサイト」と言うことにします.
インターネットが普及しだした頃に多く見られた方式です.

ウェブページが階層的になっているページを保存するには,最初の保存ページを決めます.このページは,ブラウザで表示する場合の表示ページです.このページがあるディレクトリ以下のページを保存するものとします.
FTP 接続であれば,ディレクトリを再帰的に検索できますが,HTTP サーバ, HTTPS サーバへの接続の場合は,この方法は使えません.
そこで,まず,最初のページから HTML コードを取得して,そのページからリンクしているページや画像等のリストを取得します.更に,取得した各々のページからリンクしているページや画像等のリストを取得します.これを繰り返します.
階層的な保存は,当サイトのように,階層的な構成のサイトのページの保存に向いています.ブログ等のように,ディレクトリ構造が変化するサイトのウェブページの保存には適していません.

ブログや,ウィキペデイア (フリー百科事典) で代表される Wiki 方式のサイトは,画像等のファイルが別のホストに保存されている場合があります.階層的に保存されているわけではありません.
本プログラムでは,同じホスト内のファイルしか保存しないようにしています.したがって,保存対象のウェブページによっては,インターネットに接続されていない,オフラインの状態では正しく表示できない場合があります.
また,全てのウェブサイトのページが正常に保存できるとは限りません.

保存するのは指定したウェブページだけですが,フレームは,保存しないとページ全体としての表示がきません.そこで,フレームだけは保存するようにしています.ただし,CSS とか JavaScript で構成している疑似フレームの HTML コードは保存しません.画像類は,ウェブページの HTML コードを解析して,表示している画像類のリンク先を検出して保存します.



[備考]
ただ単にウェブページをダウンロードして,ローカルディスクに保存できればいいのであれば,以下のリンクの記事にある Wget のようなコマンドラインツールを使用する手もあります.
インターネットが普及し始めた頃は,このようなツールがネット上で多く提供されていました.Vector にはいまでも登録されているかも知れません.





02_作成したプログラムの仕様と使用例


作成したプログラムの使用例です.機能的には以下のようになっています.

  • サイトのディレクトリ構造をそのまま反映したディレクトリ構造で保存する
  • 保存対象のページは,基本的に,拡張子が .htm, html のファイルだけとする
    拡張子がない URL の場合は,デフォルトのファイル名を付ける
  • リンクの階層は 3 階層までとする
  • フレームは再帰的に検出するが,iFrame は対象外とする
  • 指定したウェブページがあるディレクトリ内と,その階層下のページだけを保存する
  • 保存するのは,HTML コードと,選択した拡張子のファイルとする
  • ワードやエクセルで作成されたウェブページの画像もダウンロードする
  • ファイルは常に上書き保存とする

サイトのディレクトリ構造と同じディレクトリ構造で保存すると,余分なディレクトリ (フォルダ) も作成されることもあります.しかし,この方式には利点もあります.保存したディレクトリ構造が元のサイトのディレクトリ構造と全く同じですから,記事の編集や,リンクの再構成等が容易です.

下図は,本プログラムを操作した例です.



図1
設計時の画面
  • リンクを辿る階層を指定する
  • ダウンロードするファイルの拡張子を指定する
図2
ダウンロードするページのリスト
  • 当サイトの場合
  • 765 ページある
  • これらのページと,これらのページで表示している画像類をダウンロードする
図3
ダウンロードしたファイル類
  • サイトのサーバのディレクリ構造と同じディレクトリ構造でダウンロードして保存する
  • 保存したフォルダの名前は,ダウンロード後でも変更可能
    (ここでは mrxray.on.coocan.jp の変更が可能)

下図は,下記の「Delphi 基本の基 (キホンノキ)」というウェブページの Delphi のサンプルのページを保存した例です.
このページのアドレス (URL) は,ディレクリ構造の下の方にあります.したがって,保存したページをブラウザで表示するには,index.htm をブラウザで表示します.
本プログラムでは,深い階層下に保存されたページを表示しやすいように,保存先のルートディレクリとに,jamp_downloadpage.html というファイルを作成しています.このファイルをブラウザで表示すると,保存したウェブページにジャンプするようになっています.


http://www.ne.jp/asahi/aaa/tach1394/delphi/index.htm


図4
対象のウェブページ
  • 「Delphi 基本の基」のページのリスト
図5
ダウンロードしたファイル類
  • サイトのサーバのディレクリ構造と同じディレクトリ構造でダウンロードして保存する
  • jamp_downloadpage.html を起動すると,ダウンロードしたページを表示できる
図6
index.htm をブラウザで表示
  • リンクしている各ページもディスクに保存されている

ウェブページのアドレスの末尾が / のサイトまたはウェブページがあります.これは「デフォルトドキュメント」が省略されています.デフォルトドキュメントの多くは index.html, index.html のように,index という名前です.

ウェブサイトのページの構成は様々です.例えば「Delphi Acid Floor」のトップページには,サイトのアドレスが 次の最初の行のように書かれています.しかし,このアドレスのままだと,そのサイトのページからリンクされている他のページのアドレスの全てを取得することはできません.
アドレス (URL) として 2 行目の値を指定すると,そのサイト内ページのリストが取得できます.


http://www.wwlnk.com/boheme/
http://www.wwlnk.com/boheme/top.html


下図は,実際に「Delphi Acid Floor」のサイトのウェブページをダウンロードし,Delphi tips のページを表示した結果です.
ブラウザのキャッシャを消去し,オフライン作業にして表示を確認しています.



図7
Delphi Acid Floor のサイト

[備考 1]
IE 10 までは,メニューの [ファイル] [オフラインで作業] の項目がありましたが,IE 11 では,この項目は削除されています.


[備考 2]
本プログラムは,最初の保存対象のウェブページの階層下のページだけを保存するようにしています.そのため,同じサイト内のページ内にあるページであっても,保存しないページがあります.
ネットで入所可能なツールの多くは,そのようなリンクのページも再帰的に検出してダウンロードします.


[備考 3]
ブログや Wiki のサイトは,画像類が別のホストに置いてあることがあります. これらの画像は,背景画像あるいは記事本文中の画像によって,置いてあるホスト名やディレクトリ名が違うことがあります.
本プログラムは,同じホスト内にあるファイルしかダウンロードしません.したがって,そのようなブログの記事を保存しても,オフラインの状態での画像表示はできません.


[備考 4]
Wiki 形式のウェブページの保存に挑戦しましたが,力及ばす断念しました.Delphi のオンラインヘルプの DocWiki のページはスタイルを維持した保存が可能です.
Wikipedia の記事に関しては,オフラインリーダーと呼ばれる専用のアプリがあります.また,WikipediaAPI という API も提供されています.





03_ウェブページの階層的な保存プログラムのソースコード


本プログラムのソースコードです.この後に次項のコードが続いています.



リスト1
ウェブページの階層的な保存プログラムのソースコード
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, MSHTML, IdURI, ComCtrls, CheckLst;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Memo1: TMemo;
    ProgressBar1: TProgressBar;
    Label1: TLabel;
    RadioGroup1: TRadioGroup;
    Edit2: TEdit;
    Edit3: TEdit;
    CheckListBox1: TCheckListBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CheckListBox1Click(Sender: TObject);
  private
    { Private 宣言 }
    FBaseSourceUrl    : string;
    FDefaultFileName  : string;
    FOtherFilesDir    : string;
    FProtocol         : string;
    FSiteHostDir      : string;
    FSiteSourceDir    : string;
    FSiteTopDir       : string;
    FBaseSaveDir      : string;
    FListLinkPages    : TStringList;
    FIsCancel         : Boolean;
    FEdit1OrignalProc : TWndMethod;

    function GetLinkHtmlPageList(AProtocol, ASiteHostDir, ASiteSourceDir,
      APageUrl: string; AListLinkdedURL: TStringList; ALayerNo: Integer): Integer;
    procedure Edit1SubClassProc(var message: TMessage);
    function DownloadWebPage(AProtocol, ASiteHostDir, ASiteSourceDir,
      ASiteTopDir, APageUrl, ABaseSaveDir, AOtherFilesDir, ADefaultFileName: string;
      AListFileExt: TStringList; AListDownloadURL, AListCssSiteUrls,
      AListCssSaveFiles: TStringList): Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ComObj,
  IOUtils,
  StrUtils,
  HTTPApp,
  SkRegExpW,
  Clipbrd,
  plHtmlUtiltsEx;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LIndex : Integer;
begin
  FEdit1OrignalProc := Edit1.WindowProc;
  Edit1.WindowProc  := Edit1SubClassProc;
  Edit1.AutoSelect  := True;

  Button2.Enabled := False;
  Button3.Enabled := False;
  Label1.Caption  := '';
  Edit2.Text      := '';
  Edit3.Text      := '';

  for LIndex := 0 to 7 do begin
    CheckListBox1.Checked[LIndex] := True;
  end;

  FListLinkPages := TStringList.Create;
  Memo1.Lines.Clear;

  // ダウンロードするウェブページの指定
  Edit1.Text := 'http://mrxray.on.coocan.jp/index.htm';
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Edit1.WindowProc  := FEdit1OrignalProc;
  FreeAndNil(FListLinkPages);
end;

//=============================================================================
//  CheckListBox1 の OnClick イベント処理
//=============================================================================
procedure TForm1.CheckListBox1Click(Sender: TObject);
begin
  CheckListBox1.ItemIndex := -1;
end;

//=============================================================================
//  ダウンロードすべきページのリストを作成
//  グローバル変数はここで取得しておく
//  (各 HTML とファイルのダウンロード対象の URL と保存先を除く)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  対象のウェブページの最初のディレクトリ名を取得
  //  ブログ等で,画像が別のホストに保存されている場合,この関数で取得したディ
  //  レクトリ名が含まれていれば,そのページで使用されている画像と見なしダウン
  //  ロードの対象とする
  //  対象サイトのトップページの場合は空文字になる
  //
  //  ASitePath : ホスト名の値 (末尾は / )
  //              対象のページが http://xxxx.jp/hogehoge/dir1/ の場合は
  //              /hogehoge/dir1/ を与える.この時本ルーチンは /hogehoge/ を返す
  //---------------------------------------------------------------------------
  function GetSiteTopDir(ASitePath: string): string;
  const
    Delimiters : TSysCharSet = ['/'];
    WhiteSape  : TSysCharSet = [];
  var
    LList : TStringList;
    LText : string;
  begin
    Result := '';

    LList := TStringList.Create;
    try
      HTTPApp.ExtractHTTPFields(Delimiters, WhiteSape, PChar(ASitePath), LList);
      if LList.Count >= 2 then begin
        LText := LList[1];
        if LeftStr(LText, 1) <> '/' then LText := '/' + LText;
        if RightStr(LText, 1) <> '/' then LText := LText + '/';
        Result := LText;
      end;
    finally
      FreeAndNil(LList);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LIdURL         : TIdURI;
  LRet           : Integer;
  LTargetUrl     : string;
  LText          : string;
  LLayerNo       : Integer;
  LMinimizePath  : string;
  LIndex         : Integer;
begin
  Memo1.Lines.Clear;
  FListLinkPages.Clear;

  FIsCancel       := False;
  Label1.Caption  := '0';
  Edit2.Text      := '';
  Edit3.Text      := '';
  Button1.Enabled := False;
  Button2.Enabled := False;
  Button3.Enabled := True;
  RadioGroup1.Enabled   := False;
  ProgressBar1.Position := 0;

  for LIndex := 0 to Self.ComponentCount -1 do begin
    if Components[LIndex] is TControl then begin
      TControl(Components[LIndex]).Cursor := crHourGlass;
    end;
  end;
  Button3.Cursor := crDefault;

  FBaseSourceURL   := TIdURI.URLEncode(Edit1.Text);
  FBaseSourceUrl   := MakeUrlWithOutParam(FBaseSourceUrl, False, '');
  FDefaultFileName := 'index.html';

  // ホームディレクトリ等の URL を取得しておく
  LIdURL := TIdURI.Create(FBaseSourceURL);
  try
    FProtocol      := LIdURL.Protocol;
    FSiteHostDir   := FProtocol + '://' + LIdURL.Host + '/';
    FBaseSourceUrl := LIdURL.URI;
    FSiteTopDir    := GetSiteTopDir(LIdURL.Path);

    // 保存先のディレクトリ(フォルダ)のフルパス
    // 必要なら変更するか,ダウンロードの後に移動するか変更する
    FBaseSaveDir   := ExtractFilePath(Application.ExeName) + '000' + PathDelim;
    FBaseSaveDir   := FBaseSaveDir + LIdURL.Host + PathDelim;
  finally
    FreeAndNil(LIdURL);
  end;
  FSiteSourceDir := TPath.GetDirectoryName(FBaseSourceURL) + '/';
  FOtherFilesDir := FBaseSaveDir + 'OtherFilesFolder' + PathDelim;


  // ダウンロードすべきウェブページのリストを作成
  // 接続失敗や情報取得に失敗したページはリストに追加しない
  // 1 回目 (LIndex=0 の時) は大元の URL の接続のチェックなので失敗したら終了とする

  FListLinkPages.Add(FBaseSourceUrl);
  for LLayerNo := 0 to RadioGroup1.ItemIndex do begin
    ProgressBar1.Min := 0;
    ProgressBar1.Max := FListLinkPages.Count;
    ProgressBar1.Position := 0;

    // ウェブページ内のリンクを調べてリストに追加していく
    for LIndex := 0 to FListLinkPages.Count - 1 do begin
      if FIsCancel then break;

      LMinimizePath := MinimizeText(FListLinkPages[LIndex], Edit2, Edit2.Width - 180);
      Edit2.Text    := '処理ページ : ' + LMinimizePath;

      LTargetUrl := FListLinkPages[LIndex];
      LRet := GetLinkHtmlPageList(FProtocol,
                                  FSiteHostDir,
                                  FSiteSourceDir,
                                  LTargetUrl,
                                  FListLinkPages,
                                  LLayerNo);

      if (LLayerNo = 0) then begin
        if (LRet < 0) then begin
          LText := '接続または情報取得に失敗しました ( ' + IntToStr(LRet) + ' )';
          MessageBox(Handle, PChar(LText), '結果', MB_ICONINFORMATION);
          FIsCancel := True;
          break;
        end;
      end;

      if FIsCancel then break;
      ProgressBar1.Position := LIndex + 1;
      Application.ProcessMessages;
      Sleep(1);
    end;

    if FIsCancel then begin
      FListLinkPages.Clear;
      Memo1.Lines.Clear;
      Label1.Caption := '';
      break;
    end;


    Label1.Caption := 'ページ数 : ' + IntToStr(FListLinkPages.Count);
    Label1.Update;
    Memo1.Lines.BeginUpdate;
    Memo1.Lines.Clear;
    for LIndex := 0 to FListLinkPages.Count - 1 do begin
      Memo1.Lines.Add(URLDecodeEx(FListLinkPages[LIndex]));
    end;
    Memo1.Lines.EndUpdate;
  end;

  ProgressBar1.Position := 0;
  Edit2.Text      := '';
  Edit3.Text      := '';
  Button1.Enabled := True;
  Button2.Enabled := FListLinkPages.Count > 0;
  Button3.Enabled := False;
  RadioGroup1.Enabled := True;

  for LIndex := 0 to Self.ComponentCount -1 do begin
    if Components[LIndex] is TControl then begin
      TControl(Components[LIndex]).Cursor := crDefault;
    end;
  end;
end;

//=============================================================================
//  ウェブページ (HTML コード) をダウンロードして保存
//  ページで表示している画像類もダウンロード
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LListFileExt      : TStringList;
  LListCssSaveFiles : TStringList;
  LListCssSiteUrls  : TStringList;
  LTargetUrl        : string;
  LLinkPath         : string;
  LSavePath         : string;
  LHtmlCode         : TStringList;
  LMinimizePath     : string;
  LIndex            : Integer;
begin
  if FListLinkPages.Count = 0 then exit;

  LListFileExt      := TStringList.Create;
  LListCssSaveFiles := TStringList.Create;
  LListCssSiteUrls  := TStringList.Create;
  try
    //ダウンロードすべきファイルの拡張子
    for LIndex := 0 to CheckListBox1.Count - 1 do begin
      if CheckListBox1.Checked[LIndex] then begin
        LListFileExt.Add(Trim(CheckListBox1.Items[LIndex]));
      end;
    end;

    Button1.Enabled     := False;
    Button2.Enabled     := False;
    Button3.Enabled     := True;
    RadioGroup1.Enabled := False;

    for LIndex := 0 to Self.ComponentCount -1 do begin
      if Components[LIndex] is TControl then begin
        TControl(Components[LIndex]).Cursor := crHourGlass;
      end;
    end;
    Button3.Cursor := crDefault;

    FIsCancel             := False;
    ProgressBar1.Min      := 0;
    ProgressBar1.Max      := FListLinkPages.Count;
    ProgressBar1.Position := 0;

    // FListLinkPages (TStringList) に格納したウェブページと
    // そのページで使用している画像類をダウンロードする

    for LIndex := 0 to FListLinkPages.Count - 1 do begin

      LMinimizePath := MinimizeText(FListLinkPages[LIndex], Edit2, Edit2.Width - 180);
      Edit2.Text    := '処理ページ : ' + LMinimizePath;

      DownloadWebPage(FProtocol,
                      FSiteHostDir,
                      FSiteSourceDir,
                      FSiteTopDir,
                      FListLinkPages[LIndex],
                      FBaseSaveDir,
                      FOtherFilesDir,
                      FDefaultFileName,
                      LListFileExt,
                      FListLinkPages,
                      LListCssSiteUrls,
                      LListCssSaveFiles);
      ProgressBar1.Position := LIndex + 1;

      if FIsCancel then break;
    end;

    // ダウンロードが終了したらCSSファイルの Background の値を調査
    // 画像へのリンクがあればダウンロードし,CSS の該当部分を書き換える

    if not FIsCancel then begin
      for LIndex := 0 to LListCssSiteUrls.Count - 1 do begin

        LMinimizePath := MinimizeText(LListCssSiteUrls[LIndex], Edit2, Edit2.Width - 185);
        Edit2.Text    := 'CSS 処理中 : ' + LMinimizePath;
        Edit3.Text    := '';

        DownloadBackGroundImageCSS(FProtocol,
                                   FSiteHostDir,
                                   FSiteSourceDir,
                                   FSiteTopDir,
                                   FBaseSaveDir,
                                   FOtherFilesDir,
                                   LListCssSiteUrls[LIndex],
                                   LListCssSaveFiles[LIndex],
                                   ProgressBar1);
      end;


      // 保存したページを起動しやすいように,自動ジャンプ用のページを作成
      // この HTML ファイルを起動すると保存したページが表示できる
      LHtmlCode := TStringList.Create;
      try
        LTargetUrl := MakeUrlWithOutParam(FBaseSourceUrl, True, FDefaultFileName);
        LSavePath  := FBaseSaveDir + 'jump_downloadpage.html';

        // 対象となった元のウェブページの保存先を取得
        // 変数に退避しておいた方がいいかも知れない
        LLinkPath := GetSaveFilePath(LTargetUrl,
                                     FSiteHostDir,
                                     FSiteSourceDir,
                                     FSiteTopDir,
                                     FBaseSaveDir,
                                     FOtherFilesDir,
                                     False,
                                     False);
        // 保存を相対パスに変換
        LLinkPath := GetRelativeSavePath(FBaseSaveDir, LSavePath, LLinkPath);
        //IE対策
        LLinkPath := URLDecodeEx(LLinkPath);

        // 自動ジャンプ用の HTML コードを生成
        LHtmlCode.Add('<html>');
        LHtmlCode.Add('<head>');
        LHtmlCode.Add('<meta http-equiv="refresh" content="0;URL=' + LLinkPath + '">');
        LHtmlCode.Add('</head>');
        LHtmlCode.Add('</html>');
        //保存する
        LHtmlCode.SaveToFile(LSavePath);


        LHtmlCode.Clear;
        // 対象となった元のウェブページへの移動用 HTML コードを生成
        LSavePath := FBaseSaveDir + 'jump_originalwebpage.html';
        //IE対策
        LLinkPath := URLDecodeEx(FBaseSourceUrl);

        // 自動ジャンプ用の HTML コードを生成
        LHtmlCode.Add('<!-- Original WebPage URL -->');
        LHtmlCode.Add('<!-- ' + FBaseSourceUrl + ' -->');
        LHtmlCode.Add('<html>');
        LHtmlCode.Add('<head>');
        LHtmlCode.Add('<meta http-equiv="refresh" '
                    + 'content="0;URL=' + FBaseSourceUrl + '">');
        LHtmlCode.Add('</head>');
        LHtmlCode.Add('</html>');
        //保存する
        LHtmlCode.SaveToFile(LSavePath);
      finally
        FreeAndNil(LHtmlCode);
      end;
    end;
  finally
    FreeAndNil(LListFileExt);
    FreeAndNil(LListCssSaveFiles);
    FreeAndNil(LListCssSiteUrls);
  end;

  Edit2.Text      := '';
  Edit3.Text      := '';
  Button1.Enabled := True;
  Button2.Enabled := FListLinkPages.Count > 0;
  Button3.Enabled := False;
  RadioGroup1.Enabled   := True;
  ProgressBar1.Position := 0;

  for LIndex := 0 to Self.ComponentCount -1 do begin
    if Components[LIndex] is TControl then begin
      TControl(Components[LIndex]).Cursor := crDefault;
    end;
  end;
end;

//=============================================================================
//  キャンセルボタン
//  ダウンロードを中止する
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  FIsCancel := True;
end;

//-----------------------------------------------------------------------------
//  引数で指定したウェブページで,リンクしているページのリストを作成する関数
//  引数で指定したウェブページがあるディレクトリの階層下のリンクのみを取得
//  そのディレクトリより上の階層のリンクはリストしない(フレームは除く)
//
//
//  AProtocol        : 対象サイトのプロトコル (http,https 等)
//  ASiteHostDir     : 対象サイトのホストディレクトリ
//  ASiteSourceDir   : ページをダウンロードする対象のディレクトリ (末尾に / が必要)
//  APageUrl         : 保存対象のウェページのアドレス
//                     htm,html 等のファイル名がない場合は末尾を / とする
//  AListLinkdedURL  : ダウンロード対象となるウェブページのリストを返す
//  ALayerNo         : 何階層目かの値
//
//  ウェブ上のファイルの MIME タイプを調べる方法もあるが時間がかかる
//  そこで,このルーチンでは拡張子で判定している
//  そのため,ファイル名の末尾が.gif, .jpg, .png 等のウェブページはリストに追加
//  されない
//-----------------------------------------------------------------------------
function TForm1.GetLinkHtmlPageList(AProtocol, ASiteHostDir, ASiteSourceDir,
  APageUrl: string; AListLinkdedURL: TStringList; ALayerNo: Integer): Integer;
const
  Delimiters : TSysCharSet = ['&', '#'];
  WhiteSape  : TSysCharSet = [' '];
var
  LFileExt       : string;
  LPageUrl       : string;
  LArrayExt      : array of string;
  LiDoc2         : IHTMLDocument2;
  LDocTypeText   : string;
  LCodePage      : Integer;
  LElementColl   : IHTMLElementCollection;
  LIndex         : Integer;
  LElement       : IHTMLElement;
  LOldAttibValue : string;
  LAttribute     : string;
  LFullURL       : string;
  LiPos          : Integer;
  LTempText      : string;
  LAddPageFlag   : Boolean;
begin
  Result := 0;

  SetLength(LArrayExt, 5);
  LArrayExt[0] := '.htm';
  LArrayExt[1] := '.html';
  LArrayExt[2] := '.php';
  LArrayExt[3] := '.asp';
  LArrayExt[4] := '.aspx';

  // クエリパラメータを除いた URL の値とする
  // ページ指定の / ? p= 等のパラメータは残す
  LPageUrl := MakeUrlWithOutParam(APageUrl, False, '');

  // IHTMLDocument2 インターフェイスのオブジェクトを生成
  LiDoc2 := CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

  // URL から IHTMLDocument2 オブジェクトのドキュメントを取得
  if not URLtoIHTMLDoc2(LPageUrl, LiDoc2, LDocTypeText, LCodePage) then begin
    // IHTMLDocument2 のドキュメントが取得できなければ終了
    // 該当するウェブページに接続できない場合もエラー
    Result := -2;
  end else begin
    try
      // 自分自身
      LFullURL := ToAbsoluteURLPath(AProtocol, ASiteHostDir, LPageUrl, LPageUrl);

      // ページ内のリンク部分は削除
      LiPos := Pos('#', LFullURL);
      if LiPos > 0 then begin
        LTempText := Copy(LFullURL, LiPos, Length(LFullURL));
        LFullURL  := StringReplace(LFullURL, LTempText, '', []);
      end;
      // 既にリストに存在する URL は追加しない
      if AListLinkdedURL.IndexOf(LFullURL) < 0 then begin
        AListLinkdedURL.Add(LFullURL);
      end;

      //-----------------------------------------------------------------------
      //  タグの処理
      //  これ以外にもタグの処理が必要な場合があるかも知れない
      //-----------------------------------------------------------------------
      LElementColl := LiDoc2.all;
      for LIndex := 0 to LElementColl.length - 1 do begin
        LAttribute := '';
        LElement   := LElementColl.item(LIndex, '') as IHTMLElement;

        // 指定タグ名の指定属性の値を取り出す
        if LElement.tagName = 'FRAME' then begin
          LAttribute := 'src';
        end else
        if LElement.tagName = 'IFRAME' then begin
          LAttribute := 'src';
        end else
        if (LElement.tagName = 'LINK') and (ALayerNo > 0) then begin
          LAttribute := 'href';
        end else
        if (LElement.tagName = 'A') and (ALayerNo > 0) then begin
          LAttribute  := 'href';
        end;

        //---------------------------------------------------------------------
        //  タグのリンク先 URL の処理関係
        //  リンク先をリストに追加していく
        //---------------------------------------------------------------------
        if LAttribute <> '' then begin
          // 属性値を取得
          LOldAttibValue := LElement.getAttribute(LAttribute, 0);

          // javascript 疑似プロトコル (javascript 疑似スキー /JavaScript URI) は除外
          if not (ContainsText(LOldAttibValue, 'javascript:')) then begin

            // クエリパラメータはページへのリンク部分のみ取り出す
            // LUrlParam で必要なのはページ指定の部分のみ
            // それ以外はページ内リンクの#を取り除く
            LOldAttibValue := MakeUrlWithOutParam(LOldAttibValue, False, '');

            // ページ内のリンク (#) はリストには追加しない
            if (LeftStr(LOldAttibValue, 1) <> '#')
                and (LOldAttibValue <> '') then begin

              // 属性値 (リンク先) を絶対URLの値を取得 (クエリ パラメータなしの値)
              LFullURL := ToAbsoluteURLPath(AProtocol,
                                            ASiteHostDir,
                                            LPageUrl,
                                            LOldAttibValue);

              // 拡張子だけを取得
              LFileExt := LowerCase(TPath.GetExtension(LFullURL));
              if (MatchText(LFileExt, LArrayExt)) or (LFileExt = '') then begin

                // 元のなるディレクトリの階層下のページのみを対象とするので,
                // 元となるディレクトリが含まれているページだけをリストに追加
                // ただしフレームは対象のディレクトリより上にある場合があるので
                // サイトのトップディレクリ階層下を再帰的に調べる
                if (LElement.tagName = 'FRAME') then begin
                  LAddPageFlag := ContainsText(LFullURL, ASiteHostDir);
                end else begin
                  LAddPageFlag :=
                    LeftStr(LFullURL, Length(ASiteSourceDir)) = ASiteSourceDir;
                end;

                if LAddPageFlag then begin
                  // ページ内リンクの指定は削除する (フレームの場合はないと思うが)
                  LiPos := Pos('#', LFullURL);
                  if LiPos > 0 then begin
                    LTempText := Copy(LFullURL, LiPos, Length(LFullURL));
                    LFullURL  := StringReplace(LFullURL, LTempText, '', []);
                  end;

                  // 既にリストに存在する URL は追加しない
                  if AListLinkdedURL.IndexOf(LFullURL) < 0 then begin
                    AListLinkdedURL.Add(LFullURL);

                    // フレームだけは再帰的に検出
                    if (LElement.tagName = 'FRAME') then begin
                      GetLinkHtmlPageList(AProtocol,
                                          ASiteHostDir,
                                          ASiteSourceDir,
                                          LFullURL,
                                          AListLinkdedURL,
                                          ALayerNo);
                    end;
                  end;
                end;
              end;
            end;
          end;
        end;
        Application.ProcessMessages;
        if FIsCancel then break;
      end;
      //各種タグの処理終了

    except
      // DOM の処理で例外が発生した場合
      // アドレス(URL) はリストに追加しない
      Result := -1;
    end;
  end;
  LiDoc2          := nil;
  LElementColl    := nil;
  LElement        := nil;
end;


//-----------------------------------------------------------------------------
//  Edit1 のサブクラス化関数
//  この程度であれば派生クラス(コンポーネント)にするほどの必要はないだろう
//  デコードした URL をセットするために使用
//  実際に URL にアクセスする際はエンコードが必要
//-----------------------------------------------------------------------------
procedure TForm1.Edit1SubClassProc(var message: TMessage);
var
  LText : string;
  LLen  : Integer;
begin
  // 元の WindowsProc を実行
  FEdit1OrignalProc(message);

  // クリップボードからの貼り付けの場合
  if message.Msg = WM_PASTE then begin
    if Clipboard.HasFormat(CF_TEXT) then begin
      LText := Clipboard.AsText;
      Edit1.Text := URLDecodeEx(LText);
    end;
  end else
  // テキストが変更になった時のメッセージ処理
  // 直接 Edit1.Text に代入すると,またこのメッセージの処理が実行される
  // そのために永久循環になってしまう
  if message.Msg = CM_TEXTCHANGED then begin
    LLen := Edit1.Perform(WM_GETTEXTLENGTH, 0, 0);
    SetString(LText, nil, LLen + 1);
    Edit1.Perform(WM_GETTEXT, LLen + 1, PChar(LText));

    // Edit1 にデコードした値をセット
    LText := URLDecodeEx(LText);
    Edit1.Perform(WM_SETTEXT, 0, PChar(LText));
  end;
end;




04_ウェブページの HTML コードを解析するコード


上のコードの続きです.
この DownloadWebPage 関数は,上の GetLinkHtmlPageList 関数で取得したウエブページのリストの各々のウェブページの HTML ファイルをダウンロードして,そのコードを解析して,保存用の HTML コードを作成して保存します.



リスト2
ウェブページの HTML コードを解析するコード
//-----------------------------------------------------------------------------
//  指定したウェブページの HTML と画像類をダウンロードする関数
//  ダウンロードするウェブページのリストから保存先パス名を作成しながら保存
//  該当サイトのディレクリと同じディレクトリ構造にして保存する
//
//  AProtocol         : 対象サイトのプロトコル (http,https 等)
//  ASiteHostDir      : 対象サイトのホストディレクトリ
//  ASiteSourceDir    : ページをダウンロードする対象のディレクトリ(末尾に / が必要)
//  ASiteTopDir       : 該当サイトの最初のディレクトリ (部分名だけ)
//                      空文字にすると大元のページに含まれているホスト内に含ま
//                      れている画像ファイル類だけダウンロードの対象となる
//  APageUrl,         : 保存対象のウェページのアドレス
//  ABaseSaveDir      : 保存先のルートディレクトリ
//  AOtherFilesDir    : 対象ホスト名がURLに指定文字列が含まれていないファイルを
//                      保存するディレクトリ名
//  ADefaultFileName  : ファイル名がない場合に付けるデフォルトのファイル名
//  AListFileExt      : ダウンロードするファイルの拡張子のリスト
//                      html (text/html) 関係のファイルは指定しても無効
//  AListDownloadURL  : ダウンロードするウェブページを格納したリスト
//  AListCssSiteUrls  : CSSファイルのURLのリストを格納して返す
//  AListCssSaveFiles : CSSファイルの保存先のリストを格納して返す
//
//  javascript, css は,リンクが提供元のサーバの場合はダウンロードしない
//  ダウンロードしないと,オフラインの時にスタイルが反映されないが,対象のペー
//  ジがネット上から消失しても,javascrip, css が提供されていれば,スタイルは再現
//  できる
//  現在は,デスクトップコンピュータのほとんどがネットに接続の状態で使用されて
//  いることを考えれば,これは妥当な仕様と思われる
//  javascript の中には,html,css コード生成するものもあり,ダウンロードする場合
//  は,これらもパース(解析)する必要がある
//  ただし,Jquery.js だけは例外的にダウンロードする
//-----------------------------------------------------------------------------
function TForm1.DownloadWebPage(AProtocol, ASiteHostDir, ASiteSourceDir,
  ASiteTopDir, APageUrl, ABaseSaveDir, AOtherFilesDir, ADefaultFileName: String;
  AListFileExt: TStringList; AListDownloadURL, AListCssSiteUrls,
  AListCssSaveFiles: TStringList): Integer;

  //---------------------------------------------------------------------------
  //  保存時の重複名のチェック
  //  重複する場合は末尾に数字を加えた名前にする
  //  本サンプルでは CSS の保存名の際にだけ使用している
  //---------------------------------------------------------------------------
  function CheckDuplicateFileName(AFileUrlPath, ASaveFileName: string;
    AFileUrlList: TStringList; AListSaveFileName: TStringList): string;
  var
    LFileDir     : string;
    LNoExtName   : string;
    LFileExt     : string;
    LNewFileName : string;
    LIndex       : Integer;
    LFileNo      : Integer;
  begin
    LNewFileName := ASaveFileName;

    // 同名のファイルが存在しなけば処理は不要
    LIndex := AListSaveFileName.IndexOf(ASaveFileName);
    if LIndex >= 0 then begin
      if AFileUrlList[LIndex] <> AFileUrlPath then begin
        LFileDir   := TPath.GetDirectoryName(ASaveFileName);
        LNoExtName := TPath.GetFileNameWithoutExtension(ASaveFileName);
        LFileExt   := TPath.GetExtension(ASaveFileName);

        LFileNo := 1;
        while True do begin
          LNewFileName := LNoExtName + '-' + FormatFloat('0#', LFileNo) + LFileExt;
          LNewFileName := LFileDir + PathDelim + LNewFileName;
          if AFileUrlList.IndexOf(LNewFileName) < 0 then break;
          LFileNo := LFileNo + 1;
        end;
      end;
    end;

    Result := LNewFileName;
  end;
  //---------------------------------------------------------------------------

var
  LArrayExt         : array of string;
  LiDoc2            : IHTMLDocument2;
  LDocTypeText      : string;
  LCodePage         : Integer;
  LPageUrl          : string;
  LSaveHtmlFilePath : string;
  LElementColl      : IHTMLElementCollection;
  LElement          : IHTMLElement;
  LOriginAttib      : string;
  LOldAttib         : string;
  LNewAttib         : string;
  LUrlParams        : string;
  LStyleValue       : string;
  LAttribute        : string;
  LOriginFullURL    : string;
  LFullURL          : string;
  LTempFullURL      : string;
  LHtmlCode         : TStringList;
  LFileExt          : string;
  LSharp            : string;
  LiPos             : Integer;
  LSaveFilePath     : string;
  LListMatch        : TStringList;
  LEncode           : TEncoding;
  LTempStr          : string;
  LSkRegExp         : TSkRegExp;
  LMatchText        : string;
  LIndex            : Integer;
begin
  Result := 0;

  SetLength(LArrayExt, AListFileExt.Count + 1);
  for LIndex := 0 to AListFileExt.Count - 1 do begin
    LArrayExt[LIndex] := LowerCase(AListFileExt[LIndex]);
  end;
  LArrayExt[AListFileExt.Count] := '.php';

  // IHTMLDocument2 インターフェイスのオブジェクトを生成
  LiDoc2 := CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

  // URL から IHTMLDocument2 オブジェクトのドキュメントを取得
  // LCodePage はウェブページの文字コードページ
  if not URLtoIHTMLDoc2(APageUrl, LiDoc2, LDocTypeText, LCodePage) then begin
    // IHTMLDocument2 のドキュメントが取得できなければ終了
    // 該当するウェブページに接続できない場合もエラー
    Result := -2;
  end else begin

    LPageUrl := APageUrl;
    // ファイル名がない場合はデフォルトの拡張子のファイル名を付ける
    LPageUrl := MakeUrlWithOutParam(LPageUrl, True, ADefaultFileName);

    // デコードしてから保存ファイル名を生成する
    // デコードしないと IE では表示できない (表示する時にエンコードするらしい)
    // 変換後の値を単にデコードすると,日本語の変換に失敗して空文字になる
    // TEncoding.Default を指定してデコードすると日本語が文字化けする
    LTempStr := URLDecodeEx(LPageUrl);
    LSaveHtmlFilePath := GetSaveFilePath(LTempStr,
                                         ASiteHostDir,
                                         ASiteSourceDir,
                                         ASiteTopDir,
                                         ABaseSaveDir,
                                         AOtherFilesDir,
                                         False,
                                         True);

    //------------------------------------------------------------------------
    //  処理するタグの種類
    //  これ以外にもタグの処理が必要な場合があるかも知れない
    //------------------------------------------------------------------------

    LElementColl := LiDoc2.all;
    for LIndex := 0 to LElementColl.length - 1 do begin
      try
        LAttribute := '';
        LElement   := LElementColl.item(LIndex, '') as IHTMLElement;


        // 指定タグ名の指定属性の値を取り出す
        if LElement.tagName = 'BODY' then begin
          LAttribute := 'background';
        end else
        if LElement.tagName = 'TABLE' then begin
          LAttribute := 'background';
        end else
        if LElement.tagName = 'TD' then begin
          LAttribute := 'background';
        end else
        if LElement.tagName = 'FRAME' then begin
          LAttribute := 'src';
        end else
        if LElement.tagName = 'IFRAME' then begin
          LAttribute := 'src';
        end else
        if LElement.tagName = 'LINK' then begin
          LAttribute := 'href';
        end else
        if LElement.tagName = 'SCRIPT' then begin
          LAttribute := 'src';
        end else
        if LElement.tagName = 'IMG' then begin
          // srcset は画像の表示サイズ等の制御用 (レスポンシブ・イメージ)の属性
          //これの属性を削除しないと表示できない画像がある(リンクは表示される)
          // 画像をクリックして元の画像を表示する機能は PHP が提供している
          // 同じ名前の画像を別名でダウンロードして,属性をセットする必要がある
          LElement.removeAttribute('srcset', 0);
          LAttribute := 'src';
        end else
        if LElement.tagName = 'A' then begin
          LAttribute  := 'href';
        end else

        //---------------------------------------------------------------------
        //  この部分は UL タグの Sytle 属性専用の処理
        //  UL タグの情報は JavaScript に記述されていることもある
        //  小宮秀一氏作の Delphi 用正規表現ユニット SkRegExp を利用
        //---------------------------------------------------------------------
        if LElement.tagName = 'UL' then begin
          // 画像だけを検出
          LStyleValue := LElement.style.listStyleImage;

          if LStyleValue <> '' then begin
            LListMatch := TStringList.Create;
            try
              if TSkRegExp.RegMatch('\((.+?)\)', LStyleValue, LListMatch) then begin
                // url の()内のパス名を取得
                LOldAttib := LListMatch[1];
                //属性値(リンク先)を絶対URLの値に変換
                LFullURL := ToAbsoluteURLPath(AProtocol,
                                              ASiteHostDir,
                                              APageUrl,
                                              LOldAttib);
                // 保存先のフルパス
                LSaveFilePath := GetSaveFilePath(LFullURL,
                                                 ASiteHostDir,
                                                 ASiteSourceDir,
                                                 ASiteTopDir,
                                                 ABaseSaveDir,
                                                 AOtherFilesDir,
                                                 False,
                                                 True);
                // 属性値の値を保存先の相対パスに変換
                LNewAttib := GetRelativeSavePath(ABaseSaveDir,
                                                 LSaveHtmlFilePath,
                                                 LSaveFilePath);


                if (LeftStr(LOldAttib, 1) <> '#') and (LFileExt <> '') then begin
                  // listStyleImage の画像パス名部分を置き換え
                  LNewAttib := StringReplace(LStyleValue,
                                             LOldAttib,
                                             LNewAttib,
                                             []);
                  // \ (円記号) では画像が表示されない
                  LNewAttib := StringReplace(LNewAttib,
                                             '\',
                                             '/',
                                             [rfReplaceAll]);
                end;

                // 要素に新しい属性をセット
                LElement.style.listStyleImage := LNewAttib;
                // ダウンロード
                DownloadWebFileSaveToFile(LFullURL, LSaveFilePath, False);
              end;
            finally
              FreeAndNil(LListMatch);
            end;
          end;
          // このエレメントは処理済みとする
          LAttribute := '';
        end;
        // UL タグの処理終了

        //---------------------------------------------------------------------
        //  この部分は UL タグ以外のファイルの保存処理関係
        //  LUrlParams の先頭は ? がある
        //---------------------------------------------------------------------
        if LAttribute <> '' then begin

          LOriginAttib := LElement.getAttribute(LAttribute, 0);
          // まずリンク属性の URL を絶対 URL に変換
          // ここで取得した値にはパラメータ類も含まれている
          LOriginFullURL := ToAbsoluteURLPath(AProtocol,
                                              ASiteHostDir,
                                              LPageUrl,
                                              LOriginAttib);


          // 現在処理中のページ内のリンク (先頭が #) の場合,属性値の変更はしない
          // 以下はそれ以外の処理
          if (LeftStr(LOriginFullURL, 1) <> '#')
              and (LOriginFullURL <> '') then begin

            //パラメータだけを取り出す
            LUrlParams := GetLinkUrlParams(LOriginAttib);

            // パラメータなしのリンクの値と拡張子を取得
            LFullURL := StringReplace(LOriginFullURL, LUrlParams, '', []);
            LFileExt := LowerCase(TPath.GetExtension(LFullURL));

            // # がある場合はその部分を変数に退避
            // 属性のセットの時に付加する
            LSharp := '';
            LiPos  := Pos('#', LOriginFullURL);
            if LiPos > 0 then begin
              LSharp       := Copy(LOriginFullURL, LiPos, Length(LOriginFullURL));
              LTempFullURL := Copy(LOriginFullURL, 1, LiPos - 1);
            end else begin
              LTempFullURL := LOriginFullURL;
            end;

            LTempStr   := MinimizeText(LTempFullURL, Edit3, Edit3.Width - 160);
            Edit3.Text := '処理中 : ' + LTempStr;


            // CGI は絶対パスを設定
            // CGI は実行環境がないと表示できない
            // リダイレクトで取得して保存することも考えられる
            if (LFileExt = '.cgi') then begin
              LElement.setAttribute(LAttribute, LOriginFullURL, 0);
            end else
            // 属性値が保存対象のページの URL の値だった場合
            if AListDownloadURL.IndexOf(LTempFullURL) >= 0 then begin

              LSaveFilePath := GetSaveFilePath(LOriginFullURL,
                                               ASiteHostDir,
                                               ASiteSourceDir,
                                               ASiteTopDir,
                                               ABaseSaveDir,
                                               AOtherFilesDir,
                                               False,
                                               False);
              LNewAttib := GetRelativeSavePath(ABaseSaveDir,
                                               LSaveHtmlFilePath,
                                               LSaveFilePath);

              // クエリパラメータがページへのリンクの場合
              if (LeftStr(LUrlParams, 3) = '?p=')
                  or (LeftStr(LUrlParams, 9) = '?page_id=') then begin

                // & や # があっても PHP サーバでないと動作しない
                // ローカル PHP が動作可能なシステムならばセットしてもいいかも知れない
                // このあたりは PHP の知識が乏しいので適当!!
                if (ContainsText(LUrlParams, '&'))
                    or (ContainsText(LUrlParams, '#')) then begin

                  LElement.setAttribute(LAttribute, LOriginFullURL, 0);
                end else begin
                  LNewAttib := LNewAttib + TPath.GetExtension(ADefaultFileName);
                  // IE 対策 (FireFox 等では不要)
                  LNewAttib := URLDecodeEx(LNewAttib);
                  LElement.setAttribute(LAttribute, LNewAttib, 0);
                end;
              end else begin

                //-------------------------------------------------------------
                //  クエリパラメータにページ移動のパラメータがない場合
                //  ページを保存する (保存した) 時と同じ URL 値で属性をセットする
                //  # を除いた絶対 URL から属性の値を再計算
                //  ページのリストにある URL だけをセットするのであるが,実際には
                //  リストにあるページでもダウンロードできないページがある
                //
                //  if CheckWebFileCanDownload(LOriginFullURL) then begin
                //    ...
                //  end else begin
                //    LElement.setAttribute(LAttribute, LOriginFullURL, 0);
                //  end;
                //  のように,ダウンロード可能かをチェックして処理できるが,その
                //  ファイルに接続するために時間がかかるので省略している
                //-------------------------------------------------------------

                LTempFullURL := MakeUrlWithOutParam(LTempFullURL,
                                                    True,
                                                    ADefaultFileName);
                LSaveFilePath := GetSaveFilePath(LTempFullURL,
                                                 ASiteHostDir,
                                                 ASiteSourceDir,
                                                 ASiteTopDir,
                                                 ABaseSaveDir,
                                                 AOtherFilesDir,
                                                 False,
                                                 False);
                LNewAttib := GetRelativeSavePath(ABaseSaveDir,
                                                 LSaveHtmlFilePath,
                                                 LSaveFilePath);
                // IE 対策(FireFox 等では不要)
                LNewAttib := URLDecodeEx(LNewAttib);
                LElement.setAttribute(LAttribute, LNewAttib + LSharp, 0);
              end;
            end else begin

              if not (MatchText(LFileExt, LArrayExt))
                  or (LFileExt = '')
                  or (LFileExt = '.html')
                  or (LFileExt = '.htm')
                  or (LFileExt = '.asp')
                  or (LFileExt = '.aspx') then begin

                if ContainsText(LOriginFullURL, 'javascript:') then begin
                  LTempStr := 'javascript';
                  LSaveFilePath := GetSaveFilePath(LOriginFullURL,
                                                   ASiteHostDir,
                                                   ASiteSourceDir,
                                                   ASiteTopDir,
                                                   ABaseSaveDir,
                                                   AOtherFilesDir,
                                                   False,
                                                   False);
                  LNewAttib := GetRelativeSavePath(ABaseSaveDir,
                                                   LSaveHtmlFilePath,
                                                   LSaveFilePath);
                  // GetSaveFilePath はファイル名に使用できない:を削除してしまう
                  // その対策
                  LNewAttib := StringReplace(LNewAttib,
                                             LTempStr,
                                             LTempStr + ':',
                                             []);
                  LElement.setAttribute(LAttribute, LNewAttib, 0);
                end else begin
                  // 保存対象以外は絶対 URL を属性値にセット
                  // フレームタグの src 属性は,今処理しているこのページと同じく
                  // ローカルな場所でないと変更はできないらしい
                  LElement.setAttribute(LAttribute, LOriginFullURL, 0);
                end;
              end else begin
                //-----------------------------------------------------------
                //  以下,保存対象のファイルの場合
                //  # 等はないものとする
                //  LFullURL はパラメータなしの値
                //-----------------------------------------------------------

                // LFullURL が空の場合は空文字を返す
                LSaveFilePath := GetSaveFilePath(LFullURL,
                                                 ASiteHostDir,
                                                 ASiteSourceDir,
                                                 ASiteTopDir,
                                                 ABaseSaveDir,
                                                 AOtherFilesDir,
                                                 True,
                                                 True);

                if (LSaveFilePath <> '') and (LFileExt = '.php') then begin
                  // php のスタイルシートはダウンロードする
                  // load.php という名前になっているので,これを load.css で保存する
                  if (TPath.GetFileName(LSaveFilePath) = 'load.php') then begin
                    if LElement.tagName = 'LINK' then begin
                      LTempStr := LowerCase(LElement.getAttribute('rel', 0));
                      if LTempStr = 'stylesheet' then begin
                        LFileExt      := '.css';
                        LSaveFilePath := TPath.ChangeExtension(LSaveFilePath,
                                                               LFileExt);
                      end;
                    end;
                  end;
                  if LFileExt <> '.css' then begin
                    // 保存対象外にする
                    // PHP は PHP の実行環境がインストールされていないと実行できない
                    LSaveFilePath := '';
                    LElement.setAttribute(LAttribute, LOriginFullURL, 0);
                  end;
                end;

                if LSaveFilePath <> '' then begin

                  // CSS ファイルのリストに追加
                  // CSS は同じ名前の時がある
                  // 保存したCSS ファイルは後で解析する
                  // これは同じ CSS でもパラメータの違いによる
                  // 本サンプルでは CSS 以外の重複チェックはしていないが
                  // 重複の可能性はある
                  if LFileExt = '.css' then begin
                    LSaveFilePath := CheckDuplicateFileName(LTempFullURL,
                                                            LSaveFilePath,
                                                            AListCssSiteUrls,
                                                            AListCssSaveFiles);
                    AListCssSiteUrls.Add(LTempFullURL);
                    AListCssSaveFiles.Add(LSaveFilePath);
                  end;

                  LNewAttib := GetRelativeSavePath(ABaseSaveDir,
                                                   LSaveHtmlFilePath,
                                                   LSaveFilePath);

                  // ダウンロード処理
                  // MIME タイプが text/html ファイルは,元の属性をそのままセット
                  if DownloadWebFileSaveToFile(LTempFullURL, LSaveFilePath, False)
                      then begin
                    // IE 対策 (FireFox 等では不要)
                    LNewAttib := URLDecodeEx(LNewAttib);
                    LElement.setAttribute(LAttribute, LNewAttib, 0);
                  end else begin
                    LElement.setAttribute(LAttribute, LOriginFullURL, 0);
                  end;
                end;

                if FIsCancel then Break;
              end;
            end;
          end;
        end;
      except
        // エレメントの処理でエラーとなった場合
        Result := -3;
      end;
      Application.ProcessMessages;
      Sleep(1);
    end;

    // プロバイダ提供の[ブックマーク][ツイート][シェア]等のボタン類のタグを削除
    // オフラインで観る時は機能しないから削除してもいいだろう?
    for LIndex := LElementColl.length - 1 downto 0 do begin
      LElement := LElementColl.item(LIndex, '') as IHTMLElement;
      if LElement.className = 'sharedaddy sd-sharing-enabled' then begin
        LElement.outerHTML := '';
      end else
      if LElement.className = 'share-button sectionfooter' then begin
        LElement.outerHTML := '';
      end else
      if LElement.tagName = 'INS' then begin
        if LElement.className = 'adsbygoogle' then begin
          LElement.outerHTML := '';
        end;
      end;
    end;
    // 各種タグの処理終了


    //-------------------------------------------------------------------------
    //  編集後の HTML コードの保存処理
    //-------------------------------------------------------------------------

    LHtmlCode := TStringList.Create;
    try
      try
        LHtmlCode.Text := LiDoc2.body.parentElement.outerHTML;

        // DOCTYPE タグ部分を挿入
        LElementColl := LElementColl.tags('DOCTYPE') as IHTMLElementCollection;
        if LElementColl.length = 0 then begin
          if LDocTypeText <> '' then begin
            LHtmlCode.Insert(0, LDocTypeText);
          end;
        end;

        // Yahoo ジオシティーズの広告関係のタグを削除してしまう
        // オフラインの時にオフラインの大きな表示が現れるので...
        LSkRegExp := TSkRegExp.Create;
        try
          // 検索用の正規表現パターン
          LSkRegExp.Expression := '<\!-- geoguide start -->.+?<\!-- geoguide end -->';
          LSkRegExp.Options    := [roIgnoreCase, roSingleLine];

          // 検索開始
          if LSkRegExp.Exec (LHtmlCode.Text) then begin
            repeat
              LMatchText     := LSkRegExp.Groups[0].Strings;
              LHtmlCode.Text := StringReplace(LHtmlCode.Text,
                                              LMatchText,
                                              '',
                                              []);
            // 対象の文字列がマッチしなくなるまでループ
            until not LSkRegExp.ExecNext;
          end;
        finally
          FreeAndNil(LSkRegExp);
        end;

        // 元の文字コードページで保存する
        // 元のコードページでないコードページで保存する場合は,
        // HTML の該当部分(Charset の値等)を変更する必要あり
        LEncode := TEncoding.GetEncoding(LCodePage);
        try
          LHtmlCode.SaveToFile(LSaveHtmlFilePath, LEncode);
        finally
          FreeAndNil(LEncode);
        end;
      finally
        FreeAndNil(LHtmlCode);
      end;
      // 編集後の HTML コードの保存処理終了
    except
      // 保存処理で例外が発生した場合
      Result := -1;
    end;
  end;

  LiDoc2       := nil;
  LElementColl := nil;
  LElement     := nil;
end;


添付の plHtmlUtiltsEx.pas には下表に示す関数類を実装しています.



関数名 機能
CheckWebPageLocationIsDir 引数の URL がディレクトリ名かを判定する関数
リダイレクトの結果で判定する
CheckWebFileIsTextHtml ウェブ上のファイルが text/html 形式かを確認する関数
ウェブ上のファイルの MIME タイプを判定する
CheckWebFileCanDownLoad ウェプ上のファイルがダウンロード可能かをチェックする関数
DownloadWebFileSaveToFile ウェブ上のファイルをローカルなディスクに保存する関数
DownloadFileToStream ウェブ上のファイルを TMemoryStream に格納する関数
URLtoIHTMLDoc2 ウェブ上の HTML テキストから IHTMLDocument2のドキュメントのオブジェクト取得する関数
DetectCodepage テキストのコードページを自動判定する関数
TStringList に格納したテキスト,または,メモリストリームに格納されたテキストのコードページ判定用
MakeUrlWithOutParam URL のパラメータ等を削除したファイル名を生成する関数
ToAbsoluteURLPath URL のパス文字列を絶対 URL の値に変換する関数
GetLinkUrlParams URL の文字列からパラメータを除いた URL 値と,パラメータ部分だけを取り出す関数
GetSaveFilePath URL の値からディスクに保存する際のパス名を生成する関数
GetRelativeSavePath ディスクへの保存パス名を相対パス名に変換する関数
URLDecodeEx 文字列をデコードした値を返す関数
MinimizeText 長いテキストの先頭部分を省略記号 (...) にして,指定した長さの文字列を生成する関数
FormatCssCode CSS コードの簡易整形ルーチン
戻り値は生成した行数
DownloadBackGroundImageCSS CSS 内で定義している背景画像の URL を取得してディスクに保存する関数
戻り値は保存した画像ファイルの数




05_IHTMLDocument2 オブジェクトの取得


plHtmlUtiltsEx ユニットに実装しいる関数です.
HTML コードから IHTMLDocument2 のオブジェクトを取得する関数のコードです.



[備考]
本サンプルは,HTML コードから IHTMLDocument2 オブジェクトを取得して,それを操作しています.元の HTML コードから IHTMLDocument2 オブジェクトを取得する場合,全ての HTML のコードがそのままセットされるわけではありません.これは,システムに実装されている Mshtml.dll のバージョンによっても異なります.
ネット上で入手可能な HTML パーサ (Parser) は,元の HTML コードのまま HTML をパース (解析) するものがあります.それらを使用すれば,元の HTML コードそのものの解析となります.



リスト3
HTML コードから IHTMLDocument2 のオブジェクトを取得する関数
//-----------------------------------------------------------------------------
//  ATargetURL のウェブから IHTMLDocument2 のドキュメントを取得
//
//  ATargetURL       : 対象のページのアドレス
//                     index.htm 等を省略する場合は最後にデリミタが必要
//  IDoc2            : IHTMLDocument2 オブジェクト (呼び出し側で生成しておく)
//  var ADocTypeText : DOCTYPE タグのテキスト
//                     IHTMLDocument2 オブジェクトから取得するコードにはない
//                     HTML コードを保存する際に追加するため
//  var ACodePage    : 対象のウェブページの文字のコードページ
//                     本関数内で検出して結果を返す
//
//  IHTMLDocument2 の使用には uses に MSHTML が必要
//  ContainsText の使用には uses に StrUtils が必要
//  小宮氏作成の Delphi 用正規表現ユニット SkRegExp 3.0.7 を利用
//-----------------------------------------------------------------------------
function URLtoIHTMLDoc2(ATargetURL: string; IDoc2: IHTMLDocument2;
  var ADocTypeText: string; var ACodePage: Integer): Boolean;
var
  LHtmlCode  : TStringList;
  LStream    : TMemoryStream;
  LEncode    : TEncoding;
  OleArray   : Variant;
  LLineCount : Integer;
  LStartTime : Cardinal;
  LSkRegExp  : TSkRegExp;
  LMatchText : string;
  LTempText  : string;
  LIndex     : Integer;
begin
  LHtmlCode := TStringList.Create;
  try
    try
      //ATargetURLのページのHTMLコードをTMemoryStreamに格納
      LStream  := TMemoryStream.Create;
      try
        // Web ページ ATargetURL からファイルをダウンロードしてメモリストリームに格納
        // text/html でない場合は以後の処理は実行しない
        Result := DownloadFileToStream(ATargetURL, LStream, True);
        if not Result then exit;

        // コードページを指定して HTML コードをストリームから読み出す
        // コードページが妥当でないと正しく取得できない
        ACodePage := DetectCodepage(MLDETECTCP_HTML, LStream);
        // TEncoding.GetEncoding では扱えない値の場合
        if ACodePage = 51932 then begin
          ACodePage := 20932;
        end else
        if ACodePage = 1200  then begin
          ACodePage := TEncoding.Unicode.CodePage;
        end else
        if ACodePage = 1201 then begin
          ACodePage := TEncoding.BigEndianUnicode.CodePage;
        end;
        LEncode := TEncoding.GetEncoding(ACodePage);

        try
          LStream.Position := 0;
          LHtmlCode.LoadFromStream(LStream, LEncode);
        finally
          FreeAndNil(LEncode);
        end;
      finally
        FreeAndNil(LStream);
      end;

      // オフラインの場合,IHTMLDocument2 には DOCTYPE タグの内容が格納されない
      // ここで退避して HTML コードを保存する時に挿入する
      ADocTypeText := '';
      LLineCount   := Min(10, LHtmlCode.Count - 1);
      for LIndex := 0 to LLineCount do begin
        if ContainsText(LHtmlCode[LIndex], '<!DOCTYPE HTML') then begin
          ADocTypeText := LHtmlCode[LIndex];
          break;
        end;
      end;

      //-----------------------------------------------------------------------
      //  Microsoft Office (ワードやエクセル)で作成されたウェブページ対応処理
      //  Office 2000 当時の資料に基づいているので最新のワードやエクセルで作成
      //  された場合については保証なし
      //  何故このような仕様になっているかは全く不明 (謎)
      //-----------------------------------------------------------------------
      LSkRegExp := TSkRegExp.Create;
      try
        // 検索用の正規表現パターン
        LSkRegExp.Expression := '<!\[if !vml\]>.+?<!\[endif\]>';
        LSkRegExp.Options    := [roIgnoreCase, roSingleLine];

        // 検索開始
        if LSkRegExp.Exec (LHtmlCode.Text) then begin
          repeat
            LMatchText := LSkRegExp.Groups[0].Strings;
            LTempText  := StringReplace(LMatchText,
                                        '<![if !vml]>',
                                        '<!--[if gte vml 1]>',
                                        []);
            LTempText := StringReplace(LTempText,
                                       '<![endif]>',
                                       '<![endif]-->',
                                       []);
            LHtmlCode.Text := StringReplace(LHtmlCode.Text,
                                            LMatchText,
                                            LTempText,
                                            []);
          // 対象の文字列がマッチしなくなるまでループ
          until not LSkRegExp.ExecNext;
        end;
      finally
        FreeAndNil(LSkRegExp);
      end;
      //-----------------------------------------------------------------------


      // IHTMLDocument2 を編集可能にして
      // 念のためreadStateが complete になるまで待つ
      IDoc2.designMode := 'on';
      while IDoc2.readyState = 'loading' do begin
        Application.ProcessMessages;
      end;

      // バリアント配列に HTML コードをセット
      OleArray := VarArrayCreate([0, 0], VarVariant);
      try
        VarArrayLock(OleArray);
        OleArray[0] := LHtmlCode.Text;

        // IHTMLDocument2 オブジェクト にHTML コードを書き込む
        IDoc2.Write(PSafeArray(System.TVarData(OleArray).VArray));

        //---------------------------------------------------------------------
        //  IHTMLDocument2 オブジェクトに HTML コードをセットするまで待つ処理
        //
        //  designMode := 'on' にして readyState = 'loading の間ループする
        //  designModeは off にしない
        //  designMode を off にすると動画にリンクがあるページでハングアップする
        //  エラーとしては検出できない
        //  表示用の UI コントロールを探すためらしいが詳細は不明
        //  IDoc2 (IHTMLDocument2) を操作している間は on にしたままとする
        //
        //  MSHTML はファイルを非同期にロードするが,Write も非同期のようである
        //---------------------------------------------------------------------
        IDoc2.designMode := 'on';
        LStartTime := timeGetTime;
        // 筆者の環境では complete では永久ループになってしまうので loading 判定
        while IDoc2.readyState = 'loading' do begin
          if (timeGetTime - LStartTime) > 250 then break;
          Application.ProcessMessages;
        end;
      finally
        VarArrayUnLock(OleArray);
        VarClear(OleArray);
      end;
    finally
      FreeAndNil(LHtmlCode);
    end;
  except
    // ウェブページの HTML コードに不正があった場合等
    Result := False;
  end;
end;




06_IHTMLDocument2 オブジェクトの取得 - OleVariant


IHTMLDocument2 オブジェクトにドキュメントをセットするには,OleVariant 型の変数を使用することもできます.OleVariant 型を使用すれば,バリアント配列を操作する必要はありません.
次のコードはその例です.



リスト4
OleVariant 型を使用して IHTMLDocument2 オブジェクトにドキュメントをセットする
implementation

uses
  MSHTML,
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LHtmlFilePath : string;
begin
  // 読み込む HTML ファイルのパス名
  LHtmlFilePath := ExtractFilePath(Application.ExeName) + 'HtmlTestCode.html';
  Edit1.Text := LHtmlFilePath;
end;

//=============================================================================
// IHTMLDocument2 オブジェクトにドキュメントをセットする
// OleVariant 型を使用して Write メソッドでセットする方法
//
//  uses に MSHTML,ComObjが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSaveFilePath : string;
  LiDoc2        : IHTMLDocument2;
  LCodeList     : TStringList;
  LvarTemp      : OleVariant;
  LvarDocument  : OleVariant;
  LvarMiMETYPE  : OleVariant;
begin
  // 保存ファイル名
  LSaveFilePath := ExtractFilePath(Application.ExeName) + 'AAA.html';

  // IHTMLDocument2 インターフェイスのオブジェクトを生成
  LiDoc2 := CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

  // IHTMLDocument2 を編集可能にして
  // readState が loading 状態の時は待つ
  LiDoc2.designMode := 'on';
  while LiDoc2.readyState = 'loading' do begin
    Application.ProcessMessages;
    Sleep(1);
  end;

  if LiDoc2 <> nil then begin
    LCodeList := TStringList.Create;
    try
      // HTML コードを読み込む
      LCodeList.LoadFromFile(Edit1.Text);

      // MIMETYPE 等を設定してコードを書きこむ
      LvarTemp     := LiDoc2;
      LvarDocument := LvarTemp.script.Document;
      LvarMiMETYPE := 'text/Html';
      LvarDocument.Open(LvarMiMETYPE);
      LvarDocument.Clear;
      LvarDocument.Write(LCodeList.Text);
      LvarDocument.Close;

      // readState が loading 状態の時は待つ
      while LiDoc2.readyState = 'loading' do begin
        Application.ProcessMessages;
        Sleep(1);
      end;
      // これで LiDoc2 にドキュメントがセットされた

      // 保存
      LCodeList.Clear;
      LCodeList.Text := LiDoc2.body.parentElement.outerHTML;
      LCodeList.SaveToFile(LSaveFilePath);
    finally
      FreeAndNil(LCodeList);
    end;
  end;
end;




07_IHTMLDocument2 オブジェクトの取得 - htmlfile


htmlfile オブジェクトを使用すると,例えば次ののように書けます.



リスト5
htmlfile オブジェクトにドキュメントをセットする
上のコードに対して変更したのは (*) の 3 ヶ所
implementation

uses
  MSHTML,
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LHtmlFilePath : string;
begin
  // 読み込む HTML ファイルのパス名
  LHtmlFilePath := ExtractFilePath(Application.ExeName) + 'HtmlTestCode.html';
  Edit1.Text := LHtmlFilePath;
end;

//=============================================================================
//  htmlfile オブジェクトにドキュメントをセットする
//  上のコードに対して変更したのは (*) の 3 ヶ所
//
//  uses に MSHTML,ComObj が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSaveFilePath : string;
  LiDoc2        : OleVariant;    //(*)
  LCodeList     : TStringList;
  LvarTemp      : OleVariant;
  LvarDocument  : OleVariant;
  LvarMiMETYPE  : OleVariant;
begin
  // 保存ファイル名
  LSaveFilePath := ExtractFilePath(Application.ExeName) + 'AAA.html';

  // htmlfile オブジェクトを生成
  LiDoc2 := CreateOleObject('htmlfile');  //(*)

  // htmlfile オブジェクトを編集可能にして
  // readState が loading の間は待つ
  LiDoc2.designMode := 'on';
  // readState が loading 状態の時は待つ
  while LiDoc2.readyState = 'loading' do begin
    Application.ProcessMessages;
    Sleep(1);
  end;

  if not VarIsEmpty(LiDoc2) then begin  //(*)
    LCodeList := TStringList.Create;
    try
      //HTMLコードを読み込む
      LCodeList.LoadFromFile(Edit1.Text);

      // MIMETYPE 等を設定してコードを書きこむ
      LvarTemp     := LiDoc2;
      LvarDocument := LvarTemp.script.Document;
      LvarMiMETYPE := 'text/Html';
      LvarDocument.Open(LvarMiMETYPE);
      LvarDocument.Clear;
      LvarDocument.Write(LCodeList.Text);
      LvarDocument.Close;

      // readState が loading 状態の時は待つ
      while LiDoc2.readyState = 'loading' do begin
        Application.ProcessMessages;
        Sleep(1);
      end;
      // これで htmlfile ブジェクトにドキュメントがセットされた

      // 保存
      LCodeList.Clear;
      LCodeList.Text := LiDoc2.body.parentElement.outerHTML;
      LCodeList.SaveToFile(LSaveFilePath);
    finally
      FreeAndNil(LCodeList);
    end;
  end;
end;




08_IHTMLDocument4.createDocumentFromUrl 関数


IHTMLDocument4 インターフェイスに createDocumentFromUrl という関数があります.
この関数を使用すると,ウェブページのアドレス (URL) から直接 IHTMLDocument2 オブジェクトのドキュメントを取得することができます.
IHTMLDocument2 ドキュメントのコードページは,日本語環境の場合, shift_jis です.そのため,本プログラムの IHTMLDocument2 オブジェクト取得コードでは,ウェブページを読み込んだ際に,コードページを調べて,そのコードページの値で保存するようにしています.

下図は,この createDocumentFromUrl 関数の使用例です.IHTMLDocument2 のコードを保存していますが,コードページが shift_jis 以外のウェブページを保存して表示すると,文字化けします.



[備考]
当サイトのページでは,サイト内へのリンクは全て相対アドレスにしています.したがって,下図のページのリンク部分をクリックしても,該当するページは表示できません.
もし,絶対アドレス (絶対 URL) で記述してあれば,クリックすることにより,ウェブ上の該当ページを表示することができます.



図8
保存した HTML を表示

リスト6
IHTMLDocument4.createDocumentFromUrl 関数の使用例
implementation

uses
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // ダウンロードするウェブページの指定
  Edit1.Text := 'http://mrxray.on.coocan.jp/index.htm';
end;

//=============================================================================
//  IHTMLDocument4.createDocumentFromUrl 関数の使用例
//  URL から IHTMLDocument2 ドキュメントのコードを取得する
//
//  uses に MSHTML,ComObj が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSaveHtmlFilePath : string;
  LiDoc2            : IHTMLDocument2;
  LiDoc4            : IHTMLDocument4;
  LHtmlCode         : TStringList;
begin
  //保存ファイル名
  LSaveHtmlFilePath := ExtractFilePath(Application.ExeName) + 'AAA.html';

  // IHTMLDocument2 インターフェイスのオブジェクトを生成
  LiDoc2 := CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

  if LiDoc2 <> nil then begin
    // IHTMLDocument4 インターフェイスのオブジェクトを生成
    LiDoc2.QueryInterface(IID_IHTMLDocument4, LiDoc4);

    // createDocumentFromUrl を使用して URL からドキュメントを取得
    LiDoc2.designMode := 'on';
    LiDoc2 := LiDoc4.createDocumentFromUrl(Edit1.Text, '');
    //完了まで待つ
    while LiDoc2.readyState = 'loading' do begin
      Application.ProcessMessages;
      Sleep(1);
    end;

    // 保存処理
    LHtmlCode := TStringList.Create;
    try
      // コードを取得
      LHtmlCode.Text := LiDoc2.body.parentElement.outerHTML;
      LHtmlCode.SaveToFile(LSaveHtmlFilePath);
    finally
      FreeAndNil(LHtmlCode);
    end;
  end;
end;




09_コードページの自動検出用の関数


plHtmlUtiltsEx ユニットに実装しいる関数です.
DetectCodepage は,ウェブページの文字のコードページを検出するために使用します.
MLang の機能を使用しています.MLang ではメモリストリーム内のコードページを検出するので,HTML のテキストを TMemoryStream に格納してからこの関数を実行します.
この関数で取得したコードページの値は,HTML コードを保存する時にも使用します.元のコードページと同じ文字コードで保存しないと,ブラウザで表示した時に文字化けします.別の文字コードで保存することも考えられますが,HTML の場合,文字コードを指定するタグや属性値があります.この部分も変更しなければなりません.ブラウザで表示する必要がなければ変換しても構いません.

この関数の機能は必ずしも完全とは言えません.保存した HTML コードが文字化けするようであれば,コードページを明確に指定する必要があります.短いコードでは失敗する場合があるようです.

本ページで使用している MultiLanguage_TLB.pas は [IDL コンパイラを使用したタイプライブラリの作成と取り込み] 記事の説明に従って作成したものです.



[備考]
TMemoryStream に格納されている文字数,つまり,テキストの長さが短いとコードページが正しく取得できません.




リスト7
文字コード (コードページ) の自動検出用の関数
//-----------------------------------------------------------------------------
//  コードページの自動検出用の関数
//  対象のテキストの長さが短いと正しく判定できない
//
//  dwFlag     : テキストの種類を指定する定数
//  ASrcStream : ここに格納されている文字のコードページを検出する
//-----------------------------------------------------------------------------
function DetectCodepage(dwFlag: DWORD;
  ASrcStrings: TStringList): Integer;
var
  LStrema : TMemoryStream;
begin
  LStrema := TMemoryStream.Create;
  try
    ASrcStrings.SaveToStream(LStrema);
    Result := DetectCodepage(dwFlag, LStrema);
  finally
    FreeAndNil(LStrema);
  end;
end;

//-----------------------------------------------------------------------------
//  コードページの自動検出用の関数
//  戻り値はコードページの値
//  対象のテキストの長さが短いと正しく判定できない
//
//  dwFlag     : テキストの種類を指定する定数
//  ASrcStream : ここに格納されている文字のコードページを検出する
//
//  このコードの使用には uses に ComObj,MultiLanguage_TLB が必要
//-----------------------------------------------------------------------------
function DetectCodepage(dwFlag: DWORD; ASrcStream: TMemoryStream): Integer;
var
  LhRet     : HRESULT;
  LMLang    : IMultiLanguage2;
  LSrcArray : array of Char;
  LSrcSize  : Integer;
  LEncode   : tagDetectEncodingInfo;
  Lscores   : Integer;
begin
  // 0 はシステムのデフォルト値(日本語環境の場合は SHIFT_JIS)
  // コードページの検出に失敗した場合はこの値を返す
  Result := TEncoding.Default.CodePage;

  LMLang := CreateComObject(CLASS_CMultiLanguage) as IMultiLanguage2;

  if LMLang <> nil then begin
    LSrcSize := ASrcStream.Size;
    SetLength(LSrcArray, LSrcSize);
    ASrcStream.Position := 0;
    ASrcStream.Read(LSrcArray[0], Length(LSrcArray));

    // dwFlag はソースコードの種類
    Lscores := 1;
    LhRet := LMLang.DetectInputCodepage(dwFlag,
                                        0,
                                        LSrcArray[0],
                                        LSrcSize,
                                        LEncode,
                                        Lscores);
    if LhRet = S_OK then begin
      Result := LEncode.nCodePage;
    end;
    LMLang := nil;
  end;
end;




10_Charset の値からコードページの値を取得


IHTMLDocument4.createDocumentFromUrl 関数を使用した場合,HTML の Charset の値が文字列として取得できます.これを利用してコードページを取得することができます.
次のコードはそれを確認するためのサンプルです.
MLang の GetCharsetInfo 関数を使用しています.


  IHTMLDocument2.chaset;

  // 上のサンプルの場合
  // LCharsetはstring型の変数
  LCharset := LiDoc2.charset;



図9
実行結果の例


リスト8
Charset の値からコードページの値を取得
implementation

uses
  MultiLanguage_TLB;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // 大文字でも小文字でもよい
  Edit1.Text := 'shift_jis'; 
  Edit1.Text := 'EUC_JP';    
  Edit1.Text := 'utf-8';
end;

//=============================================================================
//  MLang の機能を使用して Charset の文字列からコードページの値を取得
//
//  uses に MultiLanguage_TLB が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LCharset      : string;
  LCodePage     : Cardinal;
  LMLang        : IMultiLanguage;
  LMIMECSETInfo : TMIMECSETINFO;
begin
  LCharset  := Edit1.Text;
  LCodePage := 0;

  // MLang のオブジェクトを生成
  LMLang := CoCMultiLanguage.Create;
  try
    if LMLang.GetCharsetInfo(LCharset, LMIMECSETInfo) = S_OK then begin
      LCodePage := LMIMECSETInfo.uiInternetEncoding;
    end;
  finally
    LMLang := nil;
  end;
  MessageBox(Handle, PChar(IntToStr(LCodePage)), 'CodePage', MB_ICONINFORMATION);
end;




11_パラメータ付きの属性値からパラメータを取得する関数


plHtmlUtiltsEx ユニットに実装しいる関数です.
HTML のタグの href 属性等のリンク先の URL はパラメータ付きの場合があります.
このパラメータが付いたまま,ディレクトリ名やファイル名の取得等の処理を行うと,例外が発生したり正しく取得できないことがあります.
GetLinkUrlParams 関数は,このパラメータを取得します.取得したパラメータは退避しておき,タグの属性値を設定する際に付け加えます.引数には,パラメータを除いた URL の値を返します.この引数が返した値を実際の処理に使用します.



リスト9
パラメータ付きの属性値からパラメータと,パラメータを除いた URL の値を取得する関数
//-----------------------------------------------------------------------------
//  パラメータ付きの属性値からパラメータを取得する関数
//
//  AUrl : 対象の URL の値.各タグの href 属性値として取得した値
//         本関数の実行後,バラメータを除いた値を返す
//
//  TIdURI の使用には uses に IdURI が必要
//-----------------------------------------------------------------------------
function GetLinkUrlParams(var AUrl: string): string;
var
  LIdURL : TIdURI;
  LText  : string;
begin
  Result := '';

  // 取得したリンク先の相対パスの先頭は about: または about:/ となるらしい
  // ページ内のリンクは about:blank となるらしい
  //これを削除しておく
  AUrl := StringReplace(AURL, 'about:blank', '', [rfIgnoreCase]);
  AURL := StringReplace(AURL, 'about:', '', [rfIgnoreCase]);

  LIdURL := TIdURI.Create(AUrl);
  try
    LText := LIdURL.Params;
    if LText <> '' then begin
      AUrl := StringReplace(AUrl, LText, '', [rfIgnoreCase]);
      if RightStr(AUrl, 1) ='?' then begin
        Delete(AUrl, Length(AUrl), 1);
        LText := '?' + LText;
      end;
      // まれに " (ダブルクォーテーションが付いたままの時があるので,その対策
      if LeftStr(AUrl, 1) = '"' then begin
        Delete(AUrl, 1, 1);
      end;
      Result := LText;
    end;
  finally
    FreeAndNil(LIdURL);
  end;
end;




12_相対 URL を絶対 URL に変換する関数


plHtmlUtiltsEx ユニットに実装しいる関数です.
タグの属性値として取得した URL の値はサイト,あるいはページが存在するディレクトリに対する相対パスで指定されていることがあります.この値を絶対 URL (絶対パス) に変換します.

保存する HTML のタグの href, src 属性等に設定する値は,保存しないファイルの場合は絶対バスにしないと,保存先のディレクトリを基準とした相対パスでファイルを探してしまいます.逆に,保存したファイルは相対パスを指定します.そうしないと,保存したファイルを別のディレクトリ (フォルダ) に移動すると,ブラウザで正しく表示できなくなります.



リスト10
相対 URL を絶対 URL に変換する関数
//-----------------------------------------------------------------------------
//  相対 URL を絶対 URL に変換する関数
//  ウェブページ ATargetURL の HTML コード内のリンクの ARelativeURL を絶対 URL に変換
//
//  AProtocol    : 対象のウェブページのプロトコル (http または https)
//  AHomeDir     : 対象のウェブページのホームディレクトリ (末尾にデリミタが必要)
//  ATargetURL   : 対象の大元のウェブページのアドレス
//                 index.htm 等を省略する場合は最後にデリミタが必要
//                 デリミタがない場合はファイル名と見なす
//  ARelativeURL : 絶対パスを取得したい相対パス名 (絶対パスでもよい)
//
//  戻り値
//  相対パスを絶対パスに変換した値
//  サイト外のアドレスの時は元の引数の値と同じ値を返す
//  先頭が#であるページ内のリンクも引数の値をそのまま返す
//
//  TPath の使用には uses に IOUtils が必要
//  ContainsText の使用には uses に StrUtils が必要
//-----------------------------------------------------------------------------
function ToAbsoluteURLPath(AProtocol, AHomeDir, ATargetURL,
  ARelativeURL: string): string;
var
  LBaseDir     : string;
  LRelativeURL : string;
begin
  Result       := '';
  LBaseDir     := ATargetURL;
  LRelativeURL := ARelativeURL;
  if RightStr(AProtocol, 1) <> ':' then begin
    AProtocol := AProtocol + ':';
  end;

  if LBaseDir = '' then exit;
  if LRelativeURL = '' then exit;


  // ホームディレクトリの URL が先頭に含まれていればすでに絶対バスと見なす
  if LeftStr(LRelativeURL, Length(AHomeDir)) = AHomeDir then begin
    Result := LRelativeURL;
  end else begin
    //取得したリンク先の相対パスの先頭はabout:またはabout:/となるらしい
    // ページ内のリンクは about:blank となるらしい
    // これを削除しておく
    LRelativeURL := StringReplace(LRelativeURL, 'about:blank', '', [rfIgnoreCase]);
    LRelativeURL := StringReplace(LRelativeURL, 'about:', '', [rfIgnoreCase]);

    //先頭が [//] の時はプロトコルに対する相対パス
    if (LeftStr(LRelativeURL, 2) = '//') then begin
      Result := AProtocol + LRelativeURL;
    end else
    // 先頭が [/] の時はサイトルート相対パス
    if (LeftStr(LRelativeURL, 1) = '/') then begin
      Delete(LRelativeURL, 1, 1);
      Insert(AHomeDir, LRelativeURL, 1);
      Result := LRelativeURL;
    end else
    // [./] は同じディレクトリ内を明示的に表す時の記述
    if (LeftStr(LRelativeURL, 2) = './') then begin
      Delete(LRelativeURL, 1, 2);
      Insert(TPath.GetDirectoryName(ATargetURL) + '/', LRelativeURL, 1);
      Result := LRelativeURL;
    end else begin
      // 先頭に [../] がない場合は同じディレクトリまたは他のサイトへのリンク
      if (LeftStr(LRelativeURL, 3) <> '../') then begin
        // [://] という文字列があれば他のサイトと見なす
        // php 等のジャンプ先の指定で使われることがある
        // その場合は当該のサイト内であることもあるが...
        if ContainsText(LRelativeURL, '://') then begin
          Result := LRelativeURL;
        end else begin
          if LeftStr(LRelativeURL, 1) = '#' then begin
            Result := LRelativeURL;
          end else begin
            Result := TPath.GetDirectoryName(LBaseDir) + '/' + LRelativeURL;
          end;
        end;
      end else begin
        // [../] の数だけ上の階層のディレクトリ名を取得していく
        while True do begin
          LBaseDir := TPath.GetDirectoryName(LBaseDir);
          if LeftStr(LRelativeURL, 3) <> '../' then break;
          Delete(LRelativeURL, 1, 3);
        end;
        LBaseDir := LBaseDir + '/';
        if ContainsText(LBaseDir, AHomeDir) then begin
          Result := LBaseDir + LRelativeURL;
        end;
      end;
    end;
  end;
end;




13_正規表現を使用した HTML 解析の簡単な例


HTML のパースは,正規表現を使用してもできると述べましたが,その簡単な例です.
次のサンプルは,上のサンプルで使用した Charset 属性の値を求める例です.Charset 属性は META タグで設定することになっています.
正規表現は,以下の文字列を設定しています.


  <META\s.*?charset=(.*?)[\s";].*?>


上の正規表現の各文字は,次の表のような意味です.表以外の文字または文字列は, HTML コード内 (テキスト内) に書いてある文字または文字列です.



正規表現 説明
\s スペース (空白文字) を意味します.
\S (S が大文字) の場合は,空白文字以外の任意の文字 (改行文字も含まれます) を意味します.
. . (ドット) は改行文字以外の任意の文字を意味します.
* 直前の文字が 0 個以上続くことを意味します.
.* は,改行文字以外の任意の文字が 0 個以上続くことを意味します.
0 個というのは,何も文字がない状態のことです.
? 最小マッチングの指定です.最初のマッチだけを対象とします.
本サンプルは,Charset という文字が 1 つだけの,たった 1 行のテキストなので,あってもなくても同じです.
() グループ化の指定です.() で囲まれた文字列が Groups や RegMatch で取り出すことができます.
添字 0 はマッチした文字列です.添字 1 が最初のグループ化文字列です.
[] [] 内のいずれかの文字を意味します.
本サンプルでは [\s";] となっています.最初の文字は空白文字です.したがって,空白文字か," または,; のいずれかの文字を意味します.


正規表現では,改行文字は,\n ですが,改行を含む任意の文字は,以下のように指定します.
TSkRegExp では,オプションに orSingleLine を含めると,. (ドット) の意味が変更となり,改行文字を含む全ての文字となります.[\s\S]* や [\s\S]+ を使用する必要はありません.

  [\s\S]*  // 改行文字を含む任意の文字が 0 個以上の場合
  [\s\S]+  // 改行文字を含む任意の文字が 1 個以上の場合


図10
実行結果


リスト11
正規表現を使用した HTML 解析の簡単な例
META タグの Charset 属性の値を取得する例
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Button2: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  SkRegExpW;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LText : string;
begin
  // 以下のどの文字列でも結果は同じ
  // 途中に改行があってもOK
  LText := '<META content="text/html; charset=shift_jis" http-equiv=Content-Type>';
  LText := '<meta http-equiv="Content-Type" content="text/html; charset=shift_jis;">';
  LText := '<meta http-equiv="Content-Type" content="text/html; charset=shift_jis">';

  Edit1.Text := LText;
  ActiveControl := Button1;
end;

//=============================================================================
//  正規表現 (TSkRegExp の Exec) を利用してHTML のタグの属性を取り出す
//  META タグの charset の例
//
// uses に SkRegExpW が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSkRegExp : TSkRegExp;
  LText     : string;
begin
  Memo1.Lines.Clear;

  LSkRegExp := TSkRegExp.Create;
  try
    LSkRegExp.Expression := '<META\s.*?charset=(.*?)[\s";].*?>';
    LSkRegExp.Options    := [roIgnoreCase, roSingleLine];

    if LSkRegExp.Exec(Edit1.Text) then begin
      // マッチ (検出) した文字列を表示
      // 本サンプルではグループ化した (カッコ() で囲んだ部分) 文字列は 1 つだけ
      LText := LSkRegExp.Groups[0].Strings;
      LText := LText + sLineBreak + LSkRegExp.Groups[1].Strings;
      Memo1.Lines.Add(LText);
    end;
  finally
    FreeAndNil(LSkRegExp);
  end;
end;

//=============================================================================
//  正規表現 (TSkRegExp の RegMatch) を利用して HTML のタグの属性を取り出す
//  META タグの charset の例
//
// uses に SkRegExpW が必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LMatches : TStringList;
  LText    : string;
begin
  Memo1.Lines.Clear;

  LMatches := TStringList.Create;
  try
    if TSkRegExp.RegMatch('<META\s.*?charset=(.*?)[\s";].*?>',
                          Edit1.Text,
                          LMatches,
                          [roIgnoreCase, roSingleLine]) then begin

      // マッチ (検出) した文字列を表示
      // 本サンプルではグループ化した (カッコ()で囲んだ部分) 文字列は 1 つだけ
      LText := LMatches[0] + sLineBreak + LMatches[1];
      Memo1.Lines.Add(LText);
    end;
  finally
    FreeAndNil(LMatches);
  end;
end;

end.




14_HTML コードの整形 ( フォーマット )


IHTMLDocument2 オブジェクトから取得した HTML コードは,お世辞にも整っているとは言えません.
HTML のパース (解析) には影響ありませんが,HTML コードの整形は,下図のように, Delphi の IDE でも可能です.
Delphi の IDE を起動して,HTML ファイルを読み込み,[ドキュメントの整形] を実行します.整形後のテキストが文字化けするようであれば,HTML のテキストのコードページをあらかじめ UTF-8 にしておくと文字化けしないようです.



図11
HTML ドキュメントの整形
  • HTML テキストのコードページを,あらかじめ UTF-8 にしておく
  • タグ名は小文字になる
  • 長い行は,読み込みの際に切り捨てられるので注意