unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, ExtCtrls, MSHTML;

type
  TForm1 = class(TForm)
    IdHTTP1: TIdHTTP;
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    function URLtoIHTMLDoc2(AStrURL: string; var ASiteHomeDir: string;
      IDoc2: IHTMLDocument2): Boolean;
    procedure CheckDuplicateItems(AList: TStringList);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses 
  ComObj, 
  ActiveX, 
  Generics.Collections;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/index.htm';
end;

//=============================================================================
//  HTML コードから，他のページへのリンク部分を抽出
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSourceFile    : string;
  LHomeDirectory : string;
  LIHTMLDoc2     : IHTMLDocument2;
  LIndex         : Integer;
  LElementColl   : IHTMLElementCollection;
  LElement       : IHTMLElement;
  LListLinkURL   : TStringList;
  LValue         : string;
begin
  LSourceFile := Edit1.Text;

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

  // URL からホームディレクトリ名と IHTMLDocument2 のドキュメントを取得
  if URLtoIHTMLDoc2(LSourceFile, LHomeDirectory, LIHTMLDoc2) then begin
    LListLinkURL := TStringList.Create;
    try
      //これ以降が実際のHTMLの解析
      LElementColl := LIHTMLDoc2.all;
      for LIndex := 0 to LElementColl.length - 1 do begin
        LElement := LElementColl.item(LIndex, '') as IHTMLElement;
        if LElement.tagName = 'A' then begin
          // タグが A の中のhref属性の値を取り出す
          LValue := LElement.getAttribute('href', 0);
          if Trim(LValue) <> '' then begin
            // 相対パスには先頭に about: という文字が付加されるらしい
            // これを置き換える
            LValue := StringReplace(LValue, 'about:/', LHomeDirectory, [rfIgnoreCase]);
            LValue := StringReplace(LValue, 'about:', LHomeDirectory, [rfIgnoreCase]);
            //リストに追加
            LListLinkURL.Add(LValue);
          end;
        end;
        Application.ProcessMessages;
      end;

      // 重複した URL を除外する
      CheckDuplicateItems(LListLinkURL);
      Memo1.Text := LListLinkURL.Text;
    finally
      FreeAndNil(LListLinkURL);
    end;
  end;
  LIHTMLDoc2 := nil;
end;

//-----------------------------------------------------------------------------
//  HTML コードから IHTMLDocument2 のドキュメントを取得
//  ここでは実際のウェブページから HTML コードを取得
//
//  AStrURL      : 対象のページのアドレス
//  ASiteHomeDir : 対象のページのアドレスの[プロトコル+ホスト名]の値
//                 この値がホームディレクトリ
//  IDoc2        : IHTMLDocument2 オブジェクト (呼び出し側で生成しておく)
//-----------------------------------------------------------------------------
function TForm1.URLtoIHTMLDoc2(AStrURL: string; var ASiteHomeDir: string;
  IDoc2: IHTMLDocument2): Boolean;
var
  LHtmlCode : TStringList;
  LOleArray : Variant;
begin
  Result  := True;
  ASiteHomeDir := '';
  IdHTTP1.HandleRedirects := True;

  //T IdHTTP でL SourceFile のページの HTML コードを TStringList に格納
  LHtmlCode := TStringList.Create;
  try
    try
      LHtmlCode.Text := IdHTTP1.Get(AStrURL);
      // プロトコルとホスト名を取得しておく．この値がホームディレクトリ
      ASiteHomeDir := IdHTTP1.URL.Protocol + '://' + IdHTTP1.URL.Host + '/';
    except
      Result := False;
    end;
    IdHTTP1.Disconnect;
    if not Result then exit;


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

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

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

      // 念のため readState が loading の間待つ
      while IDoc2.readyState = 'loading' do begin
        Application.ProcessMessages;
      end;
    finally
      VarArrayUnLock(LOleArray);
      VarClear(LOleArray);
    end;
  finally
    FreeAndNil(LHtmlCode);
  end;
end;

