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;

//-----------------------------------------------------------------------------
//  指定したウェブページの 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;

//-----------------------------------------------------------------------------
//  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;

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;

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;

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;

//-----------------------------------------------------------------------------
//  コードページの自動検出用の関数
//  対象のテキストの長さが短いと正しく判定できない
//
//  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;

  IHTMLDocument2.chaset;

  // 上のサンプルの場合
  // LCharsetはstring型の変数
  LCharset := LiDoc2.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;

//-----------------------------------------------------------------------------
//  パラメータ付きの属性値からパラメータを取得する関数
//
//  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;

//-----------------------------------------------------------------------------
//  相対 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;

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

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

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.