Code:

{ **** UBPFD *********** by delphibase.endimus  ****

>> Расщепление строки с разделителями на массив строк

Зависимости: System

Автор: ALL.exe, Alexe @ 054.pfr.ru, ICQ:161857370, Kostroma

Copyright: ALL.exe

***************************************************** }

type

TSepArr = arrayofstring; // массив "записей"

TSepRec = record

Rec: TSepArr; // сами "записи"

Max: integer; // количество полученных "записей"

end;

function GetSeparatorRec(const sRows: string;

cSeparator: char = ','): TSepRec;

var

cCol: arrayof integer;

i, j: integer;

bSTRING: boolean;

begin

Result.Max := -1;

j := 1;

bSTRING := False;

SetLength(cCol, j);

cCol[0] := 0;

for i := 1to Length(sRows) do

begin

if sRows[i] = '"'then

bSTRING := not bSTRING;

if (sRows[i] = cSeparator) and (not bSTRING) then

begin

j := j + 1;

SetLength(cCol, j);

cCol[j - 1] := i;

end;

end;

j := j + 1;

SetLength(cCol, j);

cCol[j - 1] := Length(sRows) + 1;

Result.Max := High(cCol);

if Result.Max > 0then

begin

SetLength(Result.Rec, Result.Max + 1);

Result.Rec[0] := IntToStr(Result.Max);

for i := 1to Result.Max do

Result.Rec[i] := Copy(sRows, cCol[i - 1] + 1, cCol[i] - cCol[i - 1] - 1);

end;

end;

//Пример использования:

var

R: TSepRec;

begin

R := GetSeparatorRec('123.45-ABCDEF-"A-B-C"-"0"-', '-');

// результат:

R.Max = 5;

R.Rec = ('5', '123.45', 'ABCDEF', '"A;B;C"', '"0"', '');

Code:

unit sparfunc;

interface

uses

sysutils, classes;

function antaltecken (orgtext,soktext : string) : integer;

function beginsWith (text,teststreng : string):boolean;

function endsWith (text,teststreng : string):boolean;

function hamtastreng (text,strt,slut : string):string;

function hamtastrengmellan (text,strt,slut : string):string;

function nastadelare (progtext : string):integer;

function rtf2sgml (text : string) : string;

function sgml2win(text : string) : string;

function sgml2mac(text : string) : string;

function sgml2rtf(text : string) : string;

function sistamening(text : string) : string;

function stringnthfield (text,delim : string; vilken : integer) : string;

function stringreplace (text,byt,mot : string) : string;

function stringreplaceall (text,byt,mot : string) : string;

function text2sgml (text : string) : string;

procedure SurePath (pathen : string);

procedure KopieraFil (infil,utfil : string);

function LasInEnTextfil (filnamn : string) : string;

implementation

function LasInEnTextfil (filnamn : string) : string;

var

infil : textfile;

temptext, filtext : string;

begin

filtext := '';

//Oppna angiven fil och las in den

try

assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname

reset (infil); //Oppna filen

//Sa lange vi inte natt slutet

whilenot eof(infil) do

begin

readln (infil,temptext); //Las in en rad

filtext := filtext+temptext; //Lagg den till variabeln SGMLTEXT

end;

finally

closefile (infil); //Stang filen

end;

result := filtext;

end;

procedure KopieraFil (infil,utfil : string);

var

InStream : TFileStream;

OutStream : TFileStream;

begin

InStream := TFileStream.Create(infil,fmOpenRead);

try

OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate);

try

OutStream.CopyFrom(InStream,0);

finally

OutStream.Free;

end;

finally

InStream.Free;

end;

end;

procedure SurePath (pathen : string);

var

temprad,del1 : string;

antal : integer;

begin

