rm_htmlmemo.pas

这是一个功能强大

  fsize: integer;
  fbreakLine: boolean;
  aColor, fColor: Tcolor;
  Element: TjanHTMLElement;

  procedure pushTag;
  begin
    Element := TjanHTMLElement.Create;
    element.FontName := fname;
    element.FontSize := fsize;
    element.FontStyle := fstyle;
    element.FontColor := fColor;
    Element.Sups := sup;
    Element.Subs := sub;
    TagStack.push(Element);
  end;

  procedure popTag;
  begin
    Element := TagStack.pop;
    if element <> nil then
    begin
      fname := element.FontName;
      fsize := element.FontSize;
      fstyle := element.FontStyle;
      fcolor := element.FontColor;
      Element.sups := element.sups;
      Element.subs := element.subs;
      Element.Free;
    end;
  end;

  procedure pushElement;
  begin
    Element := TjanHTMLElement.Create;
    Element.Text := ftext;
    element.FontName := fname;
    element.FontSize := fsize;
    element.FontStyle := fstyle;
    element.FontColor := fColor;
    element.BreakLine := fBreakLine;
    fBreakLine := false;
    element.sups := sup;
    sup := false;
    element.subs := sub;
    sub := false;
    ElementStack.push(Element);
  end;

  procedure parseTag(ss: string);
  var
    pp: integer;
    atag, apar, aval: string;
    havepar: boolean;
  begin
    ss := trim(ss);
    havepar := false;
    pp := pos(' ', ss);
    if pp = 0 then
    begin // tag only
      atag := ss;
    end
    else
    begin // tag + atrributes
      atag := copy(ss, 1, pp - 1);
      ss := trim(copy(ss, pp + 1, length(ss)));
      havepar := true;
    end;
    // handle atag
    atag := lowercase(atag);
    if atag = 'br' then
      fBreakLine := true
    else if atag = 'b' then
    begin // bold
      pushtag;
      fstyle := fstyle + [fsbold];
    end
    else if atag = '/b' then
    begin // cancel bold
      fstyle := fstyle - [fsbold];
      poptag;
    end
    else if atag = 'i' then
    begin // italic
      pushtag;
      fstyle := fstyle + [fsitalic];
    end
    else if atag = '/i' then
    begin // cancel italic
      fstyle := fstyle - [fsitalic];
      poptag;
    end
    else if atag = 'u' then
    begin // underline
      pushtag;
      fstyle := fstyle + [fsunderline];
    end
    else if atag = '/u' then
    begin // cancel underline
      fstyle := fstyle - [fsunderline];
      poptag;
    end
    else if atag = 'font' then
    begin
      pushtag;
    end
    else if atag = '/font' then
    begin
      poptag;
    end
    else if atag = 'sup' then
    begin
      pushtag;
      sup := true;
    end
    else if atag = '/sup' then
    begin
      sup := false;
      poptag;
    end
    else if atag = 'sub' then
    begin
      pushtag;
      sub := true;
    end
    else if atag = '/sub' then
    begin
      sub := false;
      poptag;
    end;
    if havepar then
    begin
      repeat
        pp := pos('="', ss);
        if pp > 0 then
        begin
          aPar := lowercase(trim(copy(ss, 1, pp - 1)));
          delete(ss, 1, pp + 1);
          pp := pos('"', ss);
          if pp > 0 then
          begin
            aVal := copy(ss, 1, pp - 1);
            delete(ss, 1, pp);
            if aPar = 'face' then
            begin
              fname := aVal;
            end
            else if aPar = 'size' then
            try
              fsize := strtoint(aval);
            except
            end
            else if aPar = 'color' then
            try
              if RMHTMLStringToColor(aval, aColor) then
                fcolor := aColor;
            except
            end
          end;
        end;
      until pp = 0;
    end;
  end;
