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

RichEdit

开发平台:

Delphi

  1. unit URLScan;
  2. {==============================================================================}
  3. { Scanning RichView for URLs                                                   }
  4. { Copyright (c) 2001,2003 by Sergey Tkachenko                                  }
  5. { StrPosW is from http://www.delphi-unicode.net/Library.php                    }
  6. {==============================================================================}
  7. { ClearHypertext allows to convert all (or selected) hypertext links           }
  8. { to normal text.                                                              }
  9. { ScanURLs searches for URLs and makes them hypertext                          }
  10. { These functions receive new style for text via call of URLScanProcedure.     }
  11. { Calling for TRichViewEdit.RVData requires call ClearUndo before.             }
  12. { DetectURL and TerminateHyperlink allow url detection on typing.              }
  13. {------------------------------------------------------------------------------}
  14. { Unicode text is not processed in Delphi2 and C++Builder1.                    }
  15. { Unicode uppercase URLs can be processed only in WinNT/2000/XP                }
  16. {==============================================================================}
  17. interface
  18. {$I RV_Defs.inc}
  19. uses Windows, Messages, SysUtils, Classes,
  20.      RVStyle, RVScroll, RichView, CRVFData, RVTable, RVEdit, RVFuncs, RVItem;
  21. type
  22.   TRVURLScanProcedure = procedure (OldStyleNo: Integer;
  23.     var NewStyleNo: Integer; ToHypertext: Boolean) of object;
  24. // Document scanning
  25. function ScanURLs(RVData: TCustomRVFormattedData;
  26.   URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
  27. function ClearHypertext(RVData: TCustomRVFormattedData;
  28.   URLScanProcedure: TRVURLScanProcedure; ClearTags: Boolean): Boolean;
  29. // Detect on typing
  30. procedure TerminateHyperlink(rve: TCustomRichViewEdit;
  31.   URLScanProcedure: TRVURLScanProcedure);
  32. procedure DetectURL(rve: TCustomRichViewEdit; URLScanProcedure: TRVURLScanProcedure;
  33.   AssignTags: Boolean);
  34. implementation
  35. uses CRVData;
  36. {======================= Processing ANSI text =================================}
  37. function IsAddress(const str: String): Boolean;
  38. var s: String;
  39. begin
  40.   // Checks for prefix.
  41.   // For better results, it should check for lengths...
  42.   s := AnsiLowerCase(str);
  43.   Result :=
  44.         (Pos('http://',   s)=1) or
  45.         (Pos('ftp://',    s)=1) or
  46.         (Pos('file://',   s)=1) or
  47.         (Pos('gopher://', s)=1) or
  48.         (Pos('mailto:', s)=1) or
  49.         (Pos('https://',  s)=1) or
  50.         (Pos('news:',     s)=1) or
  51.         (Pos('telnet:',   s)=1) or
  52.         (Pos('wais:',     s)=1) or
  53.         (Pos('www.',      s)=1) or
  54.         (Pos('ftp.',      s)=1);
  55. end;
  56. {--------------------------------------------------------------}
  57. function IsEmail(const s: String): Boolean;
  58. var p1, p2: Integer;
  59.    pchr: PChar;
  60. begin
  61.   //'@' must exist and '.' must be after it. This is not comprehensive test,
  62.   //but I think that it's ok
  63.   Result := False;
  64.   p1 := Pos('@', s);
  65.   if p1=0 then exit;
  66.   pchr := StrRScan(PChar(s),'.');
  67.   if pchr = nil then exit;
  68.   p2 := pchr - PChar(s)+1;
  69.   if p1>p2 then exit;
  70.   Result := True;
  71. end;
  72. {--------------------------------------------------------------}
  73. function FindChar(pc: PChar; Len: Integer): Integer;
  74. var i: Integer;
  75. begin
  76.   for i := 0 to Len-1 do
  77.     if pc[i] in [' ',',','(',')',';','"','''', '