Delphi提取网页源文件纯文本函数如何实现？-网页设计-锦华智联科技

Delphi 提取网页源文件纯文本函数

以下是一个 Delphi 函数，用于从网页源代码中提取纯文本内容（去除所有 HTML 标签）：

（图片来源网络，侵删）

function ExtractPlainTextFromHTML(const HTML: string): string;
var
  i, Len: Integer;
  InTag: Boolean;
begin
  Result := '';
  Len := Length(HTML);
  InTag := False;
  for i := 1 to Len do
  begin
    if HTML[i] = '<' then
      InTag := True
    else if HTML[i] = '>' then
      InTag := False
    else if not InTag then
      Result := Result + HTML[i];
  end;
  // 处理连续的空白字符
  Result := StringReplace(Result, #13#10, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #13, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #10, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #9, ' ', [rfReplaceAll]);
  while Pos('  ', Result) > 0 do
    Result := StringReplace(Result, '  ', ' ', [rfReplaceAll]);
  // 去除首尾空白
  Result := Trim(Result);
end;

使用示例

var
  HTMLSource: string;
  PlainText: string;
begin
  HTMLSource := '<html><head><title>测试页面</title></head>' +
                '<body><h1>欢迎</h1><p>这是一个<b>测试</b>页面。</p></body></html>';
  PlainText := ExtractPlainTextFromHTML(HTMLSource);
  ShowMessage(PlainText); // 显示: "欢迎 这是一个测试页面。"
end;

更高级的实现（处理HTML实体）

如果需要处理HTML实体（如  , < 等）,可以使用以下改进版本：

function ExtractPlainTextFromHTMLAdvanced(const HTML: string): string;
var
  i, Len: Integer;
  InTag: Boolean;
  EntityStart: Integer;
begin
  Result := '';
  Len := Length(HTML);
  InTag := False;
  EntityStart := 0;
  for i := 1 to Len do
  begin
    if HTML[i] = '<' then
    begin
      InTag := True;
      // 处理可能的实体
      if (EntityStart > 0) and (i > EntityStart + 1) then
      begin
        Result := Result + Copy(HTML, EntityStart, i - EntityStart);
        EntityStart := 0;
      end;
    end
    else if HTML[i] = '>' then
    begin
      InTag := False;
      // 处理可能的实体
      if (EntityStart > 0) and (i > EntityStart + 1) then
      begin
        Result := Result + Copy(HTML, EntityStart, i - EntityStart);
        EntityStart := 0;
      end;
    end
    else if (HTML[i] = '&') and (not InTag) then
    begin
      // 开始记录实体
      if EntityStart = 0 then
        EntityStart := i;
    end
    else if (HTML[i] = ';') and (EntityStart > 0) then
    begin
      // 结束实体，替换为对应字符
      Result := Result + HTMLDecode(Copy(HTML, EntityStart, i - EntityStart + 1));
      EntityStart := 0;
    end
    else if not InTag then
    begin
      // 处理可能的实体
      if (EntityStart > 0) and (i > EntityStart + 1) then
      begin
        Result := Result + Copy(HTML, EntityStart, i - EntityStart);
        EntityStart := 0;
      end;
      Result := Result + HTML[i];
    end;
  end;
  // 处理剩余的实体
  if EntityStart > 0 then
    Result := Result + Copy(HTML, EntityStart, Len - EntityStart + 1);
  // 处理连续的空白字符
  Result := StringReplace(Result, #13#10, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #13, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #10, ' ', [rfReplaceAll]);
  Result := StringReplace(Result, #9, ' ', [rfReplaceAll]);
  while Pos('  ', Result) > 0 do
    Result := StringReplace(Result, '  ', ' ', [rfReplaceAll]);
  // 去除首尾空白
  Result := Trim(Result);
end;

注意事项

这些函数只是简单地移除HTML标签，对于复杂的HTML结构可能不够完善
如果需要更精确的HTML解析，建议使用专门的HTML解析器组件，如:
TWebBrowser (内置组件) -tidylib (第三方库) -IXMLDocument (XML解析器,可处理XHTML)
对于网页抓取，还可以考虑使用 Indy 的 TIdHTTP 组件获取网页源码

使用TWebBrowser的替代方案

如果需要从已加载的网页中提取纯文本,可以使用TWebBrowser的DocumentComplete事件：

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  Doc: IHTMLDocument2;
  TextRange: ITextRange;
begin
  Doc := WebBrowser1.Document as IHTMLDocument2;
  if Assigned(Doc) then
  begin
    TextRange := Doc.body.createTextRange;
    if Assigned(TextRange) then
    begin
      Memo1.Text := TextRange.text;
    end;
  end;
end;

（图片来源网络，侵删）