teehtml.pas

第三方控件：PaintGrid.pas 网格型仪表控件源文件 Mymeter.pas 圆型仪表控件源文件 Project1是这两个控件的使用范例。 该

{**********************************************}
{   Html Text mini-parser.                     }
{   Copyright (c) 2004-2005 by David Berneda   }
{   All Rights Reserved                        }
{**********************************************}
unit TeeHtml;
{$I TeeDefs.inc}

interface

uses
  Classes,
  {$IFDEF CLX}
  QGraphics,
  {$ELSE}
  Graphics,
  {$ENDIF}
  {$IFDEF CLR}
  System.IO,
  {$ENDIF}
  TeCanvas;

type
  TSize=packed record
    Width  : Integer;
    Height : Integer;
  end;

// Used by TTeeCanvas class at TeCanvas.pas unit.
procedure HtmlTextOut(ACanvas:TTeeCanvas; x,y:Integer; Text:String);
function HtmlTextExtent(ACanvas:TTeeCanvas; const Text:String):TSize;

// Pseudo-Internal hooks
var
  GraphicFileExtension : function(const FileExtension:String):TGraphic;
  GraphicDownload : function(const URL:String; Stream:TStream):Integer;

implementation

uses {$IFNDEF LINUX}
     Windows,
     {$ENDIF}
     SysUtils,
     TeeProcs, TeEngine;

const
  CRLF=#$D#$A;

var State,
    StateFont : TStringList;

type
  HtmlParserException=class(Exception);

{ returns number of sections in St string separated by ";" }
Function HtmlNumFields(St:String):Integer;
var i : Integer;
begin
  result:=0;

  repeat
    i:=Pos('=',St);
    if i>0 then
    begin
      Delete(St,1,i);
      Inc(result);
    end;
  until i=0;
end;

procedure HtmlField(s:String; Index:Integer; var left,right:String);
var i,i2,num : Integer;
begin
  left:='';
  right:='';
  num:=0;

  repeat
    i:=Pos('=',s);
    if i>0 then
    begin
      left:=Trim(Copy(s,1,i-1));
      Delete(S,1,i);
      Inc(num);

      if num=Index then
      begin
        i:=Pos('=',s);
        if i=0 then right:=Trim(s)
        else
        begin
          Dec(i);
          while Copy(s,i,1)<>' ' do Dec(i);
          right:=Trim(Copy(s,1,i-1));
          i:=0;
        end;
      end
      else
      begin
        i2:=Pos('=',s);

        if i2=0 then s:=''
        else
        begin
          Dec(i2);
          while Copy(s,i2,1)<>' ' do Dec(i2);
          Delete(s,1,i2);
        end;
      end;
    end;
  until i=0;
end;

procedure PushState(const s:String);
begin
  State.Add(s);
end;

procedure PushFont(const s:String);
begin
  StateFont.Add(s);
end;

function PopState:String;
begin
  if State.Count=0 then result:=''
  else
  begin
    result:=State.Strings[State.Count-1];
    State.Delete(State.Count-1);
  end;
end;

function PopFont:String;
begin
  if StateFont.Count=0 then result:=''
  else
  begin
    result:=StateFont.Strings[StateFont.Count-1];
    StateFont.Delete(StateFont.Count-1);
  end;
end;

function InternalHtmlText(ACanvas:TTeeCanvas; x,y:Integer; Text:String; Display:Boolean):TSize;

 function GetToken(var st:String):String;
 var i : Integer;
 begin
   i:=Pos('<',st);
   if i=0 then
   begin
     result:=st;
     st:='';
   end
   else
   if i>1 then
   begin
     result:=Copy(st,1,i-1);
     Delete(st,1,i-1);
   end
   else
   begin
     Delete(st,1,1);
     i:=Pos('>',st);

     if i=0 then
        Raise HtmlParserException.Create('Missing > at '+st)
     else
     begin
       result:='<'+Copy(st,1,i);
       Delete(st,1,i);
     end;
   end;
 end;

