rm_htmlmemo.pas

这是一个功能强大

  inherited;
end;

function THTMLElementStack.peek: THTMLElement;
var
  c: integer;
begin
  c := count;
  if c = 0 then
    result := nil
  else
  begin
    result := THTMLElement(items[c - 1]);
  end;
end;

function THTMLElementStack.pop: THTMLElement;
var
  c: integer;
begin
  c := count;
  if c = 0 then
    result := nil
  else
  begin
    result := THTMLElement(items[c - 1]);
    delete(c - 1);
  end;
end;

procedure THTMLElementStack.push(Element: THTMLElement);
begin
  add(Element);
end;

(**********************************)

procedure TRMHTMLMemoView.HTMLClearBreaks;
var
  i, c: integer;
  El: THTMLElement;
begin
  c := ElementStack.Count;
  if c = 0 then exit;
  for i := 0 to c - 1 do
  begin
    el := THTMLElement(ElementStack.items[i]);
    el.SolText := '';
    el.EolText := '';
  end;
end;

procedure TRMHTMLMemoView.HTMLElementDimensions;
var
  i, c, t, t1: integer;
  El: THTMLElement;
  h, a, w: integer;
  tm: Textmetric;
  s: string;
begin
  //  SetTextCharacterExtra(Canvas.Handle, CharSpacing);
  c := ElementStack.Count;
  width1 := 0;
  height1 := 0;
  if c = 0 then exit;
  for i := 0 to c - 1 do
  begin
    el := THTMLElement(ElementStack.items[i]);
    s := el.Text;
    t := el.FontSize;
    t1 := t;
    if (el.Sups) or (el.Subs) then t := t div 2;
    canvas.font.size := t;
    //    canvas.font.size := el.fontsize;
    canvas.font.name := el.FontName;
    canvas.font.style := el.FontStyle;
    canvas.font.Color := el.FontColor;
    w := canvas.TextWidth(s);
    canvas.font.size := t1;
    gettextmetrics(canvas.handle, tm);
    h := tm.tmHeight;
    a := tm.tmAscent;
    canvas.font.size := t1;
    width1 := width1 + w;
    el.Height := h;
    el.Ascent := a;
    el.Width := w;
    if height1 < h then height1 := h;
  end;
end;

procedure TRMHTMLMemoView.ParseHTML(s: string);
var
  p: integer;
  se, st: string;
  ftext: string;
  fstyle: TfontStyles;
  sup, sub, span: boolean;
  fname: string;
  fsize: integer;
  fbreakLine: boolean;
  aColor, fColor: Tcolor;
  Element: THTMLElement;

  procedure pushTag;
  begin
    Element := THTMLElement.Create;
    element.FontName := fname;
    element.FontSize := fsize;
    element.FontStyle := fstyle;
    element.FontColor := fColor;
    Element.Sups := sup;
    Element.Subs := sub;
    Element.Spans := span;
    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.spans := element.spans;
      Element.Free;
    end;
  end;

  procedure pushElement;
  begin
    Element := THTMLElement.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;
    element.spans := span;
    span := false;
    ElementStack.push(Element);
  end;

  procedure parseTag(ss: string);
  var
    pp, error: 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
    else if atag = 'span' then
    begin
      pushtag;
      span := true;
    end
    else if atag = '/span' then
    begin
      span := 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
              val(aval, fsize, error);
            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;
  span := 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 TRMHTMLMemoView.RenderHTML;
