teehtml.pas

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

      if x>result.Width then
         result.Width:=x;

      if SizeY>MaxSizeY then
         MaxSizeY:=SizeY;

      if MaxSizeY>result.Height then
         result.Height:=MaxSizeY;
    end;

    if HasReturn then
    begin
      MaxSizeY:=0;
      x:=OldX;
    end;
  end;

  procedure SetBackFont;
  begin
    ProcessFont(PopFont)
  end;

  procedure ImageNotFound(x,y,Width,Height:Integer);
  begin
    if Width=0 then Width:=40;
    if Height=0 then Height:=40;

    with ACanvas do
    begin
      Pen.Style:=psSolid;
      Pen.Color:=clRed;
      Pen.Width:=1;
      Brush.Style:=bsSolid;
      Brush.Color:=clWhite;
      Rectangle(x,y,x+Width,y+Height);

      MoveTo(x,y);
      LineTo(x+Width-1,y+Height-1);
      MoveTo(x,y+Height-1);
      LineTo(x+Width-1,y);
    end;
  end;

  procedure DoImage(tmpU:String);

    function RemoveQuotes(const S:String):String;
    var l : Integer;
    begin
      result:=S;
      if Copy(result,1,1)='"' then
         Delete(result,1,1);
      l:=Length(result);
      if Copy(result,l,1)='"' then
         Delete(result,l,1);
    end;

  var i,t,
      tmpW,
      tmpH  : Integer;
      tmpURL,
      Left,
      Right : String;
      {$IFDEF URLDEBUG}
      tmpSt : TStringList;
      {$ENDIF}
      tmpS  : TMemoryStream;
      g     : TGraphic;
      tmpOk : Integer;
  begin
    tmpW:=0;
    tmpH:=0;
    tmpURL:='';

    Delete(tmpU,1,5);

    if Copy(tmpU,1,2)=CRLF then
       Delete(tmpU,1,2);

    if Copy(tmpU,Length(tmpU),1)='>' then
       Delete(tmpU,Length(tmpU),1);

    i:=HtmlNumFields(tmpU);
    for t:=1 to i do
    begin
      HtmlField(tmpU,t,left,right);
      left:=UpperCase(left);
      if left='WIDTH' then tmpW:=StrToInt(Right) else
      if left='HEIGHT' then tmpH:=StrToInt(Right) else
      if left='SRC' then tmpURL:=Right; // more img attribs ?
    end;

    if tmpURL<>'' then
    begin
      tmpURL:=RemoveQuotes(Trim(tmpURL));

      tmpS:=TMemoryStream.Create;
      try
        left:=UpperCase(ExtractFileExt(tmpURL));

        g:=GraphicFileExtension(Left);

        if not Assigned(g) then
        begin
          ImageNotFound(x,y,tmpW,tmpH);
          exit;
        end;

        try
          tmpOk:=GraphicDownload(tmpURL,tmpS);

          if (tmpOk=0) and (tmpS.Size>0) then
          begin
            tmpS.Position:=0;

            try
              {$IFDEF URLDEBUG}
              tmpSt:=TStringList.Create;
              tmpSt.LoadFromStream(tmpS);
              {$ENDIF}

              g.LoadFromStream(tmpS);

              {$IFDEF URLDEBUG}
              tmpSt.Free;
              {$ENDIF}

              if tmpW=0 then tmpW:=g.Width;
              if tmpH=0 then tmpH:=g.Height;

              if (tmpW<>g.Width) or (tmpH<>g.Height) then
                 ACanvas.StretchDraw(TeeRect(x,y,x+tmpW,y+tmpH),g)
              else
                 ACanvas.Draw(x,y,g);

              Inc(x,tmpW);
              Inc(y,tmpH);
            except
              on Exception do ImageNotFound(x,y,tmpW,tmpH);
            end;
          end
          else ImageNotFound(x,y,tmpW,tmpH);
        finally
          g.Free;
        end;
      finally
        tmpS.Free;
      end;
    end;
  end;