var
  PushedFont:Boolean;

  procedure PushCurrentFont;

    Function FontWeight:String;
    begin
      if fsBold in ACanvas.Font.Style then result:='BOLD' else result:='';

      if fsItalic in ACanvas.Font.Style then
         if result='' then result:='ITALIC' else result:=result+', ITALIC';

      if fsUnderline in ACanvas.Font.Style then
         if result='' then result:='UNDERLINE' else result:=result+', UNDERLINE';

      if fsStrikeout in ACanvas.Font.Style then
         if result='' then result:='STRIKE' else result:=result+', STRIKE';

      if result='' then result:='NORMAL';
    end;

  begin
    PushFont('<FONT size='+IntToStr(ACanvas.Font.Size)+' name='+ACanvas.Font.Name+
      ' color='+IntToStr(ACanvas.Font.Color)+' weight='+FontWeight+'>');

    PushedFont:=True;
  end;

  Function HexToColor(S:String):TColor;
  begin
    S:=Trim(S);

    if Copy(s,1,1)='#' then
       result:=RGB(StrToInt('$'+Copy(s,2,2)),
                   StrToInt('$'+Copy(s,4,2)),
                   StrToInt('$'+Copy(s,6,2)))
    else
       result:=clTeeColor;
  end;

  function HtmlToColor(s:String):TColor;
  begin
    s:=Trim(UpperCase(s));

    if s='BLACK' then result:=clBlack else
    if s='RED' then result:=clRed else
    if s='BLUE' then result:=clBlue else
    if s='YELLOW' then result:=clYellow else
    if s='WHITE' then result:=clWhite else
    if s='GREEN' then result:=clGreen else
    if s='LIME' then result:=clLime else

    if Copy(s,1,1)='#' then
       result:=HexToColor(s)
    else
       result:=StringToColor(s);
  end;

  // <font name="Arial" family="Arial" size=+4 weight=bold color=#12285c  >
  procedure ProcessFont(s:String);
  var t,i:Integer;
      tmpSize, Left, Right:String;
  begin
    Delete(s,1,6);
    Delete(s,Length(s),1);

    i:=HtmlNumFields(s);
    for t:=1 to i do
    begin
      HtmlField(s,t,left,right);

      left:=UpperCase(left);

      if (left='NAME') or (left='FAMILY') then ACanvas.Font.Name:=right
      else
      if left='SIZE' then
      begin
        tmpSize:=Copy(right,1,1);

        if (tmpSize='+') or (tmpSize='-') then
           ACanvas.Font.Size:=ACanvas.Font.Size+StrToInt(right)
        else
           ACanvas.Font.Size:=StrToInt(right)
      end
      else
      if left='COLOR' then ACanvas.Font.Color:=HtmlToColor(right)
      else
      if left='WEIGHT' then
      begin
        right:=UpperCase(Right);

        if right='BOLD' then ACanvas.Font.Style:=[fsBold] else
        if right='ITALIC' then ACanvas.Font.Style:=[fsItalic] else
        if right='NORMAL' then ACanvas.Font.Style:=[] else
        if right='STRIKE' then ACanvas.Font.Style:=[fsStrikeOut] else
        if right='UNDERLINE' then ACanvas.Font.Style:=[fsUnderline]
        else
          raise Exception.Create('Unknown field in FONT WEIGHT='+right);
      end
      else
          raise Exception.Create('Unknown field in FONT: '+left);
    end;
  end;

var
  OldX : Integer;
  IsCenter : Boolean;
  MaxSizeY : Integer;

  function DoStringReplace(const S, OldPattern, NewPattern: string): string;
  var
    SearchStr, Patt, NewStr: string;
    Offset: Integer;
  begin
    SearchStr := S;
    Patt := OldPattern;
    NewStr := S;
    Result := '';

    while SearchStr <> '' do
    begin
      Offset := Pos(Patt, SearchStr);
      if Offset = 0 then
      begin
        Result := Result + NewStr;
        Break;
      end;

      Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
      NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
      SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
    end;
  end;

  procedure OutputText(tmp:String);
  var HasReturn : Boolean;
      SizeY,
      SizeX     : Integer;
  begin
    // Pending: more special characters
    tmp:=DoStringReplace(tmp,'&lt;','<');
    tmp:=DoStringReplace(tmp,'&gt;','>');
    tmp:=DoStringReplace(tmp,'&amp;','&');
    tmp:=DoStringReplace(tmp,'&quot;','"');

    HasReturn:=Copy(tmp,Length(tmp)-1,2)=CRLF;
    if HasReturn then
       Delete(tmp,Length(tmp)-1,2);

    if tmp<>'' then
    begin
      SizeX:=ACanvas.TextWidth(tmp);

      if IsCenter then
      begin
        x:=(ACanvas.Bounds.Left+ACanvas.Bounds.Right) div 2;
        x:=x-(SizeX div 2);
      end;

      SizeY:=ACanvas.TextHeight(tmp);

      if MaxSizeY=0 then
      begin
        MaxSizeY:=ACanvas.FontHeight;
        Inc(y,MaxSizeY);
      end
      else
      if SizeY<MaxSizeY then
         Inc(y,MaxSizeY-SizeY-1);

      if Display then
         ACanvas.TextOut(x,y,tmp);

      Inc(x,SizeX);