URLScan.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:18k
- unit URLScan;
- {==============================================================================}
- { Scanning RichView for URLs }
- { Copyright (c) 2001,2003 by Sergey Tkachenko }
- { StrPosW is from http://www.delphi-unicode.net/Library.php }
- {==============================================================================}
- { ClearHypertext allows to convert all (or selected) hypertext links }
- { to normal text. }
- { ScanURLs searches for URLs and makes them hypertext }
- { These functions receive new style for text via call of URLScanProcedure. }
- { Calling for TRichViewEdit.RVData requires call ClearUndo before. }
- { DetectURL and TerminateHyperlink allow url detection on typing. }
- {------------------------------------------------------------------------------}
- { Unicode text is not processed in Delphi2 and C++Builder1. }
- { Unicode uppercase URLs can be processed only in WinNT/2000/XP }
- {==============================================================================}
- interface
- {$I RV_Defs.inc}
- uses Windows, Messages, SysUtils, Classes,
- RVStyle, RVScroll, RichView, CRVFData, RVTable, RVEdit, RVFuncs, RVItem;
- type
- TRVURLScanProcedure = procedure (OldStyleNo: Integer;
- var NewStyleNo: Integer; ToHypertext: Boolean) of object;
- // Document scanning
- function ScanURLs(RVData: TCustomRVFormattedData;
- URLScanProcedure: TRVURLScanProcedure; AssignTags: Boolean): Boolean;
- function ClearHypertext(RVData: TCustomRVFormattedData;
- URLScanProcedure: TRVURLScanProcedure; ClearTags: Boolean): Boolean;
- // Detect on typing
- procedure TerminateHyperlink(rve: TCustomRichViewEdit;
- URLScanProcedure: TRVURLScanProcedure);
- procedure DetectURL(rve: TCustomRichViewEdit; URLScanProcedure: TRVURLScanProcedure;
- AssignTags: Boolean);
- implementation
- uses CRVData;
- {======================= Processing ANSI text =================================}
- function IsAddress(const str: String): Boolean;
- var s: String;
- begin
- // Checks for prefix.
- // For better results, it should check for lengths...
- s := AnsiLowerCase(str);
- Result :=
- (Pos('http://', s)=1) or
- (Pos('ftp://', s)=1) or
- (Pos('file://', s)=1) or
- (Pos('gopher://', s)=1) or
- (Pos('mailto:', s)=1) or
- (Pos('https://', s)=1) or
- (Pos('news:', s)=1) or
- (Pos('telnet:', s)=1) or
- (Pos('wais:', s)=1) or
- (Pos('www.', s)=1) or
- (Pos('ftp.', s)=1);
- end;
- {--------------------------------------------------------------}
- function IsEmail(const s: String): Boolean;
- var p1, p2: Integer;
- pchr: PChar;
- begin
- //'@' must exist and '.' must be after it. This is not comprehensive test,
- //but I think that it's ok
- Result := False;
- p1 := Pos('@', s);
- if p1=0 then exit;
- pchr := StrRScan(PChar(s),'.');
- if pchr = nil then exit;
- p2 := pchr - PChar(s)+1;
- if p1>p2 then exit;
- Result := True;
- end;
- {--------------------------------------------------------------}
- function FindChar(pc: PChar; Len: Integer): Integer;
- var i: Integer;
- begin
- for i := 0 to Len-1 do
- if pc[i] in [' ',',','(',')',';','"','''', '