Разбор строки, выделение элементов, поиск

Выделение подстроки по контексту

2013-08-21T14:54:59+07:00

Вот 2 функции которыми я очень часто пользуюсь - они выделяют из строки подстроку, которая находится до или после ключевого словаю Задача надо сказать частая, например есть строка:

"Total-2.00$"

Нижеприведенные функции позволяют выделить из строки логические элементы:

Code:

functionGetBefore(substr, str:string):string;

{©Drkb v.3(2007): www. drkb . ru,

®Vit (Vitaly Nevzorov) - nevzorov @ yahoo.com}

begin

if pos(substr,str)>0then

result:=copy(str,1,pos(substr,str)-1)

else

result:='';

end;

functionGetAfter(substr, str:string):string;

{©Drkb v.3(2007): www.drk b. ru,

®Vit (Vitaly Nevzorov) - nevzorov @ yahoo.com}

begin

if pos(substr,str)>0then

result:=copy(str,pos(substr,str)+length(substr),length(str))

else

result:='';

end;

Примеры:

1) Найти название параметра (оно находится до символа "-"):

GetBefore('-', 'Total-2.00$') // Результат будет "Total"

2) Найти сумму денег (оно находится после символа "-"):

GetAfter('-', 'Total-2.00$') // Результат будет "2.00$"

3) Найти сумму денег без знака доллара и остатка строки(оно находится после символа "-", но до символа "$"):

GetBefore('$',GetAfter('-', 'Total-2.00$ (общая сумма)') // Результат будет "2.00"

Автор:Vit

Деление строки не несколько строк

2013-08-21T14:49:57+07:00

Code:

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

>> Делит строку аStr на три строки St1,St2,St3 длиной Long1,Long2,Long3

Делит строку аStr на три строки St1,St2,St3 длиной Long1,Long2,Long3

соответственно или меньше в зависимости от длины исходной строки.

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

Автор: Сергей, nfkazak@inbox.ru, Краснодар

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

procedure DivPart(aStr: string; var St1, St2, St3: string; Long1, Long2, Long3:

byte);

var

i, pos, Long: byte;

begin

St1 := '';

St2 := '';

St3 := '';

aStr := Trim(aStr);

Long := Length(aStr);

if Long <= Long1 then

begin

St1 := aStr;

Exit

end;

Pos := Long1;

for i := 1to Long1 + 1do

if aStr[i] = ' 'then

Pos := i;

St1 := TrimRight(Copy(aStr, 1, Pos));

Delete(aStr, 1, Pos);

aStr := TrimLeft(aStr);

Long := Length(aStr);

if Long <= Long2 then

begin

St2 := aStr;

Exit

end;

Pos := Long2;

for i := 1to Long2 + 1do

if aStr[i] = ' 'then

Pos := i;

St2 := TrimRight(Copy(aStr, 1, Pos));

St3 := Trim(Copy(aStr, Pos + 1, Long3))

end;

©Drkb::00841

Code:

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

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

Параметры: Str: WideString - Строка для разбивки

Delimiter: String - Разделитель подстрок с строке Str

Результат: TStringList: Список найденных подстрок

Зависимости: System, Sysutils, Classes

Автор: Stoma, stoma @ bitex.bg

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

function Tokenize(Str: WideString; Delimiter: string): TStringList;

var

tmpStrList: TStringList;

tmpString, tmpVal: WideString;

DelimPos: LongInt;

begin

tmpStrList := TStringList.Create;

TmpString := Str;

DelimPos := 1;

while DelimPos > 0do

begin

DelimPos := LastDelimiter(Delimiter, TmpString);

tmpVal := Copy(TmpString, DelimPos + 1, Length(TmpString));

if tmpVal <> ''then

tmpStrList.Add(UpperCase(tmpVal));

Delete(TmpString, DelimPos, Length(TmpString));

end;

Tokenize := tmpStrList;

end;

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

function TForm1.GetDirNames(FullPath: string): TStringList;

begin

GetDirNames := Tokenize(FullPath, '\');

end;

Code:

procedure Explode(var a: arrayofstring; Border, S: string);

var

S2: string;

i: Integer;

begin

i := 0;

S2 := S + Border;

repeat

a[i] := Copy(S2, 0,Pos(Border, S2) - 1);

Delete(S2, 1,Length(a[i] + Border));

Inc(i);

until S2 = '';

end;

// How to use it:

// Und hier ein Beispiel zur Verwendung:

procedure TForm1.Button1Click(Sender: TObject);

var

S: string;

A: arrayofString;

begin

S := 'Ein Text durch Leerzeichen getrennt';

SetLength(A, 10);

Explode(A, ' ', S);

ShowMessage(A[0] + ' ' + A[1] + ' ' + A[2] + ' ' + A[3] + ' ' + A[4]);

end;

Замена подстрок

2013-08-21T14:51:50+07:00

Автор: Сергей Шамайтис

Code:

function ReplaceSub(str, sub1, sub2: string): string;

var

aPos: Integer;

rslt: string;

begin

aPos := Pos(sub1, str);

rslt := '';

while (aPos <> 0) do

begin

rslt := rslt + Copy(str, 1, aPos - 1) + sub2;

Delete(str, 1, aPos + Length(sub1) - 1);

aPos := Pos(sub1, str);

end;

Result := rslt + str;

end;

Code:

function ReplaceStr(const S, Srch, Replace: string): string;

{замена подстроки в строке}

var

I: Integer;

Source: string;

begin

Source := S;

Result := '';

repeat

I := Pos(Srch, Source);

if I >

0then

begin

Result := Result + Copy(Source, 1, I - 1) + Replace;

Source := Copy(Source, I + Length(Srch), MaxInt);

end

else

Result := Result + Source;

until I<

= 0;

end;

https://delphiworld.narod.

DelphiWorld 6.0

Code:

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

>> Замена в строке всех вхождений одной подстроки, на другую

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

Автор: Евгений Валяев (RhinoFC), rhinofc@sniiggims.ru, ICQ:55263922, Новосибирск

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

function StrReplace(const Str, Str1, Str2: string): string;

// str - исходная строка

// str1 - подстрока, подлежащая замене

// str2 - заменяющая строка

var

P, L: Integer;

begin

Result := str;

L := Length(Str1);

repeat

P := Pos(Str1, Result); // ищем подстроку

if P > 0then

begin

Delete(Result, P, L); // удаляем ее

Insert(Str2, Result, P); // вставляем новую

end;

until P = 0;

end;

А стандартная функция StringReplace чем не устраивает?

Автор:Vit

Как найти строку в строке начиная с определённой позиции?

2013-08-21T14:39:00+07:00

Code:

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

// Name: cnsSmartPos

// Author: Com-N-Sense

// Date:

// Purpose: Find a substring in a string starting from any position in the string.

// Params: SubStr - a substring for search.

// S - the source string to search within

// StartPos - the index position to start the search.

// Result: Integer - the position of the substring,

// zero - if the substring was not found

// Remarks: This is the original Delphi "Pos" function modified to support

// the start pos parameter.

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

function SmartPosAsm(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer;

type

StrRec = packedrecord

allocSiz: Longint;

refCnt: Longint;

length: Longint;

end;

const

skew = sizeof(StrRec);

asm

{ ->EAX Pointer to substr }

{ EDX Pointer to string }

{ <-EAX Position of substr in s or 0 }

TEST EAX,EAX

JE @@noWork

TEST EDX,EDX

JE @@stringEmpty

PUSH EBX

PUSH ESI

PUSH EDI

MOV ESI,EAX { Point ESI to substr }

MOV EDI,EDX { Point EDI to s }

MOV EAX,ECX

MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) }

ADD EDI,EAX

SUB ECX,EAX

PUSH EDI { remember s position to calculate index }

MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr)