antal := antaltecken (pathen,'\');

if antal < 3then

createdir(pathen)

else

begin

if pathen[length(pathen)] < > '\'then

pathen := pathen+'\';

pathen := stringreplace(pathen,'\','/');

del1 := copy(pathen,1,pos('\',pathen));

pathen := stringreplace(pathen,del1,'');

del1 := stringreplace(del1,'/','\');

createdir (del1);

while pathen < > ''do

begin

temprad := copy(pathen,1,pos('\',pathen));

pathen := stringreplace(pathen,temprad,'');

del1 := del1+ temprad;

temprad := '';

createdir(del1);

end;

end;

end;

function antaltecken (orgtext,soktext : string) : integer;

var

i,traffar,soklengd : integer;

begin

traffar := 0;

soklengd := length(soktext);

for i := 1to length(orgtext) do

if soktext = copy(orgtext,i,soklengd) then

traffar := traffar +1;

result := traffar;

end;

function nastadelare (progtext : string):integer;

var

i,j : integer;

begin

i := pos('.',progtext);

j := pos('!',progtext);

if (j < i) and (j > 0) then

i := j;

j := pos('!',progtext);

if (j < i) and (j > 0) then

i := j;

j := pos('?',progtext);

if (j < i) and (j > 0) then

i := j;

result := i;

end;

function stringnthfield (text,delim : string; vilken : integer) : string;

var

start,slut,i : integer;

temptext : string;

begin

start := 0;

if vilken > 0then

begin

temptext := text;

if vilken = 1then

begin

start := 1;

slut := pos (delim,text);

end

else

begin

for i:= 1to vilken -1do

begin

start := pos(delim,temptext)+length(delim);

temptext := copy(temptext,start,length(temptext));

end;

slut := pos (delim,temptext);

end;

if start > 0then

begin

if slut = 0then

slut := length(text);

result := copy (temptext,1,slut-1);

end

else

result := text;

end

else

result := text;

end;

function StringReplaceAll (text,byt,mot : string ) :string;

{Funktion for att byta ut alla forekomster av en strang mot en

annan strang in en strang. Den konverterade strangen returneras.

Om byt finns i mot maste vi ga via en temporar variant!!!}

var

plats : integer;

begin

while pos(byt,text) > 0do

begin

plats := pos(byt,text);

delete (text,plats,length(byt));

insert (mot,text,plats);

end;

result := text;

end;

function StringReplace (text,byt,mot : string ) :string;

{Funktion for att byta ut den forsta forekomsten av en strang mot en

annan strang in en strang. Den konverterade strangen returneras.}

var

plats : integer;

begin

if pos(byt,text) > 0then

begin

plats := pos(byt,text);

delete (text,plats,length(byt));

insert (mot,text,plats);

end;

result := text;

end;

function hamtastreng (text,strt,slut : string):string;

{Funktion for att hamta ut en delstrang ur en annan strang.

Om start och slut finns i text sa returneras en strang dar start

ingar i borjan och fram till tecknet fore slut.}

var

stplats,slutplats : integer;

resultat : string;

begin

resultat :='';

stplats := pos(strt,text);

if stplats > 0then

begin

text := copy (text,stplats,length(text));

slutplats := pos(slut,text);

if slutplats > 0then

resultat := copy(text,1,slutplats-1);

end;

result := resultat;

end;

function hamtastrengmellan (text,strt,slut : string):string;

{Funktion for att hamta ut en delstrang ur en annan strang.

Om start och slut finns i text sa returneras en strang dar start

ingar i borjan och fram till tecknet fore slut.}

var

stplats,slutplats : integer;

resultat : string;

begin

resultat :='';

stplats := pos(strt,text);

if stplats > 0then

begin

text := copy (text,stplats+length(strt),length(text));

slutplats := pos(slut,text);

if slutplats > 0then

resultat := copy(text,1,slutplats-1);

end;

result := resultat;

end;

function endsWith (text,teststreng : string):boolean;

{Kollar om en strang slutar med en annan strang.

Returnerar true eller false.}

var

textlngd,testlngd : integer;

kollstreng : string;

begin

testlngd := length(teststreng);

textlngd := length (text);

if textlngd > testlngd then

begin

kollstreng := copy (text,(textlngd+1)-testlngd,testlngd);

if kollstreng = teststreng then

result := true

else

result := false;

end

else

result := false;

end;

function beginsWith (text,teststreng : string):boolean;

{Funktion for att kolla om text borjar med teststreng.

Returnerar true eller false.}

var

textlngd,testlngd : integer;

kollstreng : string;

begin

testlngd := length(teststreng);

textlngd := length (text);

if textlngd > = testlngd then

begin

kollstreng := copy (text,1,testlngd);

if kollstreng = teststreng then

result := true

else

result := false;

end

else

result := false;

end;

function sistamening(text : string) : string;

//Funktion for att ta fram sista meningen i en strang. Soker pa !?.

var

i:integer;

begin

i :=length(text)-1;

while (copy(text,i,1) < > '.') and (copy(text,i,1) < > '!')

and (copy(text,i,1) < > '?') do

begin

dec(i);

if i =1then

break

end;

if i > 1then

result := copy(text,i,length(text))

else

result := '';

end;

function text2sgml(text : string) : string;

{Funktion som byter ut alla ovanliga tecken mot entiteter.

Den fardiga texten returneras.}

begin

text := stringreplaceall (text,'&','##amp;');

text := stringreplaceall (text,'##amp','&');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'?','?');

text := stringreplaceall (text,'?','&Aelig;');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'c','c');

text := stringreplaceall (text,'C','C');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'n','n');

text := stringreplaceall (text,'N','N');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'y','y');

text := stringreplaceall (text,'Y','Y');

text := stringreplaceall (text,'y','y');

text := stringreplaceall (text,'|',' ');

result := text;

end;

function sgml2win(text : string) : string;

{Funktion som ersatter alla entiteter mot deras tecken i

windows. Den fardiga strangen returneras.}

begin

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'?','?');

text := stringreplaceall (text,'&Aelig;','?');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'A' ,'A');

text := stringreplaceall (text,'a' ,'a');

text := stringreplaceall (text,'a','a');

text := stringreplaceall (text,'A','A');

text := stringreplaceall (text,'c','c');

text := stringreplaceall (text,'C','C');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'e','e');

text := stringreplaceall (text,'E','E');

text := stringreplaceall (text,'e' ,'e');

text := stringreplaceall (text,'E' ,'E');

text := stringreplaceall (text,'e' ,'e');

text := stringreplaceall (text,'E' ,'E');

text := stringreplaceall (text,'i' ,'i');

text := stringreplaceall (text,'I' ,'I');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'i','i');

text := stringreplaceall (text,'I','I');

text := stringreplaceall (text,'i' ,'i');

