Unit1.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:12k
源码类别:

RichEdit

开发平台:

Delphi

  1. unit Unit1;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   RVStyle, RVScroll, RichView;
  6. type
  7.   TForm1 = class(TForm)
  8.     RichView1: TRichView;
  9.     RVStyle1: TRVStyle;
  10.     RichView2: TRichView;
  11.     procedure RVStyle1DrawStyleText(Sender: TRVStyle; const s: String;
  12.       Canvas: TCanvas; StyleNo, SpaceBefore, Left, Top, Width,
  13.       Height: Integer; DrawState: TRVTextDrawStates;
  14.       var DoDefault: Boolean);
  15.     procedure FormCreate(Sender: TObject);
  16.     procedure RVStyle1StyleHoverSensitive(Sender: TRVStyle;
  17.       StyleNo: Integer; var Sensitive: Boolean);
  18.     procedure RVStyle1DrawTextBack(Sender: TRVStyle; Canvas: TCanvas;
  19.       StyleNo, Left, Top, Width, Height: Integer;
  20.       DrawState: TRVTextDrawStates; var DoDefault: Boolean);
  21.     procedure RVStyle1DrawCheckpoint(Sender: TRVStyle; Canvas: TCanvas; X,
  22.       Y, ItemNo, XShift: Integer; RaiseEvent: Boolean; Control: TControl;
  23.       var DoDefault: Boolean);
  24.     procedure RVStyle1DrawPageBreak(Sender: TRVStyle; Canvas: TCanvas; Y,
  25.       XShift: Integer; PageBreakType: TRVPageBreakType; Control: TControl; var DoDefault: Boolean);
  26.     procedure RVStyle1DrawParaBack(Sender: TRVStyle; Canvas: TCanvas;
  27.       ParaNo: Integer; ARect: TRect; var DoDefault: Boolean);
  28.     procedure RichView2Paint(Sender: TCustomRichView; Canvas: TCanvas;
  29.       Prepaint: Boolean);
  30.     procedure RichView2RVMouseUp(Sender: TCustomRichView;
  31.       Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
  32.   private
  33.     { Private declarations }
  34.   public
  35.     { Public declarations }
  36.   end;
  37. var
  38.   Form1: TForm1;
  39. implementation
  40. {$R *.DFM}
  41. {============================== DRAWING ROUTINES ==============================}
  42. {$R-} // turning off range checking (required for DrawTrRect)
  43. {------------------------------------------------------------------------------}
  44. { Drawing left to right arrow                                                  }
  45. {------------------------------------------------------------------------------}
  46. procedure DrawArrow(Canvas: TCanvas; Left, Top, Width, Height: Integer);
  47. var midx,midy: Integer;
  48.     one, two : Integer;
  49. begin
  50.    midx := Left+Width div 2;
  51.    midy := Top+Height div 2;
  52.    if Width>0 then begin
  53.      one := 1;
  54.      two := -2;
  55.    end
  56.    else begin
  57.      one := -1;
  58.      two := 2;
  59.    end;
  60.    Canvas.PolyLine([Point(Left+one,Top+3),
  61.                     Point(midx,Top+3),
  62.                     Point(midx,Top+1),
  63.                     Point(Left+Width+two, midy),
  64.                     Point(midx, Top+Height-2),
  65.                     Point(midx, Top+Height-4),
  66.                     Point(Left+one,Top+Height-4),
  67.                     Point(Left+one,Top+3)
  68.                     ]);
  69. end;
  70. {------------------------------------------------------------------------------}
  71. { Drawing an icon for page breaks                                              }
  72. {------------------------------------------------------------------------------}
  73. procedure DrawPageIcon(Canvas: TCanvas; Left, Top, Width, Height: Integer);
  74. var LeftS, RightS: Integer;
  75. begin
  76.   LeftS := Left+2;
  77.   RightS := Left+Width-4;
  78.   Canvas.PolyLine([Point(RightS-3,Top),
  79.                    Point(LeftS,Top),
  80.                    Point(LeftS, Top+Height),
  81.                    Point(RightS,Top+Height),
  82.                    Point(RightS,Top+3),
  83.                    Point(RightS-3,Top),
  84.                    Point(RightS-3,Top+3),
  85.                    Point(RightS,Top+3)
  86.                    ]);
  87.    Canvas.Pen.Style := psDot;
  88.    Canvas.Pen.Color := clRed;
  89.    Canvas.MoveTo(Left, Top+Height div 2);
  90.    Canvas.LineTo(Left+Width, Top+Height div 2);
  91. end;
  92. {------------------------------------------------------------------------------}
  93. { Drawing a colored rectangle with specified degree of opacity (0..255)        }
  94. { (quite slow...)                                                              }
  95. {------------------------------------------------------------------------------}
  96. procedure DrawTrRect(Canvas: TCanvas; const ARect: TRect;
  97.                      Color: TColor;
  98.                      Opacity: Integer);
  99. type
  100.   RGBARR = array [0..0] of TRGBQUAD;
  101.   PRGBARR = ^RGBARR;
  102. var prgb: PRGBARR;
  103.     rgb : TRGBQUAD;
  104.    i,j: Integer;
  105.    tr : Integer;
  106.    Clr: LongInt;
  107.    bmp: TBitmap;
  108. begin
  109.   Clr := ColorToRGB(Color);
  110.   rgb.rgbRed      := Clr and $000000FF;
  111.   rgb.rgbGreen    := (Clr and $0000FF00) shr 8;
  112.   rgb.rgbBlue     := (Clr and $00FFFFFF) shr 16;
  113.   rgb.rgbReserved := 0;
  114.   bmp := TBitmap.Create;
  115.   bmp.PixelFormat := pf32bit;
  116.   bmp.Width := ARect.Right-ARect.Left;
  117.   bmp.Height := ARect.Bottom-ARect.Top;
  118.   bmp.Canvas.CopyRect(Rect(0,0,bmp.Width,bmp.Height), Canvas, ARect);
  119.   tr := 255 - Opacity;
  120.   for i := 0 to bmp.Height-1 do begin
  121.     prgb := PRGBARR(bmp.ScanLine[i]);
  122.     for j := 0 to bmp.Width-1 do
  123.       with prgb[j] do begin
  124.         rgbBlue  := (rgbBlue*tr  + rgb.rgbBlue*Opacity) div 255;
  125.         rgbGreen := (rgbGreen*tr + rgb.rgbGreen*Opacity)div 255;
  126.         rgbRed   := (rgbRed*tr   + rgb.rgbRed*Opacity) div 255;
  127.       end;
  128.   end;
  129.   Canvas.Draw(ARect.Left, ARect.Top, bmp);
  130.   bmp.Free;
  131. end;
  132. {------------------------------------------------------------------------------}
  133. procedure TForm1.FormCreate(Sender: TObject);
  134. var i: Integer;
  135. begin
  136.   RichView1.AddNL('Example',1,1);
  137.   RichView1.AddNL('This is an example of the new feature - ',0,0);
  138.   RichView1.AddNL('custom drawn text',3,-1);
  139.   RichView1.AddNL('.',0,-1);
  140.   RichView1.AddNL(' Hot link 1 ',4,1);
  141.   RichView1.AddNL(' Hot link 2 ',5,1);
  142.   RichView1.AddBreakEx(1, rvbsLine, clBtnShadow);
  143.   RichView1.AddCheckpoint;
  144.   RichView1.AddNL('Another example - a custom drawing of checkpoints.',0,0);
  145.   RichView1.AddCheckpoint;
  146.   RichView1.AddNL('For example, you can draw a little nice arrow instead of default dotted line.',0,0);
  147.   RichView1.AddBreakEx(1, rvbsLine, clBtnShadow);
  148.   RichView1.AddNL('One more example - a custom displaying of page break',0,0);
  149.   RichView1.PageBreaksBeforeItems[RichView1.ItemCount-1] := True;
  150.   RichView1.Format;
  151.   RichView2.AddNL('Cool Effect - ',2,2);
  152.   RichView2.SetAddParagraphMode(False);
  153.   RichView2.AddNL('Transparent paragraph background.',2,2);
  154.   RichView2.AddNL('example of custom painting of paragraph background',0,2);
  155.   RichView2.SetAddParagraphMode(True);
  156.   for i := 0 to 20 do
  157.     RichView2.AddNL('This is the example how to use OnDrawParaBack and OnPaint events.',0,0);
  158.   RichView2.Format;
  159. end;
  160. {------------------------------------------------------------------------------}
  161. { Should RichView repaint itself if mouse is over text of specified style?     }
  162. {------------------------------------------------------------------------------}
  163. procedure TForm1.RVStyle1StyleHoverSensitive(Sender: TRVStyle;
  164.   StyleNo: Integer; var Sensitive: Boolean);
  165. begin
  166.   if StyleNo in [4,5] then
  167.     Sensitive := True; // (default for other styles)
  168. end;
  169. {------------------------------------------------------------------------------}
  170. { Drawing a background of text                                                 }
  171. {------------------------------------------------------------------------------}
  172. procedure TForm1.RVStyle1DrawTextBack(Sender: TRVStyle; Canvas: TCanvas;
  173.   StyleNo, Left, Top, Width, Height: Integer; DrawState: TRVTextDrawStates;
  174.   var DoDefault: Boolean);
  175. var r: TRect;
  176. begin
  177.   case StyleNo of
  178.     5:
  179.       begin
  180.         // drawing a sunken edge for the 5th style
  181.         r := Bounds(Left,Top, Width, Height);
  182.         if rvtsHover in DrawState then
  183.           DrawEdge(Canvas.Handle, r, BDR_SUNKENOUTER or BF_ADJUST, BF_RECT)
  184.       end;
  185.   end;
  186. end;
  187. {------------------------------------------------------------------------------}
  188. { Drawing a text                                                               }
  189. {------------------------------------------------------------------------------}
  190. procedure TForm1.RVStyle1DrawStyleText(Sender: TRVStyle; const s: String;
  191.   Canvas: TCanvas; StyleNo, SpaceBefore, Left, Top, Width, Height: Integer;
  192.   DrawState: TRVTextDrawStates; var DoDefault: Boolean);
  193. begin
  194.   if rvtsSelected in DrawState then
  195.     exit; // default drawing for selected text
  196.   inc(Left, SpaceBefore);
  197.   case StyleNo of
  198.     0:
  199.       begin
  200.         // sunken effect
  201.         Canvas.Font.Color := clBtnHighlight;
  202.         Canvas.TextOut(Left+1,Top+1, s);
  203.         Canvas.Font.Color := clBtnShadow;
  204.         Canvas.TextOut(Left,Top, s);
  205.         DoDefault := False;
  206.       end;
  207.     3:
  208.       begin
  209.         // raised effect
  210.         Canvas.Font.Color := clBtnHighlight;
  211.         Canvas.TextOut(Left-1,Top-1, s);
  212.         Canvas.Font.Color := clBtnShadow;
  213.         Canvas.TextOut(Left+1,Top+1, s);
  214.         DoDefault := False;
  215.       end;
  216.     4:
  217.       begin
  218.         if rvtsHover in DrawState then begin
  219.           // hot glow effect
  220.           Canvas.Font.Color := Sender.TextStyles[StyleNo].HoverColor;
  221.           Canvas.TextOut(Left+1,Top+1, s);
  222.           Canvas.TextOut(Left-1,Top-1, s);
  223.           Canvas.Font.Color := Sender.TextStyles[StyleNo].Color;
  224.           Canvas.TextOut(Left,Top, s);
  225.           DoDefault := False;
  226.         end;
  227.       end;
  228.   end;
  229. end;
  230. {------------------------------------------------------------------------------}
  231. { Drawing checkpoint as arrow icon                                             }
  232. {------------------------------------------------------------------------------}
  233. procedure TForm1.RVStyle1DrawCheckpoint(Sender: TRVStyle; Canvas: TCanvas;
  234.   X, Y, ItemNo, XShift: Integer; RaiseEvent: Boolean; Control: TControl;
  235.   var DoDefault: Boolean);
  236. begin
  237.   if RaiseEvent then
  238.     Canvas.Pen.Color := Sender.CheckpointEvColor
  239.   else
  240.     Canvas.Pen.Color := Sender.CheckpointColor;
  241.   DrawArrow(Canvas, -XShift+2, Y-5, RichView1.LeftMargin-4, 10);
  242.   DoDefault := False;
  243. end;
  244. {------------------------------------------------------------------------------}
  245. { Drawing page break as icon                                                   }
  246. {------------------------------------------------------------------------------}
  247. procedure TForm1.RVStyle1DrawPageBreak(Sender: TRVStyle; Canvas: TCanvas;
  248.   Y, XShift: Integer; PageBreakType: TRVPageBreakType; Control: TControl; var DoDefault: Boolean);
  249. begin
  250.   Canvas.Pen.Color := Sender.PageBreakColor;
  251.   DrawPageIcon(Canvas, -XShift+2, Y-8, 16, 16);
  252.   DoDefault := False;
  253. end;
  254. {------------------------------------------------------------------------------}
  255. { Drawing a background of paragraphs                                           }
  256. {------------------------------------------------------------------------------}
  257. procedure TForm1.RVStyle1DrawParaBack(Sender: TRVStyle; Canvas: TCanvas;
  258.   ParaNo: Integer; ARect: TRect; var DoDefault: Boolean);
  259. begin
  260.   if ParaNo=2 then begin
  261.     // semi-transparent background for second paragraph style
  262.     DrawTrRect(Canvas, ARect, Sender.ParaStyles[ParaNo].Background.Color, 150);
  263.     DoDefault := False;
  264.   end;
  265. end;
  266. {------------------------------------------------------------------------------}
  267. { Drawing unscrollable picture                                                 }
  268. {------------------------------------------------------------------------------}
  269. procedure TForm1.RichView2Paint(Sender: TCustomRichView; Canvas: TCanvas;
  270.   Prepaint: Boolean);
  271. var x,y: Integer;
  272.     r: TRect;
  273. begin
  274.   Canvas.Pen.Color := clRed;
  275.   Canvas.Pen.Width := 3;
  276.   Canvas.Brush.Color := clBlack;
  277.   x := Sender.ClientWidth-10;
  278.   y := Sender.ClientHeight-10;
  279.   Canvas.Ellipse(x-10, y-10, x+10, y+10);
  280.   r := Bounds(x-10, y-10, 20, 20);
  281.   Canvas.Brush.Style := bsClear;
  282.   Canvas.Font.Color := clRed;
  283.   Canvas.Font.Name  := 'Arial';
  284.   Canvas.Font.Style := [fsBold];
  285.   Canvas.Font.Size := 12;  
  286.   DrawText(Canvas.Handle, '!', 1, r, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
  287. end;
  288. procedure TForm1.RichView2RVMouseUp(Sender: TCustomRichView;
  289.   Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
  290. begin
  291.   if (x>Sender.ClientWidth-20) and (y>Sender.ClientHeight-20) then
  292.     Application.MessageBox('!','!', MB_OK or MB_ICONINFORMATION);
  293. end;
  294. end.