Code:

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

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

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

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

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

Автор: Сергей, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., Краснодар

Copyright: VIP BANK

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

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;

Code:

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

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

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

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

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

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

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

Copyright: Собственная разработка

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

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;

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;

End;

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;

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;

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;

end.

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 &gt;

0then

begin

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

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

end

else

Result := Result + Source;

until I&lt;

= 0;

end;

Code:

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

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

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

Автор: Евгений Валяев (RhinoFC), Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., ICQ:55263922, Новосибирск

Copyright: RhinoFC

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

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;

Code:

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

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

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

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

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

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

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

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

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

Copyright: Автор: Федоровских Николай

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

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;

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

Code:

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

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

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

SubStr - образец

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

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

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

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

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

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

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

Copyright: Модернизированная функция из SysUtils

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

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, Москва

Copyright: Romkin

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

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;

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;

end;

end;

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;

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;

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]);

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;

end;

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;

...

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

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;

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;

end;

end.

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 "?".

}

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, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., Одесса (Украина)

Copyright: DiVo 2003 creator 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

Автор: Дмитрий, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., ICQ:155133146, Тольятти

Copyright: Дмитрий

Дата: 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;

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;

Code:

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

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

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

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

Copyright: panov

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

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;