text := stringreplaceall (text,'I' ,'I');

text := stringreplaceall (text,'n','n');

text := stringreplaceall (text,'N','N');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'O' ,'O');

text := stringreplaceall (text,'o' ,'o');

text := stringreplaceall (text,'o','o');

text := stringreplaceall (text,'O','O');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'u' ,'u');

text := stringreplaceall (text,'U' ,'U');

text := stringreplaceall (text,'U','U');

text := stringreplaceall (text,'u','u');

text := stringreplaceall (text,'y','y');

text := stringreplaceall (text,'Y','Y');

text := stringreplaceall (text,'y' ,'y');

text := stringreplaceall (text,' ','|');

text := stringreplaceall (text,'&','&');

result := text;

end;

function sgml2mac(text : string) : string;

{Funktion som ersatter alla entiteter mot deras tecken i

mac. Den fardiga strangen returneras.}

begin

text := stringreplaceall (text,'a',chr(135));

text := stringreplaceall (text,'A',chr(231));

text := stringreplaceall (text,'?',chr(190));

text := stringreplaceall (text,'&Aelig;',chr(174));

text := stringreplaceall (text,'a',chr(136));

text := stringreplaceall (text,'A',chr(203));

text := stringreplaceall (text,'a',chr(140));

text := stringreplaceall (text,'A',chr(129));

text := stringreplaceall (text,'A',chr(128));

text := stringreplaceall (text,'a',chr(138));

text := stringreplaceall (text,'A' ,chr(229));

text := stringreplaceall (text,'a' ,chr(137));

text := stringreplaceall (text,'a',chr(139));

text := stringreplaceall (text,'A',chr(204));

text := stringreplaceall (text,'c',chr(141));

text := stringreplaceall (text,'C',chr(130));

text := stringreplaceall (text,'e',chr(142));

text := stringreplaceall (text,'E',chr(131));

text := stringreplaceall (text,'e',chr(143));

text := stringreplaceall (text,'E',chr(233));

text := stringreplaceall (text,'e' ,chr(144));

text := stringreplaceall (text,'E' ,chr(230));

text := stringreplaceall (text,'e' ,chr(145));

text := stringreplaceall (text,'E' ,chr(232));

text := stringreplaceall (text,'i' ,chr(148));

text := stringreplaceall (text,'I' ,chr(235));

text := stringreplaceall (text,'i' ,chr(146));

text := stringreplaceall (text,'I' ,chr(234));

text := stringreplaceall (text,'i' ,chr(147));

text := stringreplaceall (text,'I' ,chr(237));

text := stringreplaceall (text,'i' ,chr(149));

text := stringreplaceall (text,'I' ,chr(236));

text := stringreplaceall (text,'n',chr(150));

text := stringreplaceall (text,'N',chr(132));

text := stringreplaceall (text,'o',chr(152));

text := stringreplaceall (text,'O',chr(241));

text := stringreplaceall (text,'o',chr(151));

text := stringreplaceall (text,'O',chr(238));

text := stringreplaceall (text,'O' ,chr(239));

text := stringreplaceall (text,'o' ,chr(153));

text := stringreplaceall (text,'o',chr(191));

text := stringreplaceall (text,'O',chr(175));

text := stringreplaceall (text,'o',chr(155));

text := stringreplaceall (text,'O',chr(239));

text := stringreplaceall (text,'o',chr(154));

text := stringreplaceall (text,'O',chr(133));

text := stringreplaceall (text,'u',chr(159));

text := stringreplaceall (text,'U',chr(134));

text := stringreplaceall (text,'u',chr(156));

text := stringreplaceall (text,'U',chr(242));

text := stringreplaceall (text,'u' ,chr(158));

text := stringreplaceall (text,'U' ,chr(243));

text := stringreplaceall (text,'U',chr(244));

text := stringreplaceall (text,'u',chr(157));

text := stringreplaceall (text,'y','y');

text := stringreplaceall (text,'y' ,chr(216));

text := stringreplaceall (text,'Y' ,chr(217));

text := stringreplaceall (text,' ',' ');

text := stringreplaceall (text,'&',chr(38));

result := text;

end;

function sgml2rtf(text : string) : string;

{Funktion for att byta ut sgml-entiteter mot de koder som

galler i RTF-textrutorna.}

begin

text := stringreplaceall (text,'}','#]#');

text := stringreplaceall (text,'{','#[#');

