xhtml.pas

我自己用的Delphi函数单元 具体说明见打包文件的HELP目录下面

unit xHtml;

interface

uses Windows, SysUtils, Graphics;

//------------------------------------------------------------------//
function GetHtmlBold(s: String): string;
function GetHtmlItalic(s: String): string;
function GetHtmlQuotes(s: string): string;
function GetHtmlLink(URL, Name: string): string;
function GetHtmlMailTo(Address, Name: string): string;
function GetHtmlParameters(s: string): string;
function GetHtmlText(s:string):string;

//------------------------------------------------------------------//
function SpacesToPluses(s: string): string;

//------------------------------------------------------------------//
function GetHtmlColorValue(S: String): TColor;
function GetHtmlColorString(Color: TColor): string;


implementation

//------------------------------------------------------------------//
//取得粗体文本
function GetHtmlBold(s: String): string;
begin
   Result := Format('<B>%s</B>', [s]);
end;

//------------------------------------------------------------------//
//取得斜体文本
function GetHtmlItalic(s: String): string;
begin
   Result := Format('<I>%s</I>', [s]);
end;

//------------------------------------------------------------------//
//取得引号文本
function GetHtmlQuotes(s: string): string;
begin
  Result := Format('"%s"', [s]);
end;

//------------------------------------------------------------------//
//取得链接
function GetHtmlLink(URL, Name: string): string;
begin
  Result := Format('<A HREF=%s>%s</A>', [GetHtmlQuotes(URL), Name]);
end;

//------------------------------------------------------------------//
//取得邮件链接
function GetHtmlMailTo(Address, Name: string): string;
begin
  Result := Format('<A HREF="MAILTO:%s">%s</A>', [Address, Name]);
end;

//------------------------------------------------------------------//
//取得参数
function GetHtmlParameters(s: string): string;
begin
  Result := GetHtmlQuotes(SpacesToPluses(s));
end;

//------------------------------------------------------------------//
//取得纯文本，删除HTML标记，例如：
//GetHtmlText('<TR><TD Align="center">Hello World</TD>') = 'Hello World'
function GetHtmlText(s:string):string;
var
    i:integer;
begin
    i:=1;
    Result:='';
    while i<=length(s) do
    begin
      if s[i]='<' then
         repeat
            inc(i);
         until (s[i]='>')
      else Result:=Result+s[i];
      inc(i);
    end;
end;

//------------------------------------------------------------------//
//空白符转换为加号，用于URL传递。
function SpacesToPluses(s: string): string;
var
  i: Integer;
begin
  for i := 1 to Length(s) do
  begin
    if s[i] = ' ' then s[i] := '+';
  end;
  Result := s;
end;

//------------------------------------------------------------------//
//HTML的RGB颜色字符串转换为颜色值
function GetHtmlColorValue(S: String): TColor;
var
   Red, Green, Blue: LongInt;
begin
   Red := StrToInt('$' + Copy(S, 1, 2));
   Green := StrToInt('$' + Copy(S, 3, 2));
   Blue := StrToInt('$' + Copy(S, 5, 2));
   Result := (Blue shl 16) + (Green shl 8) + Red;
end;

//------------------------------------------------------------------//
//颜色值转换为HTML的RGB颜色字符串
function GetHtmlColorString(Color: TColor): string;
begin
  Result := IntToHex(ColorToRGB(Color), 6);
  Result := Copy(Result, 5, 2) + Copy(Result, 3, 2) + Copy(Result, 1, 2);
end;

end.