//-----------------------------------------------------------------------------
//  リスト内の重複した文字列を削除するルーチン
//  uses に Generics.Collections が必要
//-----------------------------------------------------------------------------
procedure TForm1.CheckDuplicateItems(AList: TStringList);
var
  LListDic  : TDictionary<String,TObject>;
  LListTemp : TStringList;
  LIndex    : Integer;
begin
  // 重複した URL を除外してTMemo に追加していく
  LListDic  := TDictionary<String, TObject>.Create;
  LListTemp := TStringList.Create;
  try
    LListTemp.Text := AList.Text;
    AList.Clear;
    for LIndex := 0 to LListTemp.Count - 1 do begin
      if LListDic.ContainsKey(LListTemp[LIndex]) = False then begin
        LListDic.Add(LListTemp[LIndex], nil);
        AList.Add(LListTemp[LIndex]);
      end;
    end;
  finally
    FreeAndNil(LListDic);
    FreeAndNil(LListTemp);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses 
  MSHTML,
  ComObj;

{$R *.dfm}

//=============================================================================
//  htmlfile という OLE オブジェクトのテスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  HTMLDoc : OleVariant;
  LText   : string;
begin
  HTMLDoc := CreateOleObject('htmlfile');

  LText := '<html><head><title>タイトル</title></head><body>ボディ</body></html>';
  HTMLDoc.write(LText);

  LText := HTMLDoc.FirstChild.outerHTML;
  // LText := HTMLDoc.body.parentElement.outerHTML;でも同じ
  ShowMessage(LText);

  LText := HTMLDoc.Title;
  ShowMessage(LText);

  LText := HTMLDoc.body.outerText;
  ShowMessage(LText);

  HTMLDoc := Unassigned;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    function ToAbsoluteURLPath(ATargetURL, ARelativeURL: string): string;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses 
  IdURI,
  IOUtils,
  StrUtils;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/plSamples/949_ParseHTML.htm';
  Edit2.Text := '../AAA.txt';
end;

//=============================================================================
//  下の関数のテスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LLinkFullPath : String;
begin
  Memo1.Lines.Clear;
  LLinkFullPath := ToAbsoluteURLPath(Edit1.Text, Edit2.text);
  Memo1.Lines.Add(LLinkFullPath);
end;

//-----------------------------------------------------------------------------
//  HTML コード内のリンクの相対 URL を絶対 URL に変換する関数
//
//  ATargetURL   : ウェブページのアドレス
//                 ディレクトリ名の場合は，末尾にデリミタ (/) が必要
//                 / がなければファイル名と見なす
//  ARelativeURL : 絶対パスを取得したい相対パス名 (絶対パスでもよい)
//  戻り値         相対パスを絶対パスに変換した値
//                 サイト外のアドレスの時は，元の RelativeURL のまま
//                 ページ内のリンクもそのまま (先頭が #)
//-----------------------------------------------------------------------------
function TForm1.ToAbsoluteURLPath(ATargetURL, ARelativeURL: string): string;
var
  LBaseDir       : string;
  LProtocol      : string;
  LRelativeURL   : string;
  LIdURL         : TIdURI;
  LHomeDirectory : string;
begin
  Result       := '';
  LBaseDir     := ATargetURL;
  LRelativeURL := ARelativeURL;
  if LBaseDir = '' then exit;
  if LRelativeURL = '' then exit;

  // ホームディレクトリの URL を取得しておく
  LIdURL := TIdURI.Create(ATargetURL);
  try
    LProtocol      := LIdURL.Protocol + ':';
    LHomeDirectory := LIdURL.Protocol + '://' + LIdURL.Host;
  finally
    FreeAndNil(LIdURL);
  end;


  // ホームディレクトリの URL が含まれていればすでに絶対バスと見なす
  if ContainsText(LRelativeURL, LHomeDirectory) 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 := LProtocol + LRelativeURL;
    end else
    // 先頭が [/] の時はサイトルート相対パス
    if (LeftStr(LRelativeURL, 1) = '/') then begin
      Insert(LHomeDirectory, LRelativeURL, 1);
      Result := LRelativeURL;
    end else
    // [./] は同じディレクトリ内を明示的に表す時の記述
    if (LeftStr(LRelativeURL, 2) = './') then begin
      Delete(LRelativeURL, 1, 2);
      Result := LRelativeURL;
    end else begin
      //[../]がない場合は同じディレクトリまたは他のサイトへのリンク
      if not ContainsText(LRelativeURL, '../') then begin
        // [://] という文字列があれば他のサイトと見なす
        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, LHomeDirectory) then begin
          Result := LBaseDir + LRelativeURL;
        end;
      end;
    end;
  end;
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, ExtCtrls, MSHTML;