text := stringreplaceall (text,'\','HSALSKCAB');

text := stringreplaceall (text,'HSALSKCAB','\\');

text := stringreplaceall (text,'?','\'+chr(39)+'c6');

text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6');

text := stringreplaceall (text,'a','\'+chr(39)+'e1');

text := stringreplaceall (text,'A','\'+chr(39)+'c1');

text := stringreplaceall (text,'a','\'+chr(39)+'e0');

text := stringreplaceall (text,'A','\'+chr(39)+'c0');

text := stringreplaceall (text,'a','\'+chr(39)+'e5');

text := stringreplaceall (text,'A','\'+chr(39)+'c5');

text := stringreplaceall (text,'A','\'+chr(39)+'c2');

text := stringreplaceall (text,'a','\'+chr(39)+'e2');

text := stringreplaceall (text,'a','\'+chr(39)+'e3');

text := stringreplaceall (text,'A','\'+chr(39)+'c3');

text := stringreplaceall (text,'a','\'+chr(39)+'e4');

text := stringreplaceall (text,'A','\'+chr(39)+'c4');

text := stringreplaceall (text,'c','\'+chr(39)+'e7');

text := stringreplaceall (text,'C','\'+chr(39)+'c7');

text := stringreplaceall (text,'e','\'+chr(39)+'e9');

text := stringreplaceall (text,'E','\'+chr(39)+'c9');

text := stringreplaceall (text,'e','\'+chr(39)+'e8');

text := stringreplaceall (text,'E','\'+chr(39)+'c8');

text := stringreplaceall (text,'e','\'+chr(39)+'ea');

text := stringreplaceall (text,'E','\'+chr(39)+'ca');

text := stringreplaceall (text,'e','\'+chr(39)+'eb');

text := stringreplaceall (text,'E','\'+chr(39)+'cb');

text := stringreplaceall (text,'i','\'+chr(39)+'ee');

text := stringreplaceall (text,'I','\'+chr(39)+'ce');

text := stringreplaceall (text,'i','\'+chr(39)+'ed');

text := stringreplaceall (text,'I','\'+chr(39)+'cd');

text := stringreplaceall (text,'i','\'+chr(39)+'ec');

text := stringreplaceall (text,'I','\'+chr(39)+'cc');

text := stringreplaceall (text,'i' ,'\'+chr(39)+'ef');

text := stringreplaceall (text,'I' ,'\'+chr(39)+'cf');

text := stringreplaceall (text,'n','\'+chr(39)+'f1');

text := stringreplaceall (text,'N','\'+chr(39)+'d1');

text := stringreplaceall (text,'o','\'+chr(39)+'f6');

text := stringreplaceall (text,'O','\'+chr(39)+'d6');

text := stringreplaceall (text,'o','\'+chr(39)+'f3');

text := stringreplaceall (text,'O','\'+chr(39)+'d3');

text := stringreplaceall (text,'o','\'+chr(39)+'f2');

text := stringreplaceall (text,'O','\'+chr(39)+'d2');

text := stringreplaceall (text,'o','\'+chr(39)+'f8');

text := stringreplaceall (text,'O','\'+chr(39)+'d8');

text := stringreplaceall (text,'O','\'+chr(39)+'d4');

text := stringreplaceall (text,'o','\'+chr(39)+'f4');

text := stringreplaceall (text,'o','\'+chr(39)+'f5');

text := stringreplaceall (text,'O','\'+chr(39)+'d5');

text := stringreplaceall (text,'u','\'+chr(39)+'fa');

text := stringreplaceall (text,'U','\'+chr(39)+'da');

text := stringreplaceall (text,'u','\'+chr(39)+'fb');

text := stringreplaceall (text,'U','\'+chr(39)+'db');

text := stringreplaceall (text,'U','\'+chr(39)+'d9');

text := stringreplaceall (text,'u','\'+chr(39)+'f9');

text := stringreplaceall (text,'u','\'+chr(39)+'fc');

text := stringreplaceall (text,'U','\'+chr(39)+'dc');

text := stringreplaceall (text,'y','\'+chr(39)+'fd');

text := stringreplaceall (text,'Y','\'+chr(39)+'dd');

text := stringreplaceall (text,'y','\'+chr(39)+'ff');

text := stringreplaceall (text,'?','\'+chr(39)+'a3');

text := stringreplaceall (text,'#]#','\}');

text := stringreplaceall (text,'#[#','\{');

text := stringreplaceall (text,' ','|');

text := stringreplaceall (text,'&','&');

result := text;

end;

function rtf2sgml (text : string) : string;

{Funktion for att konvertera en RTF-rad till SGML-text.}

var

temptext : string;

start : integer;

begin

text := stringreplaceall (text,'&','##amp;');

text := stringreplaceall (text,'##amp','&');

text := stringreplaceall (text,'\'+chr(39)+'c6','?');

text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;');

text := stringreplaceall (text,'\'+chr(39)+'e5','a');

text := stringreplaceall (text,'\'+chr(39)+'c5','A');

text := stringreplaceall (text,'\'+chr(39)+'e4','a');

text := stringreplaceall (text,'\'+chr(39)+'c4','A');

text := stringreplaceall (text,'\'+chr(39)+'e1','a');

text := stringreplaceall (text,'\'+chr(39)+'c1','A');

text := stringreplaceall (text,'\'+chr(39)+'e0','a');

text := stringreplaceall (text,'\'+chr(39)+'c0','A');

text := stringreplaceall (text,'\'+chr(39)+'c2','A');

text := stringreplaceall (text,'\'+chr(39)+'e2','a');

text := stringreplaceall (text,'\'+chr(39)+'e3','a');

text := stringreplaceall (text,'\'+chr(39)+'c3','A');

text := stringreplaceall (text,'\'+chr(39)+'e7','c');

text := stringreplaceall (text,'\'+chr(39)+'c7','C');

text := stringreplaceall (text,'\'+chr(39)+'e9','e');

text := stringreplaceall (text,'\'+chr(39)+'c9','E');

text := stringreplaceall (text,'\'+chr(39)+'e8','e');

text := stringreplaceall (text,'\'+chr(39)+'c8','E');

text := stringreplaceall (text,'\'+chr(39)+'ea','e');

text := stringreplaceall (text,'\'+chr(39)+'ca','E');

text := stringreplaceall (text,'\'+chr(39)+'eb','e');

text := stringreplaceall (text,'\'+chr(39)+'cb','E');

text := stringreplaceall (text,'\'+chr(39)+'ee','i');

text := stringreplaceall (text,'\'+chr(39)+'ce','I');

text := stringreplaceall (text,'\'+chr(39)+'ed','i');

text := stringreplaceall (text,'\'+chr(39)+'cd','I');

text := stringreplaceall (text,'\'+chr(39)+'ec','i');

text := stringreplaceall (text,'\'+chr(39)+'cc','I');

text := stringreplaceall (text,'\'+chr(39)+'ef','i');

text := stringreplaceall (text,'\'+chr(39)+'cf','I');

text := stringreplaceall (text,'\'+chr(39)+'f1','n');

text := stringreplaceall (text,'\'+chr(39)+'d1','N');

text := stringreplaceall (text,'\'+chr(39)+'f3','o');

text := stringreplaceall (text,'\'+chr(39)+'d3','O');

text := stringreplaceall (text,'\'+chr(39)+'f2','o');

text := stringreplaceall (text,'\'+chr(39)+'d2','O');

text := stringreplaceall (text,'\'+chr(39)+'d4','O');

text := stringreplaceall (text,'\'+chr(39)+'f4','o');

text := stringreplaceall (text,'\'+chr(39)+'f5','o');

text := stringreplaceall (text,'\'+chr(39)+'d5','O');

text := stringreplaceall (text,'\'+chr(39)+'f8','o');

text := stringreplaceall (text,'\'+chr(39)+'d8','O');

text := stringreplaceall (text,'\'+chr(39)+'f6','o');

text := stringreplaceall (text,'\'+chr(39)+'d6','O');

text := stringreplaceall (text,'\'+chr(39)+'fc','u');

text := stringreplaceall (text,'\'+chr(39)+'dc','U');

text := stringreplaceall (text,'\'+chr(39)+'fa','u');

text := stringreplaceall (text,'\'+chr(39)+'da','U');

text := stringreplaceall (text,'\'+chr(39)+'fb','u');

text := stringreplaceall (text,'\'+chr(39)+'db','U');

text := stringreplaceall (text,'\'+chr(39)+'d9','U');

text := stringreplaceall (text,'\'+chr(39)+'f9','u');

text := stringreplaceall (text,'\'+chr(39)+'fd','y');

text := stringreplaceall (text,'\'+chr(39)+'dd','Y');

text := stringreplaceall (text,'\'+chr(39)+'ff','y');

text := stringreplaceall (text,'|',' ');

text := stringreplaceall (text,'\'+chr(39)+'a3','?');

text := stringreplaceall (text,'\}','#]#');

text := stringreplaceall (text,'\{','#[#');

if (beginswith (text, '{\rtf1\')) or

(beginswith (text, '{\colortbl\')) then

begin

result := '';

exit;

end;

//text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}

//temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort}

//text := stringreplace (text,temptext,'');

//temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort}

//text := stringreplace (text,temptext,'');

//temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort}

//text := stringreplace (text,temptext,'');

//text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}

//text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}

{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort

det efter \fs16 och la istallet en egen tvatt av \cf0.}

//temptext := hamtastreng (text,'{\rtf1','\deflang');

//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}

text := stringreplaceall (text,'\cf0','');

temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }

text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}

text := stringreplaceall (text,'\ltrpar','');

text := stringreplaceall (text,'\ql','');

text := stringreplaceall (text,'\ltrch','');

{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}

//text := stringreplaceall (text,'\fs16','');{8 punkter}

//text := stringreplaceall (text,'\fs20','');{10 punkter}

{Nu stadar vi istallet bort alla tvasiffriga fontsize.}

while pos ('\fs',text) > 0do

begin

//application.processmessages;

start := pos ('\fs',text);

Delete(text,start,5);

end;

while pos ('\f',text) > 0do

begin

//application.processmessages;

start := pos ('\f',text);

Delete(text,start,3);

end;

text := stringreplaceall (text,'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ',' < /P > < UL > ');

text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}',' < LI > ');

text := stringreplaceall (text, '\par < LI > ',' < LI > ');

text := stringreplaceall (text, '\par < UL > ',' < UL > ');

text := stringreplaceall (text,'\pard\plain ',' < P > ');

text := stringreplaceall (text,'\par \plain\b\ul ',' < /P > < MELLIS > ');

text := stringreplaceall (text,'\plain\b\ul ',' < /P > < MELLIS > ');

text := stringreplaceall (text,'\plain',' < /MELLIS > ');

text := stringreplaceall (text,'\par }',' < /P > ');

if (pos ('\par \tab ',text) > 0) or (pos (' < P > \tab ',text) > 0) then

begin

text := stringreplaceall (text,'\par \tab ',' < TR > < TD > ');

text := stringreplaceall (text,' < P > \tab ',' < TR > < TD > ');

text := stringreplaceall (text,'\tab ',' < /TD > < TD > ');

end

else

text := stringreplaceall (text,'\tab ','');

text := stringreplaceall (text,'\par ',' < /P > < P > ');

text := stringreplaceall (text,'#]#','}');

text := stringreplaceall (text,'#[#','{');

text := stringreplaceall (text,'\\','\');

if pos(' < TD > ',text) > 0then

text := text+' < /TD > < /TR > ';

if pos(' < LI > ',text) > 0then

text := text+' < /LI > ';

result := text;

end;

end.

Code:

regsvr32 vbscript.dll

Code:

{

Define the name of the pascal unit, wich will be the type library import unit, in

the edit box "Unit dir name".

Uncheck the checkbox "Generate Component Wrapper" (we are only interested in the

pascal source)

and press the button "Create Unit" to create the import unit.

Let's assume to have the latest available version in date

September the 23th i.e.

"Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"

The following "interface" are declared:

}

IRegExp = interface;

IMatch = interface;

IMatchCollection = interface;

IRegExp2 = interface;

IMatch2 = interface;

IMatchCollection2 = interface;

ISubMatches = interface;

{

IRegExp and IRegExp2 are different versions (IRegExp2 is the latest)

of the same "interface". Idem for the other "interface".

Then there are the declarations of CoClasses defined in Type Library.

We map each CoClass to its Default Interface:

}

RegExp = IRegExp2;

Match = IMatch2;

MatchCollection = IMatchCollection2;

SubMatches = ISubMatches;

//IRegExp2 is the "main" "interface":

// 1) properties:

a) property Pattern: WideString read Get_Pattern

writeSet_Pattern;

//regular expression

b) property IgnoreCase: WordBool read Get_IgnoreCase

writeSet_IgnoreCase;

//"case insensitive" search (TRUE o FALSE)

c) property Global: WordBool read Get_Global writeSet_Global;

//TRUE for global search on the input string of the method "Execute"

//FALSE if you want to stop after the first match

d) property Multiline: WordBool read Get_Multiline

writeSet_Multiline;

//If the input string contains '\n' charachters, it contains several

//rows. If Multiline = FALSE (default value) then the regular

//expression must be tested distinctly on each row.

//If Multiline = TRUE the regular expression must be tested on the

//whole input string.

// 2) methods:

a) function Execute(const sourceString: WideString): IDispatch;

safecall;

//it returns a Matches collection object containing a match object

//for each succesfull match

b) function Test(const sourceString: WideString): WordBool;

safecall;

//it returns TRUE if the regular expression can succesfully be

//matched against the string

c) function Replace(const sourceString: WideString;

const replaceString: WideString): WideString;

safecall;

//it replaces all the matches, inside "sourceString" with the

//replace string "replaceString".

//You can use the values $1, $2, $3, ... in order to define a

//replace-string made by substrings of the pattern.

{

IMatchCollection2 collects all the matches

For example:

}

var

i: integer;

MatchesCollection: IMatchCollection2;

{...}

MatchesCollection := Execute(InputStr) as IMatchCollection2;

for i := 1to MatchesCollection.Count - 1do

begin

Memo1.Lines.Add((MatchesCollection.Item[i] as IMatch2).Value);

end;

{...}

{Remember that you can substitute the "interface" types with

the CoClass types:

RegExp (IRegExp2)

Match (IMatch2)

MatchCollection (IMatchCollection2)

SubMatches (ISubMatches)

The main properties of IMatchCollection2 are:}

a) property Item[index: Integer]: IDispatch read Get_Item;

default;

//Matches array; index in [0..n]

b) property Count: Integer read Get_Count;

//Number of matches

{The Item property returns "IMatch2" values

IMatch2 represents each succesfull match

The main properties are}

a) property Value: WideString read Get_Value;

//matched value or text

b) property FirstIndex: Integer read Get_FirstIndex;

//the position within the original string where the match occurred.

//Note that the first position in a string is 0

c) property Length: Integer read Get_Length;

//length of the matched string

d) property SubMatches: IDispatch read Get_SubMatches;

//substrings ($1, $2, $3, ...)

{ISubMatches collects the values of $1, $2, $3, ...

The main properties are}

a) property Item[index: Integer]: OleVariant read Get_Item;

default;

//for example Item[3] is $3; note that index values start from 0

property Count: Integer read Get_Count;

//number of substrings

{

Short description of $1, $2, $3, ...

They are defined in the following manner:

let's scan the pattern from left to right:

$1 is the substring from the first open parenthesis to the corrisponding

closed one.

$1 is the substring from the second open parenthesis to the corrisponding

closed one.

$1 is the substring from the third open parenthesis to the corrisponding

closed one.

....

For example: let's consider the following pattern

(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)((/[ _a-z\d\-\\\.]+)+)*

$1 = FTP|HTTP

$2 = [_a-z\d\-]+(\.[_a-z\d\-]+)+

$3 = \.[_a-z\d\-]+

$4 = (/[ _a-z\d\-\\\.]+)+

$5 = /[ _a-z\d\-\\\.]+

Finally a couple of examples:

Save an html file from the internet and name it "Test.htm".

Create a new delphi project: drop 2 buttons (btSearch e btReplace)

and a Memo (Memo1); of course include in the "uses" directive the

name of the import unit.

}

//returns all links in "Test.htm" and $1, $2, $3, etc...

procedure TForm1.btSearchClick(Sender: TObject);

var

i, j: integer;

FileStream: TFileStream;

InputStr, InputFile: string;

RegExp1: RegExp;

MatchCollection1: MatchCollection;

Match1: Match;

SubMatches1: ISubMatches;

begin

//

InputFile := 'Test.htm'; //input file

FileStream := TFileStream.Create(InputFile, fmOpenRead);

SetLength(InputStr, FileStream.Size);

FileStream.Read(InputStr[1], FileStream.Size);

//load "Test.htm" in InputString

RegExp1 := CoRegExp.Create;

with RegExp1 do

begin

//I want to search all links

Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +

'((/[ _a-z\d\-\\\.]+)+)*';

IgnoreCase := True; //"case insensitive" search

Global := True; //I want to search all the matches

MatchCollection1 := Execute(InputStr) as MatchCollection;

end;

for i := 0to MatchCollection1.Count - 1do

begin

Match1 := MatchCollection1.Item[i] as Match;

Memo1.Lines.Add(Match1.Value);

SubMatches1 := Match1.SubMatches as SubMatches;

for j := 0to SubMatches1.Count - 1do

begin

Memo1.Lines.Add(' ' + '$' + inttostr(j + 1) +

' = ' + VarToStr(SubMatches1.Item[j]));

end;

end;

RegExp1 := nil;

FileStream.Free;

end;

//I replace all links in "Test.htm" with a new string and

//save the result string in the new file "Test_out.htm"

procedure TForm1.btReplaceClick(Sender: TObject);

var

i: integer;

InFileStream, OutFileStream: TFileStream;

InputStr, OutputStr, InputFile, OutputFile: string;

RegExp1: RegExp;

MatchCollection1: MatchCollection;

Match1: Match;

SubMatches1: ISubMatches;

begin

InputFile := 'Test.htm';

OutputFile := 'Test_out.htm';

InFileStream := TFileStream.Create(InputFile, fmOpenRead);

SetLength(InputStr, InFileStream.Size);

InFileStream.Read(InputStr[1], InFileStream.Size);

InFileStream.Free;

RegExp1 := CoRegExp.Create;

with RegExp1 do

begin

Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +

'((/[ _a-z\d\-\\\.]+)+)*';

IgnoreCase := True;

Global := True;

OutputStr := Replace(InputStr, '$2');

end;

OutFileStream := TFileStream.Create(OutputFile, fmCreate);

SetLength(OutputStr, Length(OutputStr));

OutFileStream.Write(OutputStr[1], Length(OutputStr));

OutFileStream.Free;

RegExp1 := nil;

ShowMessage('replace completed');

end;

 Code:

{ **** UBPFD *********** by delphibase.endimus  ****

>> Функция для "разворачивания" строк

Входные параметры:

Input - входная строка, которую необходимо представить в "развернутом виде"

на входе: 1,3,5-10,15

на выходе: 1,3,5,6,7,8,9,10,15

Зависимости: стандартный набор включаемых модулей

Автор: Ru, DiVo_Ru @ rambler.ru, Одесса

Copyright: DiVo 2002, creator Ru

***************************************************** }

function DecStr(Input: string): string;

var

i, j, t: integer;

s: string;

begin

if pos('-', Input) <> 0then

begin

while length(Input) <> 0do

begin

if Input[1] = ','then

begin

i := strtoint(s);

delete(Input, 1, 1);

result := result + s + ',';

s := '';

end

else

begin

if Input[1] = '-'then

begin

i := strtoint(s);

delete(Input, 1, 1);

t := pos(',', Input);

result := result + s + ',';

s := '';

if t = 0then

begin

j := strtoint(Input);

Input := '';

end

else

begin

j := strtoint(copy(Input, 1, t - 1));

delete(Input, 1, t);

end;

inc(i);

while i < j + 1do

begin

result := result + inttostr(i) + ',';

inc(i);

end;

end

else

begin

s := s + Input[1];

delete(Input, 1, 1);

end;

end;

end;

end

else

result := Input;

if s <> ''then

result := result + s;

end;

Code:

Procedure IsolateText( Const S: String; Tag1, Tag2: String; list:TStrings );

Var

pScan, pEnd, pTag1, pTag2: PChar;

foundText: String;

searchtext: String;

Begin

{ Set up pointers we need for the search. HTML is not case sensitive, so

we need to perform the search on a uppercased copy of S.}

searchtext := Uppercase(S);

Tag1:= Uppercase( Tag1 );

Tag2:= Uppercase( Tag2 );

pTag1:= PChar(Tag1);

pTag2:= PChar(Tag2);

pScan:= PChar(searchtext);

Repeat

{ Search for next occurence of Tag1. }

pScan:= StrPos( pScan, pTag1 );

If pScan <> NilThenBegin

{ Found one, hop over it, then search from that position

forward for the next occurence of Tag2. }

Inc(pScan, Length( Tag1 ));

pEnd := StrPos( pScan, pTag2 );

If pEnd <> NilThenBegin

{ Found start and end tag, isolate text between,

add it to the list. We need to get the text from

the original S, however, since we want the un-uppercased

version! So we calculate the address pScan would hold if

the search had been performed on S instead of searchtext. }

SetString( foundText,

Pchar(S) + (pScan- PChar(searchtext) ),

pEnd - pScan );

list.Add( foundText );

{ Continue next search after the found end tag. }

pScan := pEnd + Length(tag2);

End{ If }

Else{ Error, no end tag found for start tag, abort. }

pScan := Nil;

End; { If }

Until pScan = Nil;

End;

Code:

//Функция нечеткого сравнения строк БЕЗ УЧЕТА РЕГИСТРА

//------------------------------------------------------------------------------

//MaxMatching - максимальная длина подстроки (достаточно 3-4)

//strInputMatching - сравниваемая строка

//strInputStandart - строка-образец

// Сравнивание без учета регистра

// if IndistinctMatching(4, "поисковая строка", "оригинальная строка - эталон") > 40 then ...

type

TRetCount = packedrecord

lngSubRows: Word;

lngCountLike: Word;

end;

//------------------------------------------------------------------------------

function Matching(StrInputA: WideString;

StrInputB: WideString;

lngLen: Integer): TRetCount;

var

TempRet: TRetCount;

PosStrB: Integer;

PosStrA: Integer;

StrA: WideString;

StrB: WideString;

StrTempA: WideString;

StrTempB: WideString;

begin

StrA := string(StrInputA);

StrB := string(StrInputB);

for PosStrA := 1to Length(strA) - lngLen + 1do

begin

StrTempA := System.Copy(strA, PosStrA, lngLen);

PosStrB := 1;

for PosStrB := 1to Length(strB) - lngLen + 1do

begin

StrTempB := System.Copy(strB, PosStrB, lngLen);

if SysUtils.AnsiCompareText(StrTempA, StrTempB) = 0then

begin

Inc(TempRet.lngCountLike);

break;

end;

end;

Inc(TempRet.lngSubRows);

end; // PosStrA

Matching.lngCountLike := TempRet.lngCountLike;

Matching.lngSubRows := TempRet.lngSubRows;

end; { function }

//------------------------------------------------------------------------------

function IndistinctMatching(MaxMatching: Integer;

strInputMatching: WideString;

strInputStandart: WideString): Integer;

var

gret: TRetCount;

tret: TRetCount;

lngCurLen: Integer; //текущая длина подстроки

begin

//если не передан какой-либо параметр, то выход

if (MaxMatching = 0) or (Length(strInputMatching) = 0) or

(Length(strInputStandart) = 0) then

begin

IndistinctMatching := 0;

exit;

end;

gret.lngCountLike := 0;

gret.lngSubRows := 0;

// Цикл прохода по длине сравниваемой фразы

for lngCurLen := 1to MaxMatching do

begin

//Сравниваем строку A со строкой B

tret := Matching(strInputMatching, strInputStandart, lngCurLen);

gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;

gret.lngSubRows := gret.lngSubRows + tret.lngSubRows;

//Сравниваем строку B со строкой A

tret := Matching(strInputStandart, strInputMatching, lngCurLen);

gret.lngCountLike := gret.lngCountLike + tret.lngCountLike;

gret.lngSubRows := gret.lngSubRows + tret.lngSubRows;

end;

if gret.lngSubRows = 0then

begin

IndistinctMatching := 0;

exit;

end;

IndistinctMatching := Trunc((gret.lngCountLike / gret.lngSubRows) * 100);

end;

Code:

uses

Math;

function DoStringMatch(s1, s2: string): Double;

var

i, iMin, iMax, iSameCount: Integer;

begin

iMax := Max(Length(s1), Length(s2));

iMin := Min(Length(s1), Length(s2));

iSameCount := -1;

for i := 0to iMax do

begin

if i > iMin then

break;

if s1[i] = s2[i] then

Inc(iSameCount)

else

break;

end;

if iSameCount > 0then

Result := (iSameCount / iMax) * 100

else

Result := 0.00;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

match: Double;

begin

match := DoStringMatch('SwissDelphiCenter', 'SwissDelphiCenter.ch');

ShowMessage(FloatToStr(match) + ' % match.');

// Resultat: 85%

// Result : 85%

end;

Code:

{

Данная функция осуществляет сравнение двух строк. Первая строка

может быть любой, но она не должна содержать символов соответствия (* и ?).

Строка поиска (искомый образ) может содержать абсолютно любые символы.

Для примера: MatchStrings('David Stidolph','*St*') возвратит True.

Автор оригинального C-кода Sean Stanley

Автор портации на Delphi David Stidolph

}

function MatchStrings(source, pattern: string): Boolean;

var

pSource: array[0..255] of Char;

pPattern: array[0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;

var

t: Integer;

begin

Result := StrScan(pattern, '*') <> nil;

ifnot Result then

Result := StrScan(pattern, '?') <> nil;

end;

begin

if0 = StrComp(pattern, '*') then

Result := True

elseif (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

Result := False

elseif element^ = Chr(0) then

Result := True

else

begin

case pattern^ of

'*': if MatchPattern(element, @pattern[1]) then

Result := True

else

Result := MatchPattern(@element[1], pattern);

'?': Result := MatchPattern(@element[1], @pattern[1]);

else

if element^ = pattern^ then

Result := MatchPattern(@element[1], @pattern[1])

else

Result := False;

end;

end;

end;

begin

StrPCopy(pSource, source);

StrPCopy(pPattern, pattern);

Result := MatchPattern(pSource, pPattern);

end;