У семейства x86 есть группа специализированных строковых инструкций, одна из которых - scasb/scasw - производит поиск байта/слова в строке. Использовать преимущества этой инструкции в Delphi позволяют длинные строки, которых в старых паскалях не было.

 

Никаких сложностей с пониманием, на мой взгляд, быть не должно. Единственное это смена режима открытия файла (FileMode := 0), которая позволит открыть файлы заблокированные ядром Windows и сдвиг указателя файла при чтении нового блока влево на длину искомой строки. Сдвиг делается на случай разрезания искомой строки на части при чтении файла. Полный текст проверенной программы:

 

 

Code:

program search;

{$APPTYPE CONSOLE}

uses SysUtils;

const buffSize = 16384;

var F : File;

var buff : AnsiString;

var oldFileMode : integer;

var SearchString: shortString='SunSB';

var SearchPos : integer = -1;

var readed : integer;

var blockStart: integer;

begin

SetLength( buff, buffSize);

assignFile( F, 'Speedometer2.exe');

oldFileMode := FileMode;

FileMode := 0;

reset( F,1);

whilenot eof( F ) dobegin

blockStart := filePos( F );

blockRead( F, buff[1], buffSize, readed);

SearchPos:=Pos( SearchString, buff );

if SearchPos > 0thenbegin

WriteLn( 'Substr found at pos ',

blockStart+SearchPos );

break;

end;

if readed=buffSize then

seek( F, ( filePos( F ) -

length( SearchString )));

end;

closeFile( F );

FileMode := oldFileMode;

SetLength( buff, 0 );

if SearchPos = 0then

WriteLn( 'Substr not found.');

readLn;

end.

 

 

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

 

Здесь представлен модуль, в котором я разметил много методов для подобной работы. Некоторые функции поименованы по-шведски, но, может быть, Вы сможете понять, что они делают.

 Вам потребуется один из методов, называющийся stringreplaceall, который принимает при параметра - исходную строку, подстроку для поиска и подстроку для замены, и возвращает измененную строку. Будьте осторожны, если Вы меняется одну подстроку на другую, чьей частью является первая. Вы должны делать это в два прохода, или Вы попадете в бесконечный цикл.

 Так, если Вы имеете текст, содержащий слово Joe, и Вы хотите все его вхождения изменить на Joey, то Вы должны сделать сперва нечто похожее на:

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

И потом:

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

 

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.

 

 

 

It is possible to use regular expressions in Delphi thanks to their implementation inside "Microsoft(r) Windows(r) Script".First of all I want to say that this article isn't a theoretical analisys of the regular expressions but an explanation of how to use them in Delphi. First of all I suggest you to download the latest version of "Microsoft(r) Windows(r) Script" at the following url:

 

https://msdn.microsoft.com/downloads/default.asp?URL=/downloads/sample.asp?url=/msdn-files/027/001/733/msdncompositedoc . xml

 

Download the desired package. Once downloaded, run it to install.

 

It will be installed Microsoft(r) Windows(r) Script wich containes:

 

Visual Basic(r) Script Edition (VBScript.) Version 5.6,

JScript(r) Version 5.6, Windows Script Components,

Windows Script Host 5.6,

Windows Script Runtime Version 5.6.

 

We are interested in the implementation of regular expressions, which is in the file "vbscript.dll". Every time you will want to run a program, wich exploits regular expressions by using "Microsoft(r) Windows(r) Script", on a given computer, it will be needed to copy the file "vbscript.dll" on the target computer and register it with the following command line:

 

Code:

regsvr32 vbscript.dll

 

Note that the auto-installing package, you have downloaded from the internet, automatically do it.

 

Now let's go to import the type library in Delphi:

 

In the delphi menu, select "Project" then "Import type library": it shows a mask containing a list. Inside the list select "Microsoft VBScript Regular Expressions" (followed by a version number). It is possible that there are more then one item with this name (it only changes the version number): in this situation select the item with the higher version number. In date September the 23th 2002, the package that can be downloaded from Microsoft's internet site returns the following value:

 

"Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"

 

This version supplies the following "Class Names"

}

 

TRegExp

TMatch

TMatchCollection

TSubMatches

 

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;

 

 

 

Взято с сайтаhttps://www.swissdelphicenter.ch/en/tipsindex

 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;

 

 

Автор: Дмитрий Кузан

 

Недавно в поисках информации по интеллектуальным алгоритмам сравнения я нашел такой алгоритм — алгоритм сравнения (совпадения) двух строк, Так как он был написан на VBA, я под свои нужды переписал его на Delphi

 

Уважаемые пользователи проекта DelphiWorld, я думаю данная функция пригодится тем, кто часто пишет функции поиска, особенно когда поиск приблизителен. То есть, например, в БД забито "Иванав Иван" - с ошибкой при наборе, а ищется "Иванов". Так вот, данный алгоритм может вам найти "Иванав" при вводе "Иванов",а также при "Иван Иванов" - даже наоборот с определенной степенью релевантности при сравнении. А используя сравнение в процентном отношении, вы можете производить поиск по неточным данным с более-менее степенью похожести.

 

Еще раз повторяю, алгоритм не мой, я только его портировал на Delphi.

А метод был предложен Владимиром Кива, за что ему огромное спасибо.

 

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;

 

 

https://delphiworld.narod

DelphiWorld 6.0

 

 


 

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;

 

 

Взято с сайта: https://www.swissdelphicenter

Автор: David Stidolph

 

Есть множество задач, где необходимо использование так называемой "дикой карты", то есть поиск в строке по фильтру, когда в качестве поиска используется подстрока с символом "*" (звездочка). Например, если необходимо выяснить наличие подстроки 'St' с какими-либо символами перед ней, то в качестве параметра для поиска задается подстрока вида '*St'. Звездочка может присутствовать как в начале/конце подстроки, так и по обеим ее сторонам. Также при составлении фильтра вместо любого одиночного символа возможна подстановка знака вопроса.

 

Пока функция может только сообщать о наличии необходимых вложений, но было бы интересно получить ваши примеры, которые могли бы и возвращать искомую подстроку.

 

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;