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

RichEdit

开发平台:

Delphi

  1. unit Unit1;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   RVStyle, RVScroll, RichView, RVEdit, StdCtrls, ExtCtrls, CRVFData, ShellApi,
  6.   URLScan;
  7. type
  8.   TForm1 = class(TForm)
  9.     Panel1: TPanel;
  10.     btnOpen: TButton;
  11.     btnScan: TButton;
  12.     rve: TRichViewEdit;
  13.     RVStyle1: TRVStyle;
  14.     od: TOpenDialog;
  15.     CheckBox1: TCheckBox;
  16.     procedure btnOpenClick(Sender: TObject);
  17.     procedure btnScanClick(Sender: TObject);
  18.     procedure FormCreate(Sender: TObject);
  19.     procedure rveJump(Sender: TObject; id: Integer);
  20.     procedure rveKeyDown(Sender: TObject; var Key: Word;
  21.       Shift: TShiftState);
  22.   private
  23.     { Private declarations }
  24.     procedure URLScanEvent(OldStyleNo: Integer; var NewStyleNo: Integer;
  25.                            ToHypertext: Boolean);
  26.   public
  27.     { Public declarations }
  28.   end;
  29. var
  30.   Form1: TForm1;
  31. implementation
  32. {$R *.DFM}
  33. {------------------------------------------------------------------------------}
  34. procedure TForm1.FormCreate(Sender: TObject);
  35. begin
  36.   // Uncomment this line to test working with Unicode
  37.   // RVStyle1.TextStyles[0].Unicode := True;
  38.   rve.Clear;
  39.   rve.AddNLATag('This demo shows how to implement URL scanning',0,0,0);
  40.   rve.AddNLATag('Click the button, and URLs (like this - "www.richedit.com/") will be highlighted.',0,0,0);
  41.   rve.AddNLATag('Ctrl+click URL to launch browser or e-mail client',0,0,0);  
  42.   rve.Format;
  43. end;
  44. {------------------------------------------------------------------------------}
  45. procedure TForm1.btnOpenClick(Sender: TObject);
  46. var r: Boolean;
  47. begin
  48.   if not od.Execute then
  49.     exit;
  50.   Screen.Cursor := crHourglass;
  51.   rve.Clear;
  52.   rve.DeleteUnusedStyles(True,True,True);
  53.   case od.FilterIndex of
  54.    1: r := rve.LoadText(od.FileName,0,0,False);
  55.    2: r := rve.LoadRTF(od.FileName);
  56.    else r := False;
  57.   end;
  58.   rve.Format;
  59.   Screen.Cursor := crDefault;
  60.   if not r then
  61.     Application.MessageBox('Error loading file', 'Error', MB_OK or MB_ICONSTOP);
  62. end;
  63. {------------------------------------------------------------------------------}
  64. procedure TForm1.btnScanClick(Sender: TObject);
  65. var r: Boolean;
  66. begin
  67.   Screen.Cursor := crHourglass;
  68.   // Moving caret to the beginning
  69.   rve.SetSelectionBounds(0, rve.GetOffsBeforeItem(0), 0, rve.GetOffsBeforeItem(0));
  70.   // Clearing undo/redo buffers
  71.   rve.ClearUndo;
  72.   // removing old hypertext links
  73.   r := ClearHypertext(rve.RVData, URLScanEvent, True);
  74.   // scanning for URLs
  75.   r := ScanURLs(rve.RVData, URLScanEvent, True) or r;
  76.   if r then
  77.     rve.Format;
  78.   Screen.Cursor := crDefault;
  79.   rve.SetFocus;    
  80. end;
  81. {------------------------------------------------------------------------------}
  82. // Callback procedure
  83. // This procedure should return index of style for converting source style to
  84. procedure TForm1.URLScanEvent(OldStyleNo: Integer; var NewStyleNo: Integer;
  85.   ToHypertext: Boolean);
  86. var Style: TFontInfo;
  87. begin
  88.   // Constructing desired style
  89.   Style := TFontInfo.Create(nil);
  90.   Style.Assign(RVStyle1.TextStyles[OldStyleNo]);
  91.   Style.Jump := ToHypertext;
  92.   if ToHypertext then begin
  93.     // Hypertext links will be blue and underlined
  94.     Style.Style := Style.Style+[fsUnderline];
  95.     Style.Color := clBlue;
  96.     Style.JumpCursor := crJump;
  97.     end
  98.   else begin
  99.     // Plain text will be black and not underlined
  100.     Style.Style := Style.Style-[fsUnderline];
  101.     Style.Color := clWindowText;
  102.   end;
  103.   // May be such style already exists?
  104.   NewStyleNo := RVStyle1.TextStyles.FindSuchStyle(OldStyleNo,Style,RVAllFontInfoProperties);
  105.   if NewStyleNo=-1 then begin
  106.     // Not exists, adding...
  107.     RVStyle1.TextStyles.Add.Assign(Style);
  108.     NewStyleNo := RVStyle1.TextStyles.Count-1;
  109.     RVStyle1.TextStyles[NewStyleNo].Standard := False;
  110.   end;
  111.   Style.Free;
  112. end;
  113. {------------------------------------------------------------------------------}
  114. procedure TForm1.rveJump(Sender: TObject; id: Integer);
  115. var RVData: TCustomRVFormattedData;
  116.     ItemNo: Integer;
  117.     url: String;
  118. begin
  119.    rve.GetJumpPointLocation(id, RVData, ItemNo);
  120.    url := PChar(RVData.GetItemTag(ItemNo));
  121.    ShellExecute(0, 'open', PChar(url), nil, nil, SW_SHOW);
  122. end;
  123. {------------------------------------------------------------------------------}
  124. procedure TForm1.rveKeyDown(Sender: TObject; var Key: Word;
  125.   Shift: TShiftState);
  126. begin
  127.   if Key in [VK_SPACE, VK_RETURN] then begin
  128.     // url detection
  129.     if CheckBox1.Checked then
  130.       DetectURL(rve, URLScanEvent, True);
  131.     // closing url if necessary
  132.     TerminateHyperlink(rve, URLScanEvent); 
  133.   end;
  134. end;
  135. end.