urlscan.pas

与Action相结合,可以解决中文件显示乱码

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 [' ',',','(',')',';','"','''', '