rm_htmlmemo.pas

这是一个功能强大

  //  SetTextCharacterExtra(Canvas.Handle, CharSpacing);
  canvas.Brush.color := BackColor;
  canvas.Brush.style := bsclear;
  c := ElementStack.Count;
  if c = 0 then exit;
  HTMLClearBreaks;
  clw := spWidth;
  if width1 > spWidth then clw := width1 + spGapLeft;
  ml := spGapLeft;
  isol := 0;
  {
    y := gapy + RealRect.Top;
    if height1 < spHeight then
    begin
      if vdc = 0 then y := gapy + RealRect.Top; //垂直 顶对齐
      if (vdc = 1) and (height1 < spHeight) then y := round(RealRect.Top + spHeight / 2 - height1 / 2); //垂直居中
      if (vdc = 2) and (height1 < spHeight) then y := round(RealRect.Top + spHeight - height1 - gapy); //垂直对底
    end;
  }
  x := ml + RealRect.Left;
  if width1 < spWidth then
  begin
    if hdc = 0 then x := ml + RealRect.Left; //居左
    if (hdc = 1) and (width1 < spWidth) then x := round(RealRect.Left + spWidth / 2 - width1 / 2); //居中
    if (hdc = 2) and (width1 < spWidth) then x := round(RealRect.Left + spWidth - width1 - spGapLeft); //居右
  end;
  xold := x;

  ieol := 0;
  pendingBreak := false;
  repeat
    i := isol;
    xav := clw;
    maxHeight := 0;
    maxAscent := 0;
    eol := false;
    repeat // scan line
      el := THTMLElement(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;

    x1 := x;
    y1 := y;
    for i := isol to ieol do
    begin
      el := THTMLElement(ElementStack.items[i]);
    end;
    if y + maxheight - y1 < spHeight then
    begin
      if vdc = 0 then y := spGapTop + RealRect.Top; //垂直 顶对齐
      if (vdc = 1) and (height1 < spHeight) then y := round(RealRect.Top + spHeight / 2 - (y + maxHeight - y1) / 2); //垂直居中
      if (vdc = 2) and (height1 < spHeight) then y := round(RealRect.Top + spHeight - (y + maxHeight - y1) - spGapTop); //垂直对底
    end
    else y := spGapTop + RealRect.Top; //垂直 顶对齐
    x := x1;

    baseline := maxAscent;
    for i := isol to ieol do
    begin
      el := THTMLElement(ElementStack.items[i]);
      RenderString(el);
    end;
    if spHeight < maxheight then
    begin
      spHeight := maxheight + spGapTop;
      CalcGaps;
    end;
    isol := ieol;
  until (ieol >= c - 1) and (el.EolText = '');
end;

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

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

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

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

procedure TRMHTMLMemoView.writeHTML(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;
  //  if width1 > 0 then spWidth := width1+gapx;
  FText := s;
end;

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

procedure TRMHTMLMemoView.ExpandVariables;
var
  i: Integer;
  s: string;

  function GetBrackedVariable(s: string; var i, j: Integer): string;
  var
    c: Integer;
    fl1, fl2: Boolean;
  begin
    j := i;
    fl1 := True;
    fl2 := True;
    c := 0;
    Result := '';
    if s = '' then Exit;
    Dec(j);
    repeat
      Inc(j);
      if fl1 and fl2 then
        if s[j] = '[' then
        begin
          if c = 0 then i := j;
          Inc(c);
        end
        else if s[j] = ']' then Dec(c);
      if fl1 then
        if s[j] = '"' then fl2 := not fl2;
      if fl2 then
        if s[j] = '''' then fl1 := not fl1;
    until (c = 0) or (j >= Length(s));
    Result := Copy(s, i + 1, j - i - 1);
  end;

  procedure GetData(var s: string);
  var
    i, j: Integer;
    s1, s2: WideString;
  begin
    i := 1;
    repeat
      while (i < Length(s)) and (s[i] <> '[') do Inc(i);
      s1 := GetBrackedVariable(s, i, j);
      if i <> j then
      begin
        Delete(s, i, j - i + 1);
        s2 := '';
        InternalOnGetValue(Self, s1, s2);
        Insert(s2, s, i);
        Inc(i, Length(s2));
        j := 0;
      end;
    until i = j;
  end;
begin
  Memo1.Clear;
  for i := 0 to Memo.Count - 1 do
  begin
    s := Memo[i];
    if (Length(trim(s)) > 0) and (DocMode <> rmdmDesigning) then
      GetData(s);
    Memo1.Add(s);
  end;
end;

function TRMHTMLMemoView.ShowHTML: Boolean;
begin
  RenderHTML;
  Result := True;
end;

procedure TRMHTMLMemoView.Draw(Canvas: TCanvas);
begin
  BeginDraw(Canvas);
  Memo1.Assign(Memo);
  ExpandVariables;
  if memo1.Count > 0 then
    writeHTML(memo1.Text);
  CalcGaps;
  ShowBackground;
  ShowHTML;
  ShowFrame;
  RestoreCoord;
end;

procedure TRMHTMLMemoView.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  Stream.Read(vdc, SizeOf(vdc));
  Stream.Read(hdc, SizeOf(hdc));
end;

procedure TRMHTMLMemoView.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  Stream.Write(vdc, SizeOf(vdc));
  Stream.Write(hdc, SizeOf(hdc));
end;

procedure TRMHTMLMemoView.OnHook(View: TRMView);
begin
end;

procedure TRMHTMLMemoView.ShowEditor;
var
  i: byte;
  tmp: TRMHtmlForm;
begin
  tmp := TRMHtmlForm.Create(nil);
  try
    with tmp do
    begin
      if vdc = 0 then vlb.Down := true;
      if vdc = 1 then vcb.Down := true;
      if vdc = 2 then vrb.Down := true;
      if hdc = 0 then hlb.Down := true;
      if hdc = 1 then hcb.Down := true;
      if hdc = 2 then hrb.Down := true;
      FLabel.text := '';
      M1.Clear;
      if memo.Count > 0 then
      begin
        for i := 0 to memo.count - 1 do
        begin
          m1.Lines.Add(memo.strings[i]);
        end;
      end;
      if ShowModal = mrOk then
      begin
				RMDesigner.BeforeChange;
        if vlb.Down then vdc := 0;
        if vcb.Down then vdc := 1;
        if vrb.Down then vdc := 2;
        if hlb.Down then hdc := 0;
        if hcb.Down then hdc := 1;
        if hrb.Down then hdc := 2;
        Memo.Clear;
        if m1.Lines.Count > 0 then
        begin
          for i := 0 to m1.lines.count - 1 do
            memo.Add(m1.lines.Strings[i]);
        end;
      end;
    end;
  finally
    tmp.Free;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMHtmlForm }

function TRMHtmlForm.ShowEditor(View: TRMView): TModalResult;
begin
  Result := mrOK;
end;

procedure TRMHtmlForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(Self, 'Caption', rmRes + 914);
  RMSetStrProp(Label1, 'Caption', rmRes + 915);
  RMSetStrProp(Button3, 'Caption', rmRes + 916);
  RMSetStrProp(btnFont, 'Caption', rmRes + 917);
  RMSetStrProp(btnFontItalic, 'Caption', rmRes + 918);
  RMSetStrProp(btnFontBold, 'Caption', rmRes + 919);
  RMSetStrProp(SpeedButton1, 'Caption', rmRes + 920);
  RMSetStrProp(SpeedButton3, 'Caption', rmRes + 921);
  RMSetStrProp(SpeedButton6, 'Caption', rmRes + 922);
  RMSetStrProp(SpeedButton4, 'Caption', rmRes + 923);

  RMSetStrProp(Button1, 'Caption', SOK);
  RMSetStrProp(Button2, 'Caption', SCancel);
end;

procedure TRMHtmlForm.Button3Click(Sender: TObject);
var
  s: string;
begin
  s := RMDesigner.InsertDBField(nil);
  if s <> '' then
  begin
    ClipBoard.Clear;
    ClipBoard.AsText := s;
    M1.PasteFromClipboard;
    M1.SetFocus;
  end;
end;

procedure TRMHtmlForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = vk_Return) and (ssCtrl in Shift) then
  begin
    ModalResult := mrOk;
    Key := 0;
  end;
end;

procedure TRMHtmlForm.M1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = vk_Insert) and (Shift = []) then Button3Click(Self);
  if Key = vk_Escape then ModalResult := mrCancel;
  if (Key = vk_Return) and (ssCtrl in Shift) then
  begin
    ModalResult := mrOk;
    Key := 0;
  end;
end;

procedure TRMHtmlForm.M1Change(Sender: TObject);
var
  i: byte;
begin
  if m1.lines.Count > 0 then
  begin
    FLabel.text := '';
    for i := 0 to m1.lines.count - 1 do
      FLabel.text := FLabel.text + m1.lines.Strings[i];
  end;
end;

procedure TRMHtmlForm.SpeedButton1Click(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<sup>' + strpas(buffer) + '</sup>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.SpeedButton3Click(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<sub>' + strpas(buffer) + '</sub>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.btnFontClick(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s, color: string;
begin
  if FontDialog1.Execute then
  begin
    color := ColorToString(fontdialog1.Font.color);
    if copy(color, 1, 2) = 'cl' then color := copy(color, 3, length(color) - 2);
    Size := m1.SelLength;
    Inc(Size);
    GetMem(Buffer, Size);
    m1.GetSelTextBuf(Buffer, size);
    s := '<font face="' + fontdialog1.Font.Name + '" size="' + inttostr(fontdialog1.Font.size) + '" color="' + color + '">' + strpas(buffer) + '</font>';
    FreeMem(Buffer, Size);
    m1.SelText := s;
    M1.SetFocus;
  end;
end;

procedure TRMHtmlForm.btnFontItalicClick(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<i>' + strpas(buffer) + '</i>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.SpeedButton4Click(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<u>' + strpas(buffer) + '</u>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.btnFontBoldClick(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<b>' + strpas(buffer) + '</b>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.SpeedButton6Click(Sender: TObject);
var
  Buffer: PChar;
  size: integer;
  s: string;
begin
  Size := m1.SelLength;
  Inc(Size);
  GetMem(Buffer, Size);
  m1.GetSelTextBuf(Buffer, size);
  s := '<span>' + strpas(buffer) + '</span>';
  FreeMem(Buffer, Size);
  m1.SelText := s;
  M1.SetFocus;
end;

procedure TRMHtmlForm.FormActivate(Sender: TObject);
begin
  M1.SetFocus;
end;

procedure TRMHtmlForm.FormCreate(Sender: TObject);
begin
  FLabel := TjanMarkupLabel.create(Self);
  FLabel.Parent := ScrollBox1;
  FLabel.Align := alClient;

  Localize;
end;

procedure TRMHtmlForm.FormDestroy(Sender: TObject);
begin
  FLabel.Free;
end;

initialization
  RMRegisterObjectByRes(TRMHTMLMemoView, 'RM_HTMLMemoObject', 'HTML标签', nil);

finalization

end.