DEC EDX { EDX = Length(substr) - 1 }

JS @@fail { < 0 ? return 0 }

MOV AL,[ESI] { AL = first char of substr }

INC ESI { Point ESI to 2'nd char of substr }

SUB ECX,EDX { #positions in s to look at }

{ = Length(s) - Length(substr) + 1 }

JLE @@fail

@@loop:

REPNE SCASB

JNE @@fail

MOV EBX,ECX { save outer loop counter }

PUSH ESI { save outer loop substr pointer }

PUSH EDI { save outer loop s pointer }

MOV ECX,EDX

REPE CMPSB

POP EDI { restore outer loop s pointer }

POP ESI { restore outer loop substr pointer }

JE @@found

MOV ECX,EBX { restore outer loop counter }

JMP @@loop

@@fail:

POP EDX { get rid of saved s pointer }

XOR EAX,EAX

JMP @@exit

@@stringEmpty:

XOR EAX,EAX

JMP @@noWork

@@found:

POP EDX { restore pointer to first char of s }

MOV EAX,EDI { EDI points of char after match }

SUB EAX,EDX { the difference is the correct index }

@@exit:

POP EDI

POP ESI

POP EBX

@@noWork:

end; //SmartPosAsm

function cnsSmartPos(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer;

begin

dec(StartPos);

Result := SmartPosAsm(SubStr,S,StartPos);

if Result > 0then Result := Result + StartPos;

end; //cnsSmartPos

Круто конечно, но есть стандартная функция:

function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;

Автор:Vit

Code:

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

>> Поиск подстроки в строке с заданной позиции

S - строка, в которой искать

SubStr - образец

fromPos - с какой позиции

Все на асемблере, принцип простой - ищется первый символ, затем часть строки

сравнивается с образцом начиная с этого символа

Если образец не найден, возвращает 0

Если найден - номер первого символа вхождения

Зависимости: Нету их!

Автор: Romkin, romkin @ pochtamt.ru, Москва

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

function TailPos(const S, SubStr: AnsiString; fromPos: integer): integer;

asm

PUSH EDI

PUSH ESI

PUSH EBX

PUSH EAX

OR EAX,EAX

JE @@2

OR EDX,EDX

JE @@2

DEC ECX

JS @@2

MOV EBX,[EAX-4]

SUB EBX,ECX

JLE @@2

SUB EBX,[EDX-4]

JL @@2

INC EBX

ADD EAX,ECX

MOV ECX,EBX

MOV EBX,[EDX-4]

DEC EBX

MOV EDI,EAX

@@1: MOV ESI,EDX

LODSB

REPNE SCASB

JNE @@2

MOV EAX,ECX

PUSH EDI

MOV ECX,EBX

REPE CMPSB

POP EDI

MOV ECX,EAX

JNE @@1

LEA EAX,[EDI-1]

POP EDX

SUB EAX,EDX

INC EAX

JMP @@3

@@2: POP EAX

XOR EAX,EAX

@@3: POP EBX

POP ESI

POP EDI

end;

Code:

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

>> Поиск подстроки в строке с заданной позиции (стандартный вариант)

Вроде работает

Substr - подстрока, S - строка, fromPos - с какой позиции искать

Если вхождение не найдено, возвращает 0

Ограничения - как для ansiStrPos

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

Автор: Romkin, romkin @ pochtamt.ru, Москва

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

function fAnsiPos(const Substr, S: string; FromPos: integer): Integer;

var

P: PChar;

begin

Result := 0;

P := AnsiStrPos(PChar(S) + fromPos - 1, PChar(SubStr));

if P <> nilthen

Result := Integer(P) - Integer(PChar(S)) + 1;

end;

Как разделить строку на элементы, Аналог VB функции Split

2013-08-20T20:43:52+07:00

Вариант 1.

В Дельфи есть специальный класс для хранения массивов строк - TStringList - очень рекомендую. Вот как вашу строку превратить в TStringList:

Объявление переменной

Code:

var t:TStringList;

begin

t:=TStringList.create; //создаём класс

t.text:=stringReplace('Ваша строка для разделения',' ',#13#10,[rfReplaceAll]);//мы заменяем все пробелы на символы конца строки

//теперь можно убедится что у вас строка разбина на элементы:

showmessage(t[0]);

showmessage(t[1]);

showmessage(t[2]);

showmessage(t[3]);

...

//после работы надо уничтожить класс

t.free;

Автор:Vit

Взято с Vingrad ruhttps://forum.vingrad

Вариант 2. Используем стандартные массивы:

Code:

var a:arrayofstring;//наш массив

s:string;//строка которую мы будем разбивать

begin

s:='Windows Messages SysUtils Variants Classes Graphics Controls Forms';

Repeat//мы постепенно заполняем массив на каждом шаге цикла по 1 элементу

setlength(a,length(a)+1);//увеличиваем размер массива на 1

if pos(' ',s)>0then//если есть пробел то надо взять слово до пробела

begin

a[length(a)-1]:=copy(s,1, pos(' ',s));//присвоение последнему элементу массива первого слова

s:=copy(s,pos(' ',s)+1, length(s));//удаляем из строки первое слово

end

else//в строке осталось только одно слово

begin

a[length(a)-1]:=s;// присвоим последнее слово

break;//выход из цикла

end;

Until False;//цикл бесконечный, выход изнутри

//теперь проверяем что получили

showmessage(a[0]);

showmessage(a[1]);

showmessage(a[2]);

После использования массива не забудте освободить память a:=nil или setlength(a,0)

Автор:Vit

Взято с Vingrad ruhttps://forum.vingrad

Code:

procedure SplitOnWords(const s:string; Delimiters:setof char; Strings:TStrings);

var

p,sp:PChar;

str:string;

begin

include(Delimiters,#0); //чтоб уж наверняк

p:=pointer(s);

while true do

begin

//пропускаем все разделители в начале

while p^ in Delimiters do

if p^=#0then

exit

else

inc(p);

sp:=p;

//пока не кончилось слово.

whilenot (p^ in Delimiters) do inc(p);

//запоминаем слово

SetLength(str,cardinal(p)-cardinal(sp));

Move(sp^,pointer(str)^,cardinal(p)-cardinal(sp));

Strings.Add(str);

end;

Автор:Fantasist

Взято с Vingrad ruhttps://forum.vingrad

См. также Парсинг строк

Количество вхождений подстроки в строку

2013-08-21T14:46:31+07:00

Code:

function CountPos(const subtext: string; Text: string): Integer;

begin

if (Length(subtext) = 0) or (Length(Text) = 0) or (Pos(subtext, Text) = 0) then

Result := 0

else

Result := (Length(Text) - Length(StringReplace(Text, subtext, '', [rfReplaceAll]))) div

Length(subtext);

end;

Code:

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

>> Подсчёт количества вхождений символа в строке

Функцийка считает количество повторений

символа заданного InputSubStr в строке InputStr.

Зависимости: Стандартные модули

Автор: Ru, DiVo_Ru@rambler.ru, Одесса (Украина)

Дата: 18 ноября 2003 г.

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

function CntChRepet(InputStr: string; InputSubStr: char): integer;

var

i: integer;

begin

result := 0;

for i := 1to length(InputStr) do

if InputStr[i] = InputSubStr then

inc(result);

end;

Code:

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

>> Подсчитать количество вхождений подстроки в строке

Понадобилось подсчитать количество вхождений подстроки в строку,

вот и появилась эта функция. Возможно в ней и нет изюминки,

но может кому и пригодится.

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

Автор: Дмитрий, bestonix@mail.ru, ICQ:155133146, Тольятти

Дата: 17 октября 2002 г.

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

function CntRecurrences(substr, str: string): integer;

var

cnt, p: integer;

begin

cnt := 0;

while str <> ''do

begin

p := Pos(substr, str);

if p > 0then

inc(cnt)

else

p := 1;

Delete(str, 1, (p + Length(substr) - 1));

end;

Result := cnt;

end;

Автор: ___Nikolay

Code:

// Кол-во вхождений символа в строку

function SymbolEntersCount(s: string; ch: char): integer;

var

i: integer;

begin

Result := 0;

if Trim(s) <> ''then

for i := 1to Length(s) do

if s[i] = ch then

inc(Result);

end;

Модуль поиска по маске (более совершеный нежели дельфийский masks)

2013-08-21T14:48:11+07:00

Code:

unit awMachMask; // © Alexandr Petrovich Sysoev

interface

uses Classes;

///////////////////////////////////////////////////// Работа со списком шаблонов

// Функции предназначены для сопоставления текстов (имен файлов) на

// соответствие заданному шаблону или списку шаблонов.

// Обычно используется для посторения простых фильтров, например аналогичных

// файловым фильтрам программы Total Commander.

// Каждый шаблон аналогичен шаблону имен файлов в MS-DOS и MS Windows,

// т.е. может включать "шаблонные" символы '*' и '?' и не может включать

// символ '|'.

// Любой шаблон может быть заключен в двойные кавычки ('''), при этом двойные

// кавычки имеющиеся в шаблоне должны быть удвоены. Если шаблон включает

// символы ';' или ' ' (пробел) то он обязательно должен быть заключен в

// двойные кавычки.

// В списке, шаблоны разделяются символом ';'.

// За первым списком шаблонов, может следовать символ '|', за которым может

// следовать второй список.

// Текст (имя файла) будет считаться соответствующим списку шаблонов только

// если он соответствует хотя бы одному шаблону из первого списка,

// и не соответствует ни одному шаблону из второго списка.

// Если первый список пуст, то подразумевается '*'

// Формальное описание синтаксиса списка шаблонов:

// Полный список шаблонов :: [<список включаемых шаблонов>]['|'<список исключаемых шаблонов>]

// список включаемых шаблонов :: <список шаблонов>

// список исключаемых шаблонов :: <список шаблонов>

// список шаблонов :: <шаблон>[';'<шаблон>]

// шаблон :: шаблон аналогичный шаблону имен файлов в

// MS-DOS и MS Windows, т.е. может включать

// "шаблонные" символы '*' и '?' и не может

// включать символ '|'. Шаблон может быть

// заключен в двойные кавычки (''') при этом

// двойные кавычки имеющиеся в шаблоне должны

// быть удвоены. Если шаблон включает символы

// ';' или ' ' (пробел) то он

// обязательно должен быть заключен в двойные

// кавычки.

// Например:

// '*.ini;*.wav' - соответствует любым файлам с расшиениями 'ini'

// или 'wav'

// '*.*|*.exe' - соответствует любым файлам, кроме файлов с

// расширением 'EXE'

// '*.mp3;*.wav|?.*;??.*' - соответствует любым файлам с расшиениями 'mp3'

// и 'wav' за исключением файлов у которых имя

// состоит из одного или двух символов.

// '|awString.*' - соответствует любым файлам за исключением файлов

// с именем awString и любым расширением.

Function IsMatchMask (aText, aMask :pChar ) :Boolean; overload;

Function IsMatchMask (aText, aMask :String; aFileNameMode :Boolean =True) :Boolean; overload;

// Выполняют сопоставление текста aText с одним шаблоном aMask.

// Возвращает True если сопоставление выполнено успешно, т.е. текст

// aText соответствует шаблону aMask.

// Если aFileNameModd=True, то объект используется для сопоставления

// имен файлов с шаблоном. А именно, в этом случае, если aText не

// содержит символа '.' то он добавляется в конец. Это необходимо для

// того, чтобы файлы без расширений соответствовали например шаблону '*.*'

Function IsMatchMaskList (aText, aMaskList :String; aFileNameMode :Boolean =True): Boolean;

// Выполняет сопоставление текста aText со списком шаблонов aMaskList.

// Возвращает True если сопоставление выполнено успешно, т.е. текст

// aText соответствует списку шаблонов aMaskList.

// Если aFileNameModd=True, то объект используется для сопоставления

// имен файлов с шаблоном. А именно, в этом случае, если aText не

// содержит символа '.' то он добавляется в конец. Это необходимо для

// того, чтобы файлы без расширений соответствовали например шаблону '*.*'

// Замечание, если требуется проверка сопоставления нескольких строк одному

// списку шаблонов, эффективнее будет воспользоваться объектом tMatchMaskList.

Type

tMatchMaskList = class(tObject)

Private

fMaskList :String;

fCaseSensitive :Boolean;

fFileNameMode :Boolean;

fPrepared :Boolean;

fIncludeMasks :tStringList;

fExcludeMasks :tStringList;

procedure SetMaskList (v :String );

procedure SetCaseSensitive (v :Boolean);

Public

constructor Create (Const aMaskList :String ='');

// Создает объект. Если задан параметр aMaskList, то он присваивается

// свойству MaskList.

destructor Destroy; override;

// Разрушает объект

procedure PrepareMasks;

// Осуществляет компиляцию списка шаблонов во внутреннюю структуру

// используемую при сопоставлении текста.

// Вызов данного метода не является обязательным и при необходимости

// будет вызван автоматически.

Function IsMatch (aText :String) :Boolean;

// Выполняет сопоставление текста aText со списком шаблонов MaskList.

// Возвращает True если сопоставление выполнено успешно, т.е. текст

// aText соответствует списку шаблонов MaskList.

Property MaskList :StringRead fMaskList Write SetMaskList ;

// Списко шаблонов используемый для сопоставления с текстом

Property CaseSensitive :Boolean Read fCaseSensitive Write SetCaseSensitive default False;

// Если False (по умолчанию), то при сопоставлении текста будет

// регистр символов не будет учитываться.

// Иначе, если True, сопоставление будет проводиться с учетом регистра.

Property FileNameMode :Boolean Read fFileNameMode Write fFileNameMode default True;

// Если True (по умолчанию), то объект используется для сопоставления

// имен файлов с шаблоном. А именно, в этом случае, если aText не

// содержит символа '.' то он добавляется в конец. Это необходимо для

// того, чтобы файлы без расширений соответствовали например шаблону '*.*'

End;

implementation

uses

SysUtils

;

Function IsMatchMask (aText, aMask :pChar ) :Boolean; overload;

begin

Result := False;

While True Dobegin

Case aMask^ of

'*' : // соответствует любому числу любых символов кроме конца строки

begin

// переместиться на очередной символ шаблона, при этом, подряд

// идущие '*' эквивалентны одному, поэтому пропуск всех '*'

repeat Inc(aMask); Until (aMask^<>'*');

// если за '*' следует любой символ кроме '?' то он должен совпасть

// с символом в тексте. т.е. нужно пропустить все не совпадающие,

// но не далее конца строки

If aMask^ <> '?'then

While (aText^ <> #0) And (aText^ <> aMask^) Do Inc(aText);

If aText^ <> #0Thenbegin// не конец строки, значит совпал символ

// '*' 'жадный' шаблон поэтому попробуем отдать совпавший символ

// ему. т.е. проверить совпадение продолжения строки с шаблоном,

// начиная с того-же '*'. если продолжение совпадает, то

If IsMatchMask (aText+1, aMask-1) Then Break; // это СОВПАДЕНИЕ

// продолжение не совпало, значит считаем что здесь закончилось

// соответствие '*'. Продолжим сопоставление со следующего

// символа шаблона

Inc(aMask); Inc(aText); // иначе переходим к следующему символу

End

ElseIf (aMask^ = #0) Then// конец строки и конец шаблона

Break // это СОВПАДЕНИЕ

Else// конец строки но не конец шаблона

Exit // это НЕ СОВПАДЕНИЕ

End;

'?' : // соответствует любому кроме конца строки

If (aText^ = #0) Then// конец строки

Exit // это НЕ СОВПАДЕНИЕ

Elsebegin// иначе

Inc(aMask); Inc(aText); // иначе переходим к следующему символу

End;

Else// символ в шаблоне должен совпасть с символом в строке

If aMask^ <> aText^ Then// символы не совпали -

Exit // это НЕ СОВПАДЕНИЕ

Elsebegin// совпал очередной символ

If (aMask^ = #0) Then// совпавший символ последний -

Break; // это СОВПАДЕНИЕ

Inc(aMask); Inc(aText); // иначе переходим к следующему символу

End;

Result := True;

End;

Function IsMatchMask (aText, aMask :String; aFileNameMode :Boolean =True) :Boolean; overload;

begin

If aFileNameMode And (Pos('.',aText)=0) then aText := aText+'.';

Result := IsMatchMask(pChar(aText),pChar(aMask));

End;

Function IsMatchMaskList (aText, aMaskList :String; aFileNameMode :Boolean =True) :Boolean;

begin

With tMatchMaskList.Create(aMaskList) Dotry

FileNameMode := aFileNameMode;

Result := IsMatch(aText);

finally

Free;

End;

/////////////////////////////////////////////////////////// tFileMask

procedure tMatchMaskList.SetMaskList (v :String );

begin

If fMaskList = v Then Exit;

fMaskList := v;

fPrepared := False;

End;

procedure tMatchMaskList.SetCaseSensitive (v :Boolean);

begin

If fCaseSensitive = v Then Exit;

fCaseSensitive := v;

fPrepared := False;

End;

constructor tMatchMaskList.Create (Const aMaskList :String);

begin

MaskList := aMaskList;

fFileNameMode := True;

fIncludeMasks := TStringList.Create; With fIncludeMasks Dobegin

Delimiter := ';';

// Sorted := True;

// Duplicates := dupIgnore;

End;

fExcludeMasks := tStringList.Create; With fExcludeMasks Dobegin

Delimiter := ';';

// Sorted := True;

// Duplicates := dupIgnore;

End;

destructor tMatchMaskList.Destroy;

begin

fIncludeMasks.Free;

fExcludeMasks.Free;

End;

procedure tMatchMaskList.PrepareMasks;

procedure CleanList(l :tStrings);

var i :Integer;

begin

For i := l.Count-1downto0DoIf l[i] = ''then l.Delete(i);

End;

var

s :String;

i :Integer;

begin

If fPrepared Then Exit;

If CaseSensitive Then

s := MaskList

Else

s := UpperCase(MaskList);

i := Pos('|',s);

If i = 0Thenbegin

fIncludeMasks.DelimitedText := s;

fExcludeMasks.DelimitedText := '';

End

Elsebegin

fIncludeMasks.DelimitedText := Copy(s,1,i-1);

fExcludeMasks.DelimitedText := Copy(s,i+1,MaxInt);

End;

CleanList(fIncludeMasks);

CleanList(fExcludeMasks);

// если список включаемых шаблонов пуст а

// список исключаемых шаблонов не пуст, то

// имеется ввиду что список включаемых шаблонов равен <все файлы>

If (fIncludeMasks.Count = 0) And (fExcludeMasks.Count <> 0) Then

fIncludeMasks.Add('*');

fPrepared := True;

End;

Function tMatchMaskList.IsMatch (aText :String) :Boolean;

var

i :Integer;

begin

Result := False;

If aText = ''then Exit;

IfNot CaseSensitive Then aText := UpperCase(aText);

If FileNameMode And (Pos('.',aText)=0) then aText := aText+'.';

IfNot fPrepared Then PrepareMasks;

// поиск в списке "включаемых" масок до первого совпадения

For i := 0To fIncludeMasks.Count-1Do

If IsMatchMask(PChar(aText),PChar(fIncludeMasks[i])) Thenbegin

Result := True;

Break;

End;

// если совпадение найдено, надо проверить по списку "исключаемых"

If Result Then

For i := 0To fExcludeMasks.Count-1Do

If IsMatchMask(PChar(aText),PChar(fExcludeMasks[i])) Thenbegin

Result := False;

Break;

End;

end.

Автор:Петрович

Взято из https://forum.sources

Нахождение последнего вхождения подстроки в строку

2013-08-21T14:53:26+07:00

Code:

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

>> Нахождение последнего вхождения подстроки в строку

Функция возвращает начало последнего вхождения

подстроки FindS в строку SrcS, т.е. первое с конца.

Если возвращает ноль, то подстрока не найдена.

Можно использовать в текстовых редакторах

при поиске текста вверх от курсора ввода.

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

Автор: Fenik, chook_nu @ uraltc.ru, Новоуральск

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

function PosR2L(const FindS, SrcS: string): Integer;

{Функция возвращает начало последнего вхождения

подстроки FindS в строку SrcS, т.е. первое с конца.

Если возвращает ноль, то подстрока не найдена.

Можно использовать в текстовых редакторах

при поиске текста вверх от курсора ввода.}

function InvertS(const S: string): string;

{Инверсия строки S}

var

i, Len: Integer;

begin

Len := Length(S);

SetLength(Result, Len);

for i := 1to Len do

Result[i] := S[Len - i + 1];

end;

var

ps: Integer;

begin

{Например: нужно найти последнее вхождение

строки 'ро' в строке 'пирожок в коробке'.

Инвертируем обе строки и получаем

'ор' и 'екборок в кожорип',

а затем ищем первое вхождение с помощью стандартной

функции Pos(Substr, S: string): string;

Если подстрока Substr есть в строке S, то

эта функция возвращает позицию первого вхождения,

а иначе возвращает ноль.}

ps := Pos(InvertS(FindS), InvertS(SrcS));

{Если подстрока найдена определяем её истинное положение

в строке, иначе возвращаем ноль}

if ps <> 0then

Result := Length(SrcS) - Length(FindS) - ps + 2

else

Result := 0;

end;

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

p := PosR2L('са', 'Мой сапог догнал самолёт.'); // p:=18;

Code:

{

Letzte Position von SubStr in S ermitteln.

Returns the last occurence of SubStr in S.

}

function LastPos(SubStr, S: string): Integer;

var

Found, Len, Pos: integer;

begin

Pos := Length(S);

Len := Length(SubStr);

Found := 0;

while (Pos > 0) and (Found = 0) do

begin

if Copy(S, Pos, Len) = SubStr then

Found := Pos;

Dec(Pos);

end;

LastPos := Found;

end;

Code:

// by Manuel Wiersch

function LastPos(const SubStr: AnsiString; const S: AnsiString): LongInt;

asm

TEST EAX,EAX // EAX auf 0 prufen (d.h. SubStr = nil)

JE @@noWork // wenn EAX = 0 dann Sprung zu noWork

TEST EDX,EDX

// Test ob S = nil

JE @@stringEmpty // bei Erfolg -> Sprung zum Label 'stringEmpty'

PUSH EBX

PUSH ESI

PUSH EDI // Register auf dem Stack sichern Grund: OH

// OH: "In einer asm-Anweisung mu? der Inhalt

// der Register EDI, ESI, ESP, EBP und EBX

// erhalten bleiben (dh. vorher auf dem Stack

// speichern) MOV ESI, EAX

// ESI = Sourceindex -> Adresse vom SubStr

MOV EDI, EDX // EDI = Destinationindex -> Adresse von S

MOV ECX,[EDI-4] // Lange von S ins Zahlregister

MOV EDX,[ESI-4] // Lange des SubStr in EDX

DEC EDX // Length(SubStr) - 1

JS @@fail

// Vorzeichenbedingter Sprung (JumpIfSign)

// d.h. (EDX < 0) -> Sprung zu 'fail'

STD; // SetDirectionFlag -> Stringroutinen von hinten

// abarbeiten

ADD ESI, EDX // Pointer auf das letzte Zeichen vom SubStr

ADD EDI, ECX

DEC EDI // Pointer auf das letzte Zeichen von S

MOV AL, [ESI] // letztes Zeichen des SubStr in AL laden

DEC ESI // Pointer auf das vorletzte Zeichen setzen.

SUB ECX, EDX // Anzahl der Stringdurchlaufe

// = Length(s) - Length(substr) + 1

JLE @@fail // Sprung zu 'fail' wenn ECX <= 0

@@loop:

REPNE SCASB // Wdh. solange ungleich (repeat while not equal)

// scan string for byte

JNE @@fail

MOV EBX,ECX { Zahleregister, ESI und EDI sichern, da nun der

Vergleich durchgefuhrt wird ob die nachfolgenden

Zeichen von SubStr in S vorhanden sind }

PUSH ESI

PUSH EDI

MOV ECX,EDX // Lange des SubStrings in ECX

REPE CMPSB // Solange (ECX > 0) und (Compare string fo byte)

// dh. solange S[i] = SubStr[i]

POP EDI

POP ESI // alten Source- und Destinationpointer vom Stack holen

JE @@found // Und schon haben wir den Index da ECX = 0

// dh. alle Zeichen wurden gefunden

MOV ECX, EBX // ECX wieder auf alte Anzahl setzen und

JMP @@loop // Start bei 'loop'

@@fail:

XOR EAX,EAX // EAX auf 0 setzen

JMP @@exit @@stringEmpty:

XOR EAX,EAX

JMP @@noWork @@found:

MOV EAX, EBX // in EBX steht nun der aktuelle Index

INC EAX // um 1 erhohen, um die Position des 1. Zeichens zu

// bekommen

@@exit:

POP EDI

POP ESI

POP EBX

@@noWork: CLD; // DirectionFlag loschen

end;

Несколько расширенных функций по определению позиции

2013-08-21T15:01:06+07:00

Code:

// Get the Position of a string, starting at the end

// Ruckwartiges Vorkommen einer Zeichenkette innerhalb eines strings, Position von hinten

function LastPos(SearchStr, Str: string): Integer;

var

i: Integer;

TempStr: string;

begin

Result := Pos(SearchStr, Str);

if Result = 0then Exit;

if (Length(Str) > 0) and (Length(SearchStr) > 0) then

begin

for i := Length(Str) + Length(SearchStr) - 1downto Result do

begin

TempStr := Copy(Str, i, Length(Str));

if Pos(SearchStr, TempStr) > 0then

begin

Result := i;

break;

end;

// Search for the next occurence of a string from a certain Position

// Nachstes Vorkommen einer Zeichenkette ab einer frei definierbaren Stelle im string

function NextPos(SearchStr, Str: string; Position: Integer): Integer;

begin

Delete(Str, 1, Position - 1);

Result := Pos(SearchStr, upperCase(Str));

if Result = 0then Exit;

if (Length(Str) > 0) and (Length(SearchStr) > 0) then

Result := Result + Position + 1;

end;

// Get the number of characters from a certain Position to the string to be searched

// Anzahl der Zeichen von einer definierbaren Position zur gesuchten Zeichenkette

function NextPosRel(SearchStr, Str: string; Position: Integer): Integer;

begin

Delete(Str, 1, Position - 1);

Result := Pos(SearchStr, UpperCase(Str)) - 1;

end;

// simple replacement for strings

// einfaches Ersetzen von Zeichenketten

function ReplaceStr(Str, SearchStr, ReplaceStr: string): string;

begin

while Pos(SearchStr, Str) <> 0do

begin

Insert(ReplaceStr, Str, Pos(SearchStr, Str));

Delete(Str, Pos(SearchStr, Str), Length(SearchStr));

end;

Result := Str;

end;

Парсинг строк

2013-08-21T14:36:29+07:00

Code:

unit splitfns;

interface

uses Classes, Sysutils;

function GetNextToken(Const S: string; Separator: TSysCharSet; var StartPos: integer): String;

{Returns the next token (substring) from string S, starting at index StartPos and ending 1 character

before the next occurrence of Separator (or at the end of S, whichever comes first).}

{StartPos returns the starting position for the next token, 1 more than the position in S of

the end of this token}

procedure Split(const S: String; Separator: TSysCharSet; MyStringList: TStringList);

{Splits a string containing designated separators into tokens and adds them to MyStringList NOTE: MyStringList must be Created before being passed to this procedure and Freed after use}

function AddToken (const aToken, S: String; Separator: Char; StringLimit: integer): String;

{Used to join 2 strings with a separator character between them and can be used in a Join function}

{The StringLimit parameter prevents the length of the Result String from exceeding a preset maximum}

implementation

function GetNextToken(Const S: string; Separator: TSysCharSet; var StartPos: integer): String;

varIndex: integer;

begin

Result := '';

{Step over repeated separators}

While (S[StartPos] in Separator) and (StartPos <= length(S)) do StartPos := StartPos + 1;

if StartPos > length(S) then Exit;

{Set Index to StartPos}

Index := StartPos;

{Find the next Separator}

Whilenot (S[Index] in Separator) and (Index <= length(S))doIndex := Index + 1;

{Copy the token to the Result}

Result := Copy(S, StartPos, Index - StartPos);

{SetStartPos to next Character after the Separator}

StartPos := Index + 1;

end;

procedure Split(const S: String; Separator: TSysCharSet; MyStringList: TStringList);

var Start: integer;

begin

Start := 1;

While Start <= Length(S) do MyStringList.Add(GetNextToken(S, Separator, Start));

end;

function AddToken (const aToken, S: String; Separator: Char; StringLimit: integer): String;

begin

if Length(aToken) + Length(S) < StringLimit then

begin

{Add a separator unless the Result string is empty}

if S = ''then Result := ''else Result := S + Separator;

{Add the token}

Result := Result + aToken;

end

else

{if the StringLimit would be

exceeded, raise an exception}

Raise Exception.Create('Cannot add token');

end;

end.

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

Code:

...

data:= TStringList.Create;

splited:=TStringList.Create;

data.LoadFromFile(s);

Split(data.Text,[',',' ',#10,#13,';','\"','.','!','-','+','*','/','\',

'(',')','[',']','{','}','<','>','''','"','?','"','#',#0],splited);

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

begin

ifnot words.Find(splited.Strings,adr) then

words.Add(splited.Strings[i]);

application.processmessages;[i]//make program to respond to user

//commands while processing in case of very long string.

end;

...

Автор:Song

Взято из https://forum.sources

Некоторое время назад одна любезная душа прислала мне этот модуль. Я нашел его весьма полезным, но применять его вам надлежит с некоторой долей осторожности, ибо тэг %s иногда приводит к исключительным ситуациям.

Code:

unit Scanf;

interface

uses SysUtils;

type

EFormatError = class(ExCeption);

function Sscanf(const s: string; const fmt: string;

const Pointers: arrayof Pointer): Integer;

implementation

{ Sscanf выполняет синтаксический разбор входной строки. Параметры...

s - входная строка для разбора

fmt - 'C' scanf-форматоподобная строка для управления разбором

%d - преобразование в Long Integer

%f - преобразование в Extended Float

%s - преобразование в строку (ограничено пробелами)

другой символ - приращение позиции s на "другой символ"

пробел - ничего не делает

Pointers - массив указателей на присваиваемые переменные

результат - количество действительно присвоенных переменных

Например, ...

Sscanf('Name. Bill Time. 7:32.77 Age. 8',

'. %s . %d:%f . %d', [@Name, @hrs, @min, @age]);

возвратит ...

Name = Bill hrs = 7 min = 32.77 age = 8 }

function Sscanf(const s: string; const fmt: string;

const Pointers: arrayof Pointer): Integer;

var

i, j, n, m: integer;

s1: string;

L: LongInt;

X: Extended;

function GetInt: Integer;

begin

s1 := '';

while (s[n] = ' ') and (Length(s) > n) do

inc(n);

while (s[n] in ['0'..'9', '+', '-'])

and (Length(s) >= n) do

begin

s1 := s1 + s[n];

inc(n);

end;

Result := Length(s1);

end;

function GetFloat: Integer;

begin

s1 := '';

while (s[n] = ' ') and (Length(s) > n) do

inc(n);

while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E'])

and (Length(s) >= n) do

begin

s1 := s1 + s[n];

inc(n);

end;

Result := Length(s1);

end;

function GetString: Integer;

begin

s1 := '';

while (s[n] = ' ') and (Length(s) > n) do

inc(n);

while (s[n] <> ' ') and (Length(s) >= n) do

begin

s1 := s1 + s[n];

inc(n);

end;

Result := Length(s1);

end;

function ScanStr(c: Char): Boolean;

begin

while (s[n] <> c) and (Length(s) > n) do

inc(n);

if (n <= Length(s)) then

Result := True

else

Result := False;

end;

function GetFmt: Integer;

begin

Result := -1;

while (TRUE) do

begin

while (fmt[m] = ' ') and (Length(fmt) > m) do

inc(m);

if (m >= Length(fmt)) then

break;

if (fmt[m] = '%') then

begin

inc(m);

case fmt[m] of

'd': Result := vtInteger;

'f': Result := vtExtended;

's': Result := vtString;

end;

inc(m);

break;

end;

if (ScanStr(fmt[m]) = False) then

break;

inc(m);

end;

begin

n := 1;

m := 1;

Result := 0;

for i := 0to High(Pointers) do

begin

j := GetFmt;

case j of

vtInteger:

begin

if GetInt > 0then

begin

L := StrToInt(s1);

Move(L, Pointers[i]^, SizeOf(LongInt));

inc(Result);

end

else

break;

end;

vtExtended:

begin

if GetFloat > 0then

begin

X := StrToFloat(s1);

Move(X, Pointers[i]^, SizeOf(Extended));

inc(Result);

end

else

break;

end;

vtString:

begin

if GetString > 0then

begin

Move(s1, Pointers[i]^, Length(s1) + 1);

inc(Result);

end

else

break;

end;

else

break;

end;

end.

https://delphiworld.narod.

DelphiWorld 6.0

Code:

// Parse a string, for example:

// How do I get the "B" from "A|B|C|D|E|F"?

function Parse(Char, S: string; Count: Integer): string;

var

I: Integer;

T: string;

begin

if S[Length(S)] <> Char then

S := S + Char;

for I := 1to Count do

begin

T := Copy(S, 0, Pos(Char, S) - 1);

S := Copy(S, Pos(Char, S) + 1, Length(S));

end;

Result := T;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(Parse('|', 'A|B|C|D|E|F', 2));

end;

{

Parameters:

Parse([Character, for example "|"], [The string],

[The number, the "B" is the 2nd part of the string]);

This function is handy to use when sending data over the internet,

for example a chat program: Name|Text. Note: Be sure there's no "Char" in the string!

Use a unused character like "|" or "?".

}

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

Поиск N-ого вхождения подстроки в строку

2013-08-21T15:02:32+07:00

Code:

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

>> Поиск N-ого вхождения подстроки в строку

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

Автор: panov, panov @ hotbox.ru, Екатеринбург

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

function SearchString(const FindStr, SourceString: string; Num: Integer):

Integer;

var

FirstSym: PChar; //Ссылка на первый символ

function MyPos(const FindStr, SourceString: PChar; Num: Integer): PChar;

begin

Result := AnsiStrPos(SourceString, FindStr);

//Поиск вхождения подстроки в строку

if (Result = nil) then

Exit; //Подстрока не найдена

Inc(Result); //Смещаем указатель на следующий символ

if Num = 1then

Exit; //Если нужно первое вхождение - заканчиваем

if num > 1then

Result := MyPos(FindStr, Result, num - 1);

//Рекурсивный поиск следующего вхождения

end;

begin

FirstSym := PChar(SourceString);

//Присваиваем адрес первого символа исходной строки

Result := MyPos(PChar(FindStr), PChar(SourceString), Num) - FirstSym;

//Номер позиции в строке

if Result < 0then

Result := 0; //Возвращаем номер позиции

end;

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

var

StrF, StrSrc: string;

n: Integer;

begin

...

StrF := 'стр';

StrSrc := 'Поиск подстроки в строке';

n := SearchString(StrF, StrSrc, 2); //n будет равна 19

end;

Произвести поиск байта или слова в строке

2013-08-21T15:16:53+07:00

У семейства 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.

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

2013-08-21T15:03:46+07:00

Code:

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

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

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

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

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

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;

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;

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

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

Регулярные выражения

2013-08-21T14:43:15+07:00

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;

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

Текст между двумя определёнными строками

2013-08-21T15:17:49+07:00

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;

Фильтрованный поиск в строке

2013-08-21T15:14:36+07:00

Автор: 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;

begin

StrPCopy(pSource, source);

StrPCopy(pPattern, pattern);

Result := MatchPattern(pSource, pPattern);

end;

Функции для парсинга строк

2013-08-21T15:07:17+07:00

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

Вам потребуется один из методов, называющийся 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;

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;

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

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

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

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

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

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

begin

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

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

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

end

else

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

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

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.

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

2013-08-21T15:09:45+07:00

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, Одесса

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

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

else

result := Input;

if s <> ''then

result := result + s;

end;

Функция приблизительного (нечеткого) сравнения строк

2013-08-21T15:11:21+07:00

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

Недавно в поисках информации по интеллектуальным алгоритмам сравнения я нашел такой алгоритм — алгоритм сравнения (совпадения) двух строк, Так как он был написан на 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;

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