var
  x1, y1, x, xold, y, xav, clw: integer;
  baseline: integer;
  i, i0, c: integer;
  el: THTMLElement;
  eol: boolean;
  ml: integer; // margin left
  isol, ieol: integer;
  maxheight, maxascent: integer;
  pendingBreak: boolean;
  SMemo: TStringList; // temporary memo used during TRMView drawing

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

  procedure OutLine(const str: string);
  begin
    SMemo.Add(str);
  end;

  procedure WrapLine(const s: string; x: integer);
  var
    k, cur, beg, last: Integer;
    bIsDBCS: Boolean;
    iCutlength: integer;
  begin
    //  SetTextCharacterExtra(Canvas.Handle, CharSpacing);
    last := 1;
    beg := 1;
    if (Length(s) <= 1) or (x + Canvas.TextWidth(s) <= spWidth + RealRect.Left) then OutLine(s)
    else
    begin
      bisdbcs := false;
      k := 0;
      for cur := 1 to Length(s) do
      begin
        icutlength := cur;
        if bIsDBCS then
        begin
          bIsDBCS := false;
          k := 0;
        end
        else
          if windows.isDBCSLeadByte(byte(s[cur])) then
          begin
            bIsDBCS := true; //判断是否为中文
            k := 1;
          end;
        if x + Canvas.TextWidth(Copy(s, beg, cur - beg + 1 + k)) >= spWidth + RealRect.Left then //>= maxwidth
        begin
          x := xold;
          if bisDBCS then dec(icutlength); //如果最后一个字是中文，少截一个字节
          if last = beg then last := icutlength; //if last = beg then last := cur;
          outLine(copy(s, beg, last - beg + 1));
          if last = length(s) then //1999.4.26  if last = cur then
          begin
            beg := cur;
            break;
          end;
          beg := last + 1;
          last := beg;
        end;
      end;
      if beg <> cur then OutLine(Copy(s, beg, cur - beg + 1));
    end;
  end;

  procedure RenderString(ee: THTMLElement);
  var
    ss, s1: string;
    i: integer;
    t: integer;

    procedure showchar(s1: string);
    begin
      if ee.Subs then canvas.TextOut(x, y + baseline - ee.Ascent div 2, s1)
      else canvas.TextOut(x, y + baseline - ee.Ascent, s1);
      if ee.Fspans then //上划线
      begin
        canvas.pen.Width := 1;
        canvas.pen.color := ee.FontColor;
        canvas.pen.Style := psSolid;
        if ee.Subs then
        begin
          canvas.MoveTo(x, y + baseline - ee.Ascent div 2);
          canvas.LineTo(x + canvas.TextWidth(s1), y + baseline - ee.Ascent div 2);
        end
        else
        begin
          canvas.MoveTo(x, y + baseline - ee.Ascent);
          canvas.LineTo(x + canvas.TextWidth(s1), y + baseline - ee.Ascent);
        end;
      end;
      x := x + canvas.TextWidth(s1);
    end;

  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;
      s1 := '';
      i0 := 1;
      SMemo := TStringList.Create;
      smemo.Clear;
      WrapLine(ss, x);
      if smemo.Count > 0 then
      begin
        for i := 0 to smemo.Count - 1 do
        begin
          if (y < spHeight + RealRect.Top - maxheight) then showchar(smemo[i]);
          if i = smemo.Count - 1 then
          begin
            if x > spWidth + RealRect.Left then
            begin
              x := xold;
              y := y + maxHeight;
            end;
          end
          else
          begin
            x := xold;
            y := y + maxHeight;
          end;
        end;
      end;
      smemo.free;
    end;
    if (ee.fsups) or (ee.fsubs) then
    begin
      ee.FFontSize := t;
      SetFont(ee);
    end;
  end;

  (***************************************)
  function HTMLLine(ee: THTMLElement): integer;
  var
    ss, s1: string;
    i: integer;
    t: integer;

    procedure showchar(s1: string);
    begin
      x := x + canvas.TextWidth(s1);
    end;

  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;
      s1 := '';
      i0 := 1;
      SMemo := TStringList.Create;
      smemo.Clear;
      WrapLine(ss, x);
      if smemo.Count > 0 then
      begin
        for i := 0 to smemo.Count - 1 do
        begin
          if (y < spHeight + RealRect.Top - maxheight) then showchar(smemo[i]);
          if i = smemo.Count - 1 then
          begin
            if x > spWidth + RealRect.Left then
            begin
              x := xold;
              y := y + maxHeight;
            end;
          end
          else
          begin
            x := xold;
            y := y + maxHeight;
          end;
        end;
      end;
      smemo.free;
    end;
    if (ee.fsups) or (ee.fsubs) then
    begin
      ee.FFontSize := t;
      SetFont(ee);
    end;
    result := 0;
  end;
  (***************************************)

begin