begin
  ElementStack.Clear;
  TagStack.Clear;
  fstyle := [];
  fname := '宋体';
  fsize := 9;
  fColor := clblack;
  fBreakLine := false;
  sup := false;
  sub := false;
  repeat
    p := pos('<', s);
    if p = 0 then
    begin
      fText := s;
      PushElement;
    end
    else
    begin
      if p > 1 then
      begin
        se := copy(s, 1, p - 1);
        ftext := se;
        pushElement;
        delete(s, 1, p - 1);
      end;
      p := pos('>', s);
      if p > 0 then
      begin
        st := copy(s, 2, p - 2);
        delete(s, 1, p);
        parseTag(st);
      end;
    end;
  until p = 0;
end;

procedure TjanMarkupLabel.RenderHTML;
var
  R: trect;
  x, y, xav, clw: integer;
  baseline: integer;
  i, c: integer;
  el: TjanHTMLElement;
  eol: boolean;
  ml: integer; // margin left
  isol, ieol: integer;
  maxheight, maxascent: integer;
  pendingBreak: boolean;

  procedure SetFont(ee: TjanHTMLElement);
  begin
    with canvas do
    begin
      font.name := ee.FontName;
      font.Size := ee.FontSize;
      font.Style := ee.FontStyle;
      font.Color := ee.FontColor;
    end;
  end;

  procedure RenderString(ee: TjanHTMLElement);
  var
    ss: string;
    ww: integer;
    t: integer;
  begin
    t := ee.FFontSize;
    SetFont(ee);
    if ee.soltext <> '' then
    begin
      if (ee.fsups) or (ee.fsubs) then
      begin
        t := ee.FFontSize;
        ee.FFontSize := ee.FFontSize div 2;
        SetFont(ee);
      end;
      ss := ee.SolText;
      ww := canvas.TextWidth(ss);
      if ee.Subs then canvas.TextOut(x, y + baseline - ee.Ascent div 2, ss)
      else canvas.TextOut(x, y + baseline - ee.Ascent, ss);
      x := x + ww;
    end;
    if (ee.fsups) or (ee.fsubs) then
    begin
      ee.FFontSize := t;
      SetFont(ee);
    end;
  end;

begin
  R := clientrect;
  canvas.Brush.color := BackColor;
  canvas.FillRect(R);
  c := ElementStack.Count;
  if c = 0 then exit;
  HTMLClearBreaks;
  clw := ClientWidth - FMarginRight;
  ml := MarginLeft;
  canvas.Brush.style := bsclear;
  y := FMarginTop;
  isol := 0;
  pendingBreak := false;
  ieol := 0;
  repeat
    i := isol;
    xav := clw;
    maxHeight := 0;
    maxAscent := 0;
    eol := false;
    repeat // scan line
      el := TjanHTMLElement(ElementStack.items[i]);
      if el.BreakLine then
      begin
        if not pendingBreak then
        begin
          pendingBreak := true;
          ieol := i;
          break;
        end
        else
          pendingBreak := false;
      end;
      if el.Height > maxheight then maxheight := el.Height;
      if el.Ascent > maxAscent then maxAscent := el.Ascent;
      el.Break(canvas, xav);
      if el.soltext <> '' then
      begin
        xav := xav - canvas.TextWidth(el.Soltext);
        if el.EolText = '' then
        begin
          if i >= c - 1 then
          begin
            eol := true;
            ieol := i;
          end
          else
          begin
            inc(i);
          end
        end
        else
        begin
          eol := true;
          ieol := i;
        end;
      end
      else
      begin // eol
        eol := true;
        ieol := i;
      end;
    until eol;
    // render line
    x := ml;
    baseline := maxAscent;
    for i := isol to ieol do
    begin
      el := TjanHTMLElement(ElementStack.items[i]);
      RenderString(el);
    end;
    y := y + maxHeight;
    isol := ieol;
  until (ieol >= c - 1) and (el.EolText = '');
end;

procedure TjanMarkupLabel.SetBackColor(const Value: TColor);
begin
  if value <> FBackColor then
  begin
    FBackcolor := Value;
    invalidate;
  end;
end;

procedure TjanMarkupLabel.SetMarginLeft(const Value: integer);
begin
  FMarginLeft := Value;
  invalidate;
end;

