rm_htmlmemo.pas

这是一个功能强大

{*****************************************}
{                                         }
{         Report Machine v2.4             }
{           HTML Memo样式 Object          }
{                                         }
{*****************************************}

unit RM_htmlmemo;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, Menus, ClipBrd, RM_Class, RM_Ctrls
  {$IFDEF COMPILER6_UP}, Variants{$ENDIF};

type

  TjanHTMLElement = class(TObject)
  private
    FFontSize: integer;
    FText: string;
    FFontName: string;
    FFontStyle: TFontStyles;
    FFontColor: TColor;
    FAscent: integer;
    FHeight: integer;
    FWidth: integer;
    FSolText: string;
    FEolText: string;
    FBreakLine: boolean;
    Fsups: boolean;
    Fsubs: boolean;
    procedure SetFontName(const Value: string);
    procedure SetFontSize(const Value: integer);
    procedure SetFontStyle(const Value: TFontStyles);
    procedure SetText(const Value: string);
    procedure SetFontColor(const Value: TColor);
    procedure SetAscent(const Value: integer);
    procedure SetHeight(const Value: integer);
    procedure SetWidth(const Value: integer);
    procedure SetEolText(const Value: string);
    procedure SetSolText(const Value: string);
    procedure SetBreakLine(const Value: boolean);
    procedure SetSup(const Value: boolean);
    procedure SetSub(const Value: boolean);
  protected
  public
    procedure Break(ACanvas: TCanvas; available: integer);
    property Text: string read FText write SetText;
    property SolText: string read FSolText write SetSolText;
    property EolText: string read FEolText write SetEolText;
    property FontName: string read FFontName write SetFontName;
    property FontSize: integer read FFontSize write SetFontSize;
    property FontStyle: TFontStyles read FFontStyle write SetFontStyle;
    property FontColor: TColor read FFontColor write SetFontColor;
    property Height: integer read FHeight write SetHeight;
    property Width: integer read FWidth write SetWidth;
    property Ascent: integer read FAscent write SetAscent;
    property BreakLine: boolean read FBreakLine write SetBreakLine;
    property Sups: boolean read FSups write SetSup;
    property Subs: boolean read FSubs write SetSub;
  end;

  TjanHTMLElementStack = class(TList)
  private
  protected
  public
    destructor Destroy; override;
    procedure Clear; override;
    // will free ALL elements in the stack
    procedure push(Element: TjanHTMLElement);
    function pop: TjanHTMLElement;
    // calling routine is responsible for freeing the element.
    function peek: TjanHTMLElement;
    // calling routine must NOT free the element
  end;

  TjanMarkupLabel = class(TGraphicControl)
  private
    { Private declarations }
    ElementStack: TjanHTMLElementStack;
    TagStack: TjanHTMLElementStack;
    FText: string;
    FBackColor: TColor;
    FMarginLeft: integer;
    FMarginRight: integer;
    FMarginTop: integer;
    procedure ParseHTML(s: string);
    procedure RenderHTML;
    procedure HTMLClearBreaks;
    procedure HTMLElementDimensions;
    procedure SetBackColor(const Value: TColor);
    procedure SetText(const Value: string);
    procedure SetMarginLeft(const Value: integer);
    procedure SetMarginRight(const Value: integer);
    procedure SetMarginTop(const Value: integer);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    { Published declarations }
    property Text: string read FText write SetText;
    property BackColor: TColor read FBackColor write SetBackColor;
    property MarginLeft: integer read FMarginLeft write SetMarginLeft;
    property MarginRight: integer read FMarginRight write SetMarginRight;
    property MarginTop: integer read FMarginTop write SetMarginTop;
  end;

  TRMHTMLMemoObject = class(TComponent) // fake component
  end;

  THTMLElement = class(TObject)
  private
    FFontSize: integer;
    FText: string;
    FFontName: string;
    FFontStyle: TFontStyles;
    FFontColor: TColor;
    FAscent: integer;
    FHeight: integer;
    FWidth: integer;
    FSolText: string;
    FEolText: string;
    FBreakLine: boolean;
    Fsups: boolean;
    Fsubs: boolean;
    Fspans: boolean;
    procedure SetFontName(const Value: string);
    procedure SetFontSize(const Value: integer);
    procedure SetFontStyle(const Value: TFontStyles);
    procedure SetText(const Value: string);
    procedure SetFontColor(const Value: TColor);
    procedure SetAscent(const Value: integer);
    procedure SetHeight(const Value: integer);
    procedure SetWidth(const Value: integer);
    procedure SetEolText(const Value: string);
    procedure SetSolText(const Value: string);
    procedure SetBreakLine(const Value: boolean);
    procedure SetSup(const Value: boolean);
    procedure SetSub(const Value: boolean);
    procedure Setspan(const Value: boolean);
  protected
  public
    procedure Break(ACanvas: TCanvas; available: integer);
    property Text: string read FText write SetText;
    property SolText: string read FSolText write SetSolText;
    property EolText: string read FEolText write SetEolText;
    property FontName: string read FFontName write SetFontName;
    property FontSize: integer read FFontSize write SetFontSize;
    property FontStyle: TFontStyles read FFontStyle write SetFontStyle;
    property FontColor: TColor read FFontColor write SetFontColor;
    property Height: integer read FHeight write SetHeight;
    property Width: integer read FWidth write SetWidth;
    property Ascent: integer read FAscent write SetAscent;
    property BreakLine: boolean read FBreakLine write SetBreakLine;
    property Sups: boolean read FSups write SetSup;
    property Subs: boolean read FSubs write SetSub;
    property Spans: boolean read FSpans write SetSpan;
  end;

  THTMLElementStack = class(TList)
  private
  protected
  public
    destructor Destroy; override;
    procedure Clear; override;
    procedure push(Element: THTMLElement);
    function pop: THTMLElement;
    function peek: THTMLElement;
  end;

  TRMHTMLMemoView = class(TRMReportView)
  private
    ElementStack: THTMLElementStack;
    TagStack: THTMLElementStack;
    FText: string;
    FBackColor: TColor;
    FMarginLeft: integer;
    FMarginRight: integer;
    FMarginTop: integer;
    procedure ParseHTML(s: string);
    procedure HTMLClearBreaks;
    procedure SetBackColor(const Value: TColor);
    procedure SetMarginLeft(const Value: integer);
    procedure SetMarginRight(const Value: integer);
    procedure SetMarginTop(const Value: integer);
    function ShowHTML: Boolean;
  protected
    procedure ExpandVariables;
  public
    VDC, HDC: byte;
    width1, height1: integer;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure OnHook(View: TRMView); override;
    procedure RenderHTML;
    procedure writeHTML(value: string);
    procedure HTMLElementDimensions;
    procedure ShowEditor; override;
  published
    property BackColor: TColor read FBackColor write SetBackColor;
    property MarginLeft: integer read FMarginLeft write SetMarginLeft;
    property MarginRight: integer read FMarginRight write SetMarginRight;
    property MarginTop: integer read FMarginTop write SetMarginTop;
  end;

  { TRMHtmlForm }
  TRMHtmlForm = class(TRMObjEditorForm)
    Button1: TButton;
    Button2: TButton;
    ScrollBox1: TScrollBox;
    FontDialog1: TFontDialog;
    Panel1: TPanel;
    M1: TMemo;
    Button3: TButton;
    btnFont: TSpeedButton;
    btnFontItalic: TSpeedButton;
    btnFontBold: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton1: TSpeedButton;
    GroupBox1: TGroupBox;
    HLB: TSpeedButton;
    HCB: TSpeedButton;
    HRB: TSpeedButton;
    VLB: TSpeedButton;
    VCB: TSpeedButton;
    VRB: TSpeedButton;
    Label1: TLabel;
    procedure Button3Click(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure M1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure M1Change(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure btnFontClick(Sender: TObject);
    procedure btnFontItalicClick(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure btnFontBoldClick(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FLabel: TjanMarkupLabel;

    procedure Localize;
  public
    function ShowEditor(View: TRMView): TModalResult; override;
  end;

implementation

uses RM_Const, RM_Utils, RM_Common;

{$R *.DFM}

function RMHTMLStringToColor(v: string; var col: Tcolor): boolean;
var
  vv: string;
begin
  if copy(v, 1, 1) <> '#' then
  begin
    vv := 'cl' + v;
    try
      col := stringtoColor(vv);
      result := true;
    except
      result := false;
    end;
  end
  else
  begin
    try
      vv := '$' + copy(v, 6, 2) + copy(v, 4, 2) + copy(v, 2, 2);
      col := stringtocolor(vv);
      result := true;
    except
      result := false;
    end
  end
end;

{ TjanHTMLElement }

procedure TjanHTMLElement.Break(ACanvas: TCanvas; available: integer);
var
  s: string;
  i, w: integer;
begin
  Acanvas.font.name := fontname;
  Acanvas.font.size := fontsize;
  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;
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

{ TjanHTMLElementStack }

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

destructor TjanHTMLElementStack.Destroy;
begin
  clear;
  inherited;
end;

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

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

procedure TjanHTMLElementStack.push(Element: TjanHTMLElement);
begin
  add(Element);
end;

{ TjanMarkupLabel }

constructor TjanMarkupLabel.create(AOwner: TComponent);
begin
  inherited;
  Elementstack := TjanHTMLElementStack.Create;
  TagStack := TjanHTMLElementStack.Create;
  FBackcolor := clwhite;
  Width := 200;
  Height := 100;
  FMarginLeft := 5;
  FMarginRight := 5;
  FMargintop := 5;
end;

destructor TjanMarkupLabel.destroy;
begin
  ElementStack.free;
  TagStack.free;
  inherited;
end;

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

procedure TjanMarkupLabel.HTMLElementDimensions;
var
  i, c: integer;
  El: TjanHTMLElement;
  h, a, w: integer;
  tm: Textmetric;
  s: string;
begin
  c := ElementStack.Count;
  if c = 0 then exit;
  for i := 0 to c - 1 do
  begin
    el := TjanHTMLElement(ElementStack.items[i]);
    s := el.Text;
    canvas.font.name := el.FontName;
    canvas.font.size := el.FontSize;
    canvas.font.style := el.FontStyle;
    canvas.font.Color := el.FontColor;
    gettextmetrics(canvas.handle, tm);
    h := tm.tmHeight;
    a := tm.tmAscent;
    w := canvas.TextWidth(s);
    el.Height := h;
    el.Ascent := a;
    el.Width := w;
  end;
end;

procedure TjanMarkupLabel.paint;
begin
  RenderHTML;
end;

procedure TjanMarkupLabel.ParseHTML(s: string);
var
  p: integer;
  se, st: string;
  ftext: string;
  fstyle: TfontStyles;
  sup, sub: boolean;
  fname: string;