type
  TForm1 = class(TForm)
    IdHTTP1: TIdHTTP;
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    function URLtoIHTMLDoc2(AStrURL: string; var ASiteHomeDir: string;
      IDoc2: IHTMLDocument2): Boolean;
    function ToAbsoluteURLPath(ATargetURL, ARelativeURL: string): string;
    procedure CheckDuplicateItems(AList: TStringList);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ComObj, ActiveX, IdURI, IOUtils, StrUtils, Generics.Collections;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/plSamples/003_StopWatch.htm';
end;

//=============================================================================
//  HTMLコードから
//    他のページへのリンク部分
//    使用しているスタイルシート，JavaScript ファイル等の場所
//  を取得して表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSourceFile    : string;
  LHomeDirectory : string;
  LIHTMLDoc2     : IHTMLDocument2;
  i              : Integer;
  LElementColl   : IHTMLElementCollection;
  LElement       : IHTMLElement;
  LListLinkURL   : TStringList;
  LValue         : string;
begin
  Memo1.Lines.Clear;
  LSourceFile := Edit1.Text;
  Screen.Cursor := crHourGlass;

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

  // URL からホームディレクトリ名と IHTMLDocument2 のドキュメントを取得
  if URLtoIHTMLDoc2(LSourceFile, LHomeDirectory, LIHTMLDoc2) then begin

    LListLinkURL := TStringList.Create;
    try
      // これ以降が実際の HTML の解析
      LElementColl := LIHTMLDoc2.all;

      for i := 0 to LElementColl.length - 1 do begin
        LElement := LElementColl.item(i, '') as IHTMLElement;

        LValue := '';
        // 指定タグ名の指定属性の値を取り出す
        if LElement.tagName = 'FRAME' then begin
          LValue := LElement.getAttribute('src', 0);
        end else
        if LElement.tagName = 'IFRAME' then begin
          LValue := LElement.getAttribute('src', 0);
        end else
        if LElement.tagName = 'BODY' then begin
          LValue := LElement.getAttribute('BACKGROUND', 0);
        end else
        if LElement.tagName = 'LINK' then begin
          LValue := LElement.getAttribute('href', 0);
        end else
        if LElement.tagName = 'SCRIPT' then begin
          LValue := LElement.getAttribute('src', 0);
        end else
        if LElement.tagName = 'A' then begin
          LValue := LElement.getAttribute('href', 0);
        end else
        if LElement.tagName = 'IMG' then begin
          LValue := LElement.getAttribute('src', 0);
        end;

        if LValue <> '' then begin
          // 相対 URL を絶対 URL に変換
          if CheckBox1.Checked then begin
            LValue := ToAbsoluteURLPath(LSourceFile, LValue);
          end;

          // ページ内のリンクと.cgi ファイルは除外
          if LeftStr(LValue, 1) <> '#' then begin
            if not ContainsText(LValue, '.cgi') then begin
              // リストに追加
              LListLinkURL.Add(LValue);
            end;
          end;
        end;
        Application.ProcessMessages;
      end;

      if LListLinkURL.Count = 0 then begin
        Memo1.Text := 'リンク情報なし';
      end else begin
        // 重複している URL を取得したリストから削除
        CheckDuplicateItems(LListLinkURL);
        Memo1.Text := LListLinkURL.Text;
      end;
    finally
      FreeAndNil(LListLinkURL);
    end;
  end;

  LIHTMLDoc2 := nil;
  Screen.Cursor := crDefault;
end;