procedure TjanMarkupLabel.SetMarginRight(const Value: integer);
begin
  FMarginRight := Value;
  invalidate;
end;

procedure TjanMarkupLabel.SetMarginTop(const Value: integer);
begin
  FMarginTop := Value;
  invalidate;
end;

procedure TjanMarkupLabel.SetText(const Value: string);
const
  cr = chr(13) + chr(10);
  tab = chr(9);
var
  s: string;
begin
  if value = FText then exit;
  s := value;
  s := stringreplace(s, cr, ' ', [rfreplaceall]);
  s := Trimright(s);
  parseHTML(s);
  HTMLElementDimensions;
  FText := s;
  invalidate;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMHTMLMemoView }

constructor TRMHTMLMemoView.Create;
begin
  inherited Create;
  BaseName := 'HTMLMemo';
  Elementstack := THTMLElementStack.Create;
  TagStack := THTMLElementStack.Create;
  FBackcolor := clwhite;
  FMarginLeft := 5;
  FMarginRight := 5;
  FMargintop := 5;
  Vdc := 1;
  hdc := 1;
  FFlags := 1; // Flags or flWantHook;
  memo.Clear;
end;

destructor TRMHTMLMemoView.Destroy;
begin
  ElementStack.free;
  TagStack.free;
  inherited Destroy; //2002.1.14 LBZ Move
end;

procedure THTMLElement.Break(ACanvas: TCanvas; available: integer);
var
  s: string;
  t, t1, i, w: integer;
begin
  Acanvas.font.name := fontname;
  Acanvas.font.size := fontsize;
  t := fontsize;
  t1 := t;
  if (sups) or (subs) then t := t div 2;
  Acanvas.font.size := t;
  Acanvas.font.style := fontstyle;
  Acanvas.font.color := fontcolor;
  if solText = '' then
    s := Text
  else
    s := Eoltext;
  if acanvas.TextWidth(s) <= available then
  begin
    soltext := s;
    eoltext := '';
    exit;
  end;
  for i := length(s) downto 1 do
  begin
    if s[i] = ' ' then
    begin
      w := acanvas.TextWidth(copy(s, 1, i));
      if w <= available then
      begin
        soltext := copy(s, 1, i);
        eoltext := copy(s, i + 1, length(s));
        exit;
      end;
    end;
  end;
  fontsize := t1;
  Acanvas.font.size := t1;
end;

procedure THTMLElement.SetAscent(const Value: integer);
begin
  FAscent := Value;
end;

procedure THTMLElement.SetBreakLine(const Value: boolean);
begin
  FBreakLine := Value;
end;

procedure THTMLElement.SetSup(const Value: boolean);
begin
  FSups := Value;
end;

procedure THTMLElement.SetSub(const Value: boolean);
begin
  FSubs := Value;
end;

procedure THTMLElement.SetSpan(const Value: boolean);
begin
  Fspans := Value;
end;

procedure THTMLElement.SetEolText(const Value: string);
begin
  FEolText := Value;
end;

procedure THTMLElement.SetFontColor(const Value: TColor);
begin
  FFontColor := Value;
end;

procedure THTMLElement.SetFontName(const Value: string);
begin
  FFontName := Value;
end;

procedure THTMLElement.SetFontSize(const Value: integer);
begin
  FFontSize := Value;
end;

procedure THTMLElement.SetFontStyle(const Value: TFontStyles);
begin
  FFontStyle := Value;
end;

procedure THTMLElement.SetHeight(const Value: integer);
begin
  FHeight := Value;
end;

procedure THTMLElement.SetSolText(const Value: string);
begin
  FSolText := Value;
end;

procedure THTMLElement.SetText(const Value: string);
begin
  FText := Value;
end;

procedure THTMLElement.SetWidth(const Value: integer);
begin
  FWidth := Value;
end;

{ THTMLElementStack }

procedure THTMLElementStack.Clear;
var
  i, c: integer;
begin
  c := count;
  if c > 0 then
    for i := 0 to c - 1 do
      THTMLElement(items[i]).free;
  inherited;
end;

destructor THTMLElementStack.Destroy;
begin
  clear;