var
  IsLastFont : Boolean;

  procedure DoToken(tmp:String);

    procedure NewSize(ASize:Integer);
    begin
      PushCurrentFont;
      ACanvas.Font.Size:=ASize;
    end;

  var tmpU,tmpS : String;
  begin
    PushedFont:=False;

    if Copy(tmp,1,2)=CRLF then
    begin
      Inc(y,ACanvas.FontHeight);
      x:=OldX;
      MaxSizeY:=0;

      Delete(tmp,1,2);
    end;

    if tmp='' then exit;

    tmpU:=UpperCase(tmp);


    if (tmpU='<BR>') or (tmpU='<P>') then  // Paragraphs here !!
    begin
      x:=OldX;
      MaxSizeY:=0;
      Inc(y,ACanvas.FontHeight);
    end
    else
    if tmpU='<BIG>' then
       NewSize(ACanvas.Font.Size+2)
    else
    if tmpU='<SMALL>' then
       NewSize(ACanvas.Font.Size-2)
    else
    if tmpU='</SUB>' then
    begin
      SetBackFont;
      Dec(y,ACanvas.FontHeight);
    end
    else
    if tmpU='<SUB>' then
    begin
      NewSize(ACanvas.Font.Size div 2);
      Inc(y,ACanvas.FontHeight);
    end
    else
    if tmpU='</SUPER>' then
    begin
      SetBackFont;
      Inc(y,ACanvas.FontHeight div 2);
    end
    else
    if tmpU='<SUPER>' then
    begin
      NewSize(ACanvas.Font.Size div 2);
      Dec(y,ACanvas.FontHeight div 2);
    end
    else
    if tmpU='<H1>' then NewSize(48) else
    if tmpU='<H2>' then NewSize(36) else
    if tmpU='<H3>' then NewSize(24) else
    if tmpU='<H4>' then NewSize(18) else
    if tmpU='<H5>' then NewSize(12) else
    if tmpU='<H6>' then NewSize(8) else

//      if tmpU='<BLINK>' then ...
//      else
    if tmpU='<PRE>' then
    begin
      PushCurrentFont;
      ProcessFont('<FONT NAME="COURIER NEW">');
    end
    else
    if tmpU='<CENTER>' then
       IsCenter:=True
    else
    if (tmpU='<B>') or (tmpU='<BOLD>') or (tmpU='<STRONG>') then
    begin
      ACanvas.Font.Style:=ACanvas.Font.Style+[fsBold];
      PushState(tmpU);
    end
    else
    if tmpU='<I>' then
    begin
      ACanvas.Font.Style:=ACanvas.Font.Style+[fsItalic];
      PushState(tmpU);
    end
    else
    if tmpU='<U>' then
    begin
      ACanvas.Font.Style:=ACanvas.Font.Style+[fsUnderline];
      PushState(tmpU);
    end
    else
    if tmpU='<STRIKE>' then
    begin
      ACanvas.Font.Style:=ACanvas.Font.Style+[fsStrikeOut];
      PushState(tmpU);
    end
    else
    if Copy(tmpU,1,5)='<IMG ' then DoImage(tmp)
    else
    if (tmpU='</B>') or (tmpU='</BOLD>') or (tmpU='</STRONG>') then
       ACanvas.Font.Style:=ACanvas.Font.Style-[fsBold]
    else
    if tmpU='</I>' then ACanvas.Font.Style:=ACanvas.Font.Style-[fsItalic]
    else
    if tmpU='</U>' then ACanvas.Font.Style:=ACanvas.Font.Style-[fsUnderline]
    else
    if tmpU='</STRIKE>' then ACanvas.Font.Style:=ACanvas.Font.Style-[fsStrikeOut]
    else
    if Copy(tmpU,1,6)='</FONT' then
       SetBackFont // ProcessFont(tmpU)
    else
    if tmpU='</PRE>' then SetBackFont
    else
    if tmpU='</CENTER>' then IsCenter:=False
    else
    if Copy(tmpU,1,6)='<FONT ' then
    begin
      PushCurrentFont;
      ProcessFont(tmpU);
    end
    else
    if tmpU='</>' then
    begin
      if IsLastFont then SetBackFont
      else
      begin
        tmpS:=PopState;
        Delete(tmpS,1,1);
        DoToken('</'+tmpS);
      end;
    end
    else
    if tmpU='<HR>' then
    begin
      x:=OldX;

      with ACanvas.Pen do
      begin
        Style:=psSolid;
        Width:=1;
        Color:=clDkGray;
      end;

      ACanvas.DoHorizLine(x,x+100,y);  // 100 ?
      Inc(y,ACanvas.FontHeight);
    end
    else
    begin
      OutputText(tmp);
      Exit;
    end;

    IsLastFont:=PushedFont;
  end;

var tmp : String;
begin
  result.Width:=0;
  result.Height:=0;

  OldX:=X;
  IsCenter:=False;
  MaxSizeY:=ACanvas.FontHeight;

  repeat
    tmp:=GetToken(Text);
    if tmp<>'' then
       DoToken(tmp);
  until tmp='';
end;

function HtmlTextExtent(ACanvas:TTeeCanvas; const Text:String):TSize;
begin
  result:=InternalHtmlText(ACanvas,0,0,Text,False);
end;

procedure HtmlTextOut(ACanvas:TTeeCanvas; x,y:Integer; Text:String);
begin
  InternalHtmlText(ACanvas,x,y,Text,True);
end;

initialization
  State:=TStringList.Create;
  StateFont:=TStringList.Create;
finalization
  StateFont.Free;
  State.Free;
end.