unit UnitIE;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    WebBrowser1: TWebBrowser;
    Splitter1: TSplitter;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    procedure CheckDuplicateItems(AList: TStringList);
    function ToAbsoluteURLPath(ATargetURL, ARelativeURL: string): string;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  IOUtils,
  IdURI,
  StrUtils,
  Generics.Collections;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text := 'http://mrxray.on.coocan.jp/Delphi/plSamples/003_StopWatch.htm';
end;

//=============================================================================
//  ウェブページをオンラインで表示中に，そのページのHTMLコードから
//    他のページへのリンク部分
//    使用しているスタイルシート，JavaScriptファイル等の場所
//  を取得して表示
//
//  (1) getAttributeの第2引数の値が0の時と4の場合のテスト
//  (2) 相対 URL を絶対 URL に変換した場合のテスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LSourceFile  : string;
  LIHTMLDoc2   : IHTMLDocument2;
  i            : Integer;
  LElementColl : IHTMLElementCollection;
  LElement     : IHTMLElement;
  LListLinkURL : TStringList;
  LValue       : string;
  LIFlags      : Integer;
begin
  Memo1.Lines.Clear;
  LSourceFile := Edit1.Text;

  if CheckBox1.Checked then begin
    LIFlags := 4;
  end else begin
    LIFlags := 0;
  end;

  // ウェブページを TWebBrowse で表示
  WebBrowser1.Navigate(LSourceFile);

  // 生成完了まで待つ
  while WebBrowser1.ReadyState < READYSTATE_INTERACTIVE do begin
    Application.ProcessMessages;
    Sleep(1);
  end;

  // IHTMLDocument2 オブジェクトを取得
  if Assigned(WebBrowser1.Document) then begin
    LIHTMLDoc2 := WebBrowser1.Document as IHTMLDocument2;

    // 念のためreadStateが complete になるまで待つ
    // ブラウザでない場合は = 'loading' でないと永久ループになる
    while LIHTMLDoc2.readyState <> 'complete' do begin
      Application.ProcessMessages;
      Sleep(1);
    end;

    LListLinkURL := TStringList.Create;
    try
      // これ以降が実際の HTML の解析
      LElementColl := LIHTMLDoc2.all;

      for i := 0 to LElementColl.length - 1 do begin
        LElement := LElementColl.item(i, '') as IHTMLElement;

        LValue := '';
        // 指定タグ名の指定属性の値を取り出す
        if LElement.tagName = 'FRAME' then begin
          LValue    := LElement.getAttribute('src', LIFlags);
        end else
        if LElement.tagName = 'IFRAME' then begin
          LValue := LElement.getAttribute('src', LIFlags);
        end else
        if LElement.tagName = 'BODY' then begin
          LValue := LElement.getAttribute('background', LIFlags);
        end else
        if LElement.tagName = 'LINK' then begin
          LValue := LElement.getAttribute('href', LIFlags);
        end else
        if LElement.tagName = 'SCRIPT' then begin
          LValue := LElement.getAttribute('src', LIFlags);
        end else
        if LElement.tagName = 'A' then begin
          LValue := LElement.getAttribute('href', LIFlags);
        end else
        if LElement.tagName = 'IMG' then begin
          LValue := LElement.getAttribute('src', LIFlags);
        end;

        if LValue <> '' then begin
          // 相対 URL を絶対 URL に変換
          if CheckBox2.Checked then begin
            LValue := ToAbsoluteURLPath(LSourceFile, LValue);
          end;

          // ページ内のリンクと .cgi ファイルは除外
          if not (LeftStr(LValue, 1) = '#') then begin
            if not ContainsText(LValue, '.cgi') then begin
              // リストに追加
              LListLinkURL.Add(LValue);
            end;
          end;
        end;
        Application.ProcessMessages;
      end;

      if LListLinkURL.Count = 0 then begin
        Memo1.Text := 'リンク情報なし';
      end else begin
        // 重複している URL を取得したリストから削除
        CheckDuplicateItems(LListLinkURL);
        Memo1.Text := LListLinkURL.Text;
      end;
    finally
      FreeAndNil(LListLinkURL);
    end;
  end;

  LIHTMLDoc2 := nil;
end;