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

RichEdit

开发平台:

Delphi

  1. unit Demo5Frm;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   RVStyle, RVScroll, RichView, StdCtrls, ExtCtrls, Menus, ShellApi;
  6. type
  7.   TfrmDemo5 = class(TForm)
  8.     pan: TPanel;
  9.     edit: TEdit;
  10.     rv: TRichView;
  11.     rvs: TRVStyle;
  12.     pm: TPopupMenu;
  13.     mitFreezescrolling: TMenuItem;
  14.     procedure FormCreate(Sender: TObject);
  15.     procedure FormResize(Sender: TObject);
  16.     procedure editKeyPress(Sender: TObject; var Key: Char);
  17.     procedure rvSelect(Sender: TObject);
  18.     procedure pmPopup(Sender: TObject);
  19.     procedure mitFreezescrollingClick(Sender: TObject);
  20.     procedure rvJump(Sender: TObject; id: Integer);
  21.     procedure FormKeyDown(Sender: TObject; var Key: Word;
  22.       Shift: TShiftState);
  23.   private
  24.     { Private declarations }
  25.   public
  26.     { Public declarations }
  27.   end;
  28. var
  29.   frmDemo5: TfrmDemo5;
  30. implementation
  31. {$R *.DFM}
  32. {--------------------------------------------------------------}
  33. function IsAddress(s: String): Boolean;
  34. begin
  35.   // Checks for prefix.
  36.   // For better results, it should check for lengths...
  37.   s := UpperCase(s);
  38.   Result :=
  39.         (Pos('HTTP://',   s)=1) or
  40.         (Pos('FTP://',    s)=1) or
  41.         (Pos('FILE://',   s)=1) or
  42.         (Pos('GOPHER://', s)=1) or
  43.         (Pos('MAILTO://', s)=1) or        
  44.         (Pos('HTTPS://',  s)=1) or
  45.         (Pos('MAILTO:',   s)=1) or
  46.         (Pos('NEWS:',     s)=1) or
  47.         (Pos('TELNET:',   s)=1) or
  48.         (Pos('WAIS:',     s)=1) or
  49.         (Pos('WWW.',      s)=1) or
  50.         (Pos('FTP.',      s)=1);
  51. end;
  52. {--------------------------------------------------------------}
  53. function IsEmail(const s: String): Boolean;
  54. var p1, p2: Integer;
  55.    pchr: PChar;
  56. begin
  57.   //'@' must exist and '.' must be after it. This is not comprehensive test,
  58.   //but I think that it's ok 
  59.   Result := False;
  60.   p1 := Pos('@', s);
  61.   if p1=0 then exit;
  62.   pchr := StrRScan(PChar(s),'.');
  63.   if pchr = nil then exit;
  64.   p2 := pchr - PChar(s)+1;
  65.   if p1>p2 then exit;
  66.   Result := True;
  67. end;
  68. {--------------------------------------------------------------}
  69. procedure AddWithURLs(s: String; rv: TRichView; DefStyle, UrlStyle: Integer);
  70. var Before, CurrentWord, Space: String;
  71.     p: Integer;
  72.     ParaNo: Integer;
  73. begin
  74.    ParaNo := 0;
  75.    Before := '';
  76.    if s = '' then begin
  77.      rv.AddNL('', DefStyle, ParaNo);
  78.      exit;
  79.    end;
  80.    while s<>'' do begin
  81.      p := Pos(' ', s);
  82.      if p=0 then p := Length(s)+1;
  83.      CurrentWord := Copy(s, 1, p-1);
  84.      Space := Copy(s, p, 1);
  85.      s := Copy(s, p+1, Length(s));
  86.      if IsAddress(CurrentWord) or IsEmail(CurrentWord) then begin
  87.         if Before<>'' then begin
  88.           rv.AddNL(Before, DefStyle, ParaNo);
  89.           ParaNo := -1;
  90.           Before := '';
  91.         end;
  92.         rv.AddNL(CurrentWord, UrlStyle, ParaNo);
  93.         ParaNo := -1;
  94.         if Space<>'' then rv.Add(Space, DefStyle);
  95.         end
  96.      else
  97.        Before := Before + CurrentWord+Space;
  98.    end;
  99.    if Before<>'' then
  100.      rv.AddNL(Before, DefStyle, ParaNo);
  101. end;
  102. {--------------------------------------------------------------}
  103. procedure TfrmDemo5.FormCreate(Sender: TObject);
  104. begin
  105.   pan.ClientHeight := edit.Height;
  106.   edit.SetBounds(0,0,pan.ClientWidth,pan.ClientHeight);
  107.   rv.AddNL('Use right-click menu to freeze scrolling when appending text', 2, 0);
  108.   rv.AddNL('Try quick-copy: selection is copied automatically when done', 2, 0);
  109.   AddWithURLs('You can use URLs and e-mail ( like www.trichview.com )',
  110.               rv, 2, 1);
  111.   rv.Format;
  112. end;
  113. {--------------------------------------------------------------}
  114. procedure TfrmDemo5.FormResize(Sender: TObject);
  115. begin
  116.  edit.Width := pan.ClientWidth;
  117. end;
  118. {--------------------------------------------------------------}
  119. procedure TfrmDemo5.editKeyPress(Sender: TObject; var Key: Char);
  120. begin
  121.   if Key=#13 then begin
  122.     AddWithURLS(edit.Text,rv,0,1);
  123.     rv.FormatTail;
  124.     Key := #0;
  125.     edit.Text := '';
  126.   end;
  127. end;
  128. {--------------------------------------------------------------}
  129. procedure TfrmDemo5.rvSelect(Sender: TObject);
  130. begin
  131.   // Quick-copy
  132.   if rv.SelectionExists then begin
  133.     rv.CopyDef;
  134.     rv.Deselect;
  135.     rv.Invalidate;
  136.   end;
  137. end;
  138. {--------------------------------------------------------------}
  139. procedure TfrmDemo5.pmPopup(Sender: TObject);
  140. begin
  141.   mitFreezeScrolling.Checked := not (rvoScrollToEnd in rv.Options);
  142. end;
  143. {--------------------------------------------------------------}
  144. procedure TfrmDemo5.mitFreezescrollingClick(Sender: TObject);
  145. begin
  146.   if (rvoScrollToEnd in rv.Options) then
  147.     rv.Options := rv.Options-[rvoScrollToEnd]
  148.   else
  149.     rv.Options := rv.Options+[rvoScrollToEnd];
  150. end;
  151. {--------------------------------------------------------------}
  152. procedure TfrmDemo5.rvJump(Sender: TObject; id: Integer);
  153. var ItemNo: Integer;
  154.     s: String;
  155. begin
  156.   ItemNo := rv.GetJumpPointItemNo(id);
  157.   s := rv.GetItemText(ItemNo);
  158.   if not IsAddress(s) and IsEmail(s) then
  159.     s := 'mailto:'+s;
  160.   ShellExecute(Application.Handle, 'open', PChar(s), nil, nil, SW_NORMAL);
  161. end;
  162. {--------------------------------------------------------------}
  163. procedure TfrmDemo5.FormKeyDown(Sender: TObject; var Key: Word;
  164.   Shift: TShiftState);
  165. begin
  166.   if Key=VK_ESCAPE then Close;
  167. end;
  168. end.