psvrtftext.pas

PIC 单片机 PAS SOURCE CODE SAMPLES

{*******************************************************}
{               RichEdit Syntax HighLight               }
{                     version 3.0                       }
{ Author:                                               }
{ Serhiy Perevoznyk                                     }
{ [e-mail]                          }
{                                                       }
{*******************************************************}
unit psvRTFText;

interface

uses
  SysUtils,  
  Windows, 
  Messages, 
  Classes, 
  Graphics, 
  Controls;


type
  TpsvRichText = class(TComponent)
  private
    FCodePage : integer;
    FFont : TFont;
    FAlignment : TAlignment;
    OutStream :TMemoryStream;
    BodyStream:TMemoryStream;
    FontTable :TStringList;
    procedure WriteString(AString: string);
    procedure WriteBody(AString : string);
    function  GetFontTableName(FontName:string):string;
    function  GetFontAttrib(Style:TFontStyles):string;
    function  GetFontSize(Size:Integer):string;
    function  GetAlignment(Alignment:TAlignment):string;
    function  GetFontColorString(Color:TColor):string;
    procedure SetFont(const Value: TFont);
  protected
    procedure AddFontToTable(Font:TFont); virtual;
    procedure AddHeader; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   Clear;
    function    Content : string;
    procedure   Write(AString : String);
    procedure   FirstBulletLine(AString : string);
    procedure   NextBulletLine(AString : string);
    procedure   Writeln;
    procedure   SaveToFile(const FileName:String);
    procedure   SaveToStream(AStream : TStream);
    procedure   InsertBitmap(ABitmap : TBitmap);
  published
    property CodePage : integer read FCodePage write FCodePage default 1252;
    property Font : TFont read FFont write SetFont;
    property Alignment : TAlignment read FAlignment write FAlignment default taLeftJustify;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TpsvRichText]);
end;

constructor TpsvRichText.Create(AOwner: TComponent);
begin
   inherited;
   OutStream :=TMemoryStream.Create;
   BodyStream:=TMemoryStream.Create;
   FontTable :=TStringList.Create;
   FCodePage := 1252;
   FFont := TFont.Create;
   FFont.Size := 12;
   FAlignment := taLeftJustify;
end;

destructor TpsvRichText.Destroy;
begin
  OutStream.Free;
  BodyStream.Free;
  FontTable.Free;
  FFont.Free;
  inherited;
end;

procedure TpsvRichText.Clear;
begin
  OutStream.Clear;
  BodyStream.Clear;
end;


procedure TpsvRichText.AddHeader;
var
  i:Integer;
begin
 WriteString('{\rtf1\ansi\ansicpg'+IntToStr(FCodePage)+'\deff0\deftab720');
 WriteString('{\fonttbl');

 for i:=0 to FontTable.count-1 do
  WriteString(FontTable.Strings[i]);

 WriteString('}');
 WriteString('{\colortbl');
 WriteString('\red0\green0\blue0;');       {Black}
 WriteString('\red128\green0\blue0;');     {Maroon}
 WriteString('\red0\green128\blue0;');     {Green}
 WriteString('\red128\green128\blue0;');   {Olive}
 WriteString('\red0\green0\blue128;');     {Navy}
 WriteString('\red128\green0\blue128;');   {Purple}
 WriteString('\red0\green128\blue128;');   {Teal}
 WriteString('\red128\green128\blue128;'); {Gray}
 WriteString('\red192\green192\blue192;'); {Silver}
 WriteString('\red255\green0\blue0;');     {Red}
 WriteString('\red0\green255\blue0;');     {Lime}
 WriteString('\red255\green255\blue0;');   {Yellow}
 WriteString('\red0\green0\blue255;');     {Blue}
 WriteString('\red255\green0\blue255;');   {Fuchsia}
 WriteString('\red0\green255\blue255;');   {Aqua}
 WriteString('\red255\green255\blue255;'); {White}
 WriteString('}');
end;


function TpsvRichText.Content : string;
var TS : TStringStream;
begin
  TS := TStringStream.Create('');
  OutStream.Clear;
  AddHeader;
  BodyStream.Position := 0;
  OutStream.CopyFrom(BodyStream, 0);
  WriteString(#13#10+'}}');
  OutStream.Position := 0;
  OutStream.SaveToStream(TS);
  Result := TS.DataString;
  TS.Free;
end;

procedure TpsvRichText.Writeln;
begin
  WriteBody('\par ');
end;

procedure TpsvRichText.Write(AString:String);
var Align,
    FontColor,
    FontAttrib,
    FontSize,
    FontName:String;
begin
  AString := StringReplace(AString, #10, '\par '#13#10, [rfReplaceAll]);
  AString := StringReplace(AString, '{', '\{', [rfReplaceAll]);
  AString := StringReplace(AString, '}', '\}', [rfReplaceAll]);
  AString := StringReplace(AString, '\', '\\', [rfReplaceAll]);
  Align      :=GetAlignment(FAlignment);
  FontColor  :=GetFontColorString(FFont.Color);
  FontSize   :=GetFontSize(FFont.Size);
  FontAttrib :=GetFontAttrib(FFont.Style);
  FontName   :=GetFontTableName(FFont.Name);
  WriteBody(#13#10'\pard'+Align+'\plain'+FontName+FontSize+FontAttrib+FontColor+' '+AString);
end;


function TpsvRichText.GetFontTableName(FontName:string):string;
var i :Integer;
begin
  Result := '\f0';
  for i:=0 to FontTable.Count-1 do
   begin
     if Pos(FontName,FontTable.Strings[i]) > 0 then
       begin
         Result := '\f'+IntToStr(i);
         Exit;
       end;
    end;
end;

function TpsvRichText.GetFontAttrib(Style:TFontStyles):string;
begin
  Result:= '';
  if (fsBold in Style) then
   Result := Result + '\b';
  if (fsItalic in Style) then
   Result := Result + '\i';
  if (fsUnderline in Style) then
   Result := Result+ '\ul';
  if (fsStrikeOut in Style) then
   Result := Result + '\strike';
end;

function TpsvRichText.GetFontSize(Size:Integer):string;
begin
  Result:='\fs'+IntToStr(size*2);
end;

function TpsvRichText.GetAlignment(Alignment:TAlignment):string;
begin
  case Alignment of
   taCenter : Result := '\qc';
   taRightJustify: Result := '\qr';
   else  Result :='';
  end;
end;

function TpsvRichText.GetFontColorString(Color:TColor):string;
begin
  case Color of
    clBlack   : Result:='\cf0';
    clMaroon  : Result:='\cf1';
    clGreen   : Result:='\cf2';
    clOlive   : Result:='\cf3';
    clNavy    : Result:='\cf4';
    clPurple  : Result:='\cf5';
    clTeal    : Result:='\cf6';
    clGray    : Result:='\cf7';
    clSilver  : Result:='\cf8';
    clRed     : Result:='\cf9';
    clLime    : Result:='\cf10';
    clYellow  : Result:='\cf11';
    clBlue    : Result:='\cf12';
    clFuchsia : Result:='\cf13';
    clAqua    : Result:='\cf14';
    clWhite   : Result:='\cf15';
     else
      Result := '\cf0';
   end;
end;

procedure TpsvRichText.AddFontToTable(Font:TFont);
var  DC: HDC;
     SaveFont: HFont;
     Metrics: TTextMetric;
     Temp:byte;
     I: Integer;
     charset,family:string;
begin

  for i := 0 to FontTable.Count - 1 do
  begin
    if Pos(Font.Name, FontTable[i]) > 0 then
     Exit
  end;

  DC := GetDC(0);
  try
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(0, DC);
  end;

case Metrics.tmCharSet of
  ANSI_CHARSET     : charset:='fcharset0';
  DEFAULT_CHARSET  : charset:='fcharset1';
  SYMBOL_CHARSET   : charset:='fcharset2';
  SHIFTJIS_CHARSET : charset:='fcharset128';
  OEM_CHARSET      : charset:='fcharset255';
    else charset:='';
end;

Temp:=Metrics.tmPitchAndFamily;
Temp:= (Temp shr 4) shl 4;

case Temp of
 FF_DECORATIVE:	family:='fdecorative';
 FF_DONTCARE:	family:='fdontcare';
 FF_MODERN:	family:='fmodern';
 FF_ROMAN:	family:='froman';
 FF_SCRIPT:	family:='fscript';
 FF_SWISS:	family:='fswiss';
  else family:='froman';
end;
  FontTable.Add('{\f'+IntToStr(FontTable.Count)+'\'+family+'\'+charset+' '+font.name+';}');
end;

procedure TpsvRichText.SaveToFile(const FileName:String);
begin
  OutStream.Clear;
  AddHeader;
  BodyStream.Position := 0;
  OutStream.CopyFrom(BodyStream, BodyStream.Size);
  WriteString(#13#10+'}}');
  OutStream.SaveToFile(FileName);
end;

procedure TpsvRichText.WriteString(AString : String);
begin
  OutStream.Write(AString[1], Length(AString));
end;

procedure TpsvRichText.WriteBody(AString : String);
begin
  BodyStream.Write(AString[1], Length(AString));
end;


procedure TpsvRichText.SetFont(const Value: TFont);
begin
  if FFont <> Value then
   begin
     FFont.Assign(Value);
     AddFontToTable(FFont);
   end;
end;



procedure TpsvRichText.SaveToStream(AStream: TStream);
begin
  OutStream.Clear;
  AddHeader;
  BodyStream.Position := 0;
  OutStream.CopyFrom(BodyStream, BodyStream.Size);
  WriteString(#13#10+'}}');
  OutStream.SaveToStream(AStream);
end;

procedure TpsvRichText.FirstBulletLine(AString : string);
var
    FontColor,
    FontAttrib,
    FontSize,
    FontName:String;
begin
  AString := StringReplace(AString, #10, '\par '#13#10, [rfReplaceAll]);
  AString := StringReplace(AString, '{', '\{', [rfReplaceAll]);
  AString := StringReplace(AString, '}', '\}', [rfReplaceAll]);
  AString := StringReplace(AString, '\', '\\', [rfReplaceAll]);
  FontColor  :=GetFontColorString(FFont.Color);
  FontSize   :=GetFontSize(FFont.Size);
  FontAttrib :=GetFontAttrib(FFont.Style);
  FontName   :=GetFontTableName(FFont.Name);
  WriteBody(#13#10'\par\pard\li150\fi-150{\*\pn\pnlvlblt\pnf1\pnindent150{\pntxtb\''b7}}\plain{\pntext\''b7\tab} ');
  WriteBody(FontSize + FontColor + FontAttrib+FontColor+ ' ');
  WriteBody(AString);
end;

procedure TpsvRichText.NextBulletLine(AString: string);
var
    FontColor,
    FontAttrib,
    FontSize,
    FontName:String;
begin
  AString := StringReplace(AString, #10, '\par '#13#10, [rfReplaceAll]);
  AString := StringReplace(AString, '{', '\{', [rfReplaceAll]);
  AString := StringReplace(AString, '}', '\}', [rfReplaceAll]);
  AString := StringReplace(AString, '\', '\\', [rfReplaceAll]);
  FontColor  :=GetFontColorString(FFont.Color);
  FontSize   :=GetFontSize(FFont.Size);
  FontAttrib :=GetFontAttrib(FFont.Style);
  FontName   :=GetFontTableName(FFont.Name);
  WriteBody(#13#10'\par' +  FontName + FontSize + FontAttrib+FontColor+' {\pntext\''b7\tab} ');
  WriteBody(AString);
end;


procedure TpsvRichText.InsertBitmap(ABitmap: TBitmap);
var
  St : string;

function Bitmap2Hex(ABitmap : TBitmap): String;
var
  Stream: TMemoryStream;
  i : integer;
begin
  Result := '';
  Stream := TMemoryStream.Create;
  try
    ABitmap.SaveToStream(Stream);
    for i := 0 to Stream.Size -1 do
      begin
        Result := Result + IntToHex(Ord(PChar(Stream.Memory)[i]),2);
      end;
  finally
    Stream.Free;
  end;
end;

function Bitmap2RTF(ABitmap : TBitmap) : string;
var
 St : string;
 L  : integer;
begin
  Result := '{\pict';
  if ABitmap.Height>1 then
   L := PChar(ABitmap.ScanLine[1])-PChar(ABitmap.ScanLine[0])
     else
        L := ABitmap.Width;
  Result := Result + Format('\dibitmap0\wbmwidthbytes%d\picw%d\pich%d ',[L, ABitmap.Width, ABitmap.Height]);
  St := Bitmap2Hex(ABitmap);
  Result := Result +  ( PChar(St) + SizeOf(TBitmapFileHeader)*2) ;
  Result := Result + '}';
end;

begin
  St := Bitmap2RTF(ABitmap);
  WriteBody(St);
end;

end.