Code:

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

>> Быстрые функции сжатия пробелов и управляющих символов в строке.

Функции удаляют из строки начальные и конечные пробелы и управляющие

символы (меньшие пробела). Идущие подряд пробелы и управляющие символы

в середине строки заменяются одним пробелом.

Зависимости: нет

Автор: Александр Шарахов, alsha @ mailru.com, Москва

Copyright: Александр Шарахов

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

// Sha_SpaceCompress удаляет из Ansi-строки начальные и конечные пробелы

// и управляющие символы (меньшие пробела). Идущие подряд пробелы

// и управляющие символы в середине строки заменяются одним пробелом.

// Исходная строка при этом не изменяется. Эта функция работает

// медленнее, чем Sha_SpaceCompressInplace. С целью ускорения работы

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

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

// следующим образом: s2:=Sha_SpaceCompress(s1); SetLength(s2,Length(s2));

// Функция не работает, если нарушен формат Ansi-строки, в частности,

// если в конце строки отсутствует терминатор.

function Sha_SpaceCompress(const s: string): string;

var

p, q, t: pchar;

ch: char;

label

rt;

begin

;

p := pointer(s);

q := nil;

if p <> nilthen

begin

;

t := p + (pinteger(p - 4))^;

if p < t then

begin

;

repeat;

dec(t);

if p > t then

goto rt;

until (t^ > ' ');

SetString(Result, nil, (t - p) + 1);

q := pchar(pointer(Result));

repeat;

repeat;

ch := p^;

inc(p);

until ch > ' ';

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

inc(q);

until p > t;

end;

end;

rt:

if q <> nilthen

begin

;

dec(q);

q^ := #0;

(pinteger(pchar(pointer(Result)) - 4))^ := q - pointer(Result);

end

else

Result := '';

end;

// Sha_SpaceCompressInplace удаляет из Ansi-строки начальные и конечные пробелы

// и управляющие символы (меньшие пробела). Идущие подряд пробелы

// и управляющие символы в середине строки заменяются одним пробелом.

// Результат замещает исходную строку. С целью ускорения работы

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

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

// следующим образом: Sha_SpaceCompressInpace(s); SetLength(s,Length(s));

// Процедура не работает, если нарушен формат Ansi-строки, в частности,

// если в конце строки отсутствует терминатор.

procedure Sha_SpaceCompressInplace(var s: string);

var

p, q, t: pchar;

ch: char;

label

rt;

begin

;

UniqueString(s);

p := pointer(s);

if p <> nilthen

begin

;

t := p + (pinteger(p - 4))^;

if p < t then

begin

;

q := p;

repeat;

dec(t);

if p > t then

goto rt;

until (t^ > ' ');

repeat;

repeat;

ch := p^;

inc(p);

until ch > ' ';

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

inc(q);

until p > t;

dec(q);

rt: q^ := #0;

(pinteger(pchar(pointer(s)) - 4))^ := q - pointer(s);

end;

end;

end;

// Sha_SpaceCompressPChar удаляет из null-terminated строки начальные

// и конечные пробелы и управляющие символы (меньшие пробела), за исключением

// терминатора. Идущие подряд пробелы и управляющие символы в середине строки

// заменяются одним пробелом. Результат замещает исходную строку.

// Никакое перераспределения памяти не производится.

// Функция не работает с read-only строкой.

function Sha_SpaceCompressPChar(p: pchar): pchar;

var

q: pchar;

ch: char;

label

rt;

begin

;

Result := p;

if (p <> nil) and (p^ <> #0) then

begin

;

q := p - 1;

repeat;

repeat;

ch := p^;

inc(p);

if ch = #0then

goto rt;

until ch > ' ';

inc(q);

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

until ch = #0;

rt: if q < Result then

inc(q);

q^ := #0;

end;

end;

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

s2 := Sha_SpaceCompress(s1);

Sha_SpaceCompressInpace(s);

Sha_SpaceCompressPChar(pch);

Code:

{ **** UBPFD *********** by kladovka.net ****

>> Нестрогое сравнение строк

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

Автор: Dimich, dvmospan pisem.net, ICQ:236286143, Bryansk

Copyright: Владимир Кива

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

unit FindCompare;

interface

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

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

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

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

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

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

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

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

function IndistinctMatching(MaxMatching : Integer;

strInputMatching: WideString;

strInputStandart: WideString): Integer;

implementation

Uses SysUtils;

Type

TRetCount = packedrecord

lngSubRows : Word;

lngCountLike : Word;

end;

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

function Matching(StrInputA: WideString;

StrInputB: WideString;

lngLen: Integer) : TRetCount;

Var

TempRet : TRetCount;

PosStrB : Integer;

PosStrA : Integer;

StrA : WideString;

StrB : WideString;

StrTempA : WideString;

StrTempB : WideString;

begin

StrA := String(StrInputA);

StrB := String(StrInputB);

For PosStrA:= 1To Length(strA) - lngLen + 1do

begin

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

PosStrB:= 1;

For PosStrB:= 1To Length(strB) - lngLen + 1do

begin

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

If SysUtils.AnsiCompareText(StrTempA,StrTempB) = 0Then

begin

Inc(TempRet.lngCountLike);

break;

end;

end;

Inc(TempRet.lngSubRows);

end; // PosStrA

Matching.lngCountLike:= TempRet.lngCountLike;

Matching.lngSubRows := TempRet.lngSubRows;

end; { function }

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

function IndistinctMatching(MaxMatching : Integer;

strInputMatching: WideString;

strInputStandart: WideString): Integer;

Var

gret : TRetCount;

tret : TRetCount;

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

begin

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

If (MaxMatching = 0) Or (Length(strInputMatching) = 0) Or

(Length(strInputStandart) = 0) Then

begin

IndistinctMatching:= 0;

exit;

end;

gret.lngCountLike:= 0;

gret.lngSubRows := 0;

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

For lngCurLen:= 1To MaxMatching do

begin

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

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

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

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

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

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

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

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

end;

If gret.lngSubRows = 0Then

begin

IndistinctMatching:= 0;

exit;

end;

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

end;

end.

Code:

begin

Relevant := FindCompare.IndistinctMatching (3, edFind.Text, edOriginal.Text);

if Relevant > 40then ShowMessage('IMHO похожи!');

//....

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

G: TGUID;

S: string;

i: Integer;

begin

CoCreateGuid(G);

S := '{' + IntToHex(G.D1, 8) + '-' + IntToHex(G.D2, 4) + '-' + IntToHex(G.D3, 4) + '-';

for i := 0to7do

begin

S := S + IntToHex(G.D4[i], 2);

if i = 1then S := S + '-'

end;

S := S + '}';

ShowMessage(GUIDToString(G) + #13 + S)

end;

Code:

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

>> О пользе типа shortstring при использовании WinAPI

Довольно значительное количество функций WinAPI принимают как параметры

указатель на заполняемый ими массив символов и размер этого массива, а

возвращают количество помещенных ими символов. Если мы работаем в ANSI (не

Unicode), здесь удобно пользоваться короткими строками и "убивать двух зайцев"

за один раз.

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

Автор: Павел Озерский, pavel @ insect.mail.iephb.ru, Санкт-Петербург

Copyright: собственная разработка автора (Павел Озерский)

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

//пример:

function ClassName(hwnd: tHandle): shortstring;

begin

byte(Result[0]) := GetClassName(hwnd, pChar(@Result[1]), 255);

end;

Code:

var

s: string;

begin

s := RevField.text;

s[1] := chr(ord(s[1]) + 1);

RevField.text := s;

end;

Code:

function IncrementTrailingVersionLetter(Str: string): string;

begin

Str[Length(Str)] := Char(Ord(Str[Length(Str)]) + 1);

IncrementTrailingVersionLetter := Str;

end;

и использовать ее следующим образом:

with RevField do

Text := IncrementTrailingVersionLetter(Text);

Code:

{ **** UBPFD *********** by kladovka.net  ****

>> Получение параметра из строки по его индексу, а также получение общего числа параметров в строке

В юните представлены две функции, одна из которых, GetParamFromString, позволяет получить параметр из строки, по индексу этого параметра (индексация начинается с 1). Параметров в строке, я называю части строк, разделённые каким-нибудь оговорённым разделителем, например символом ";".

К пример строка "fex;9x-1;code" имеет три параметра:

fex

9x-1

code.

Описание аргументов функции GetParamFromString:

SourceStr - строка, содержащая в себе параметры;

Delimiter - разделитель параметров в строке;

Ind - индекс запрашиваемого параметра.

Функция GetParamsCount просто возвращает количество параметров в строке.

Описание аргументов функции GetParamsCount:

SourceStr - строка, содержащая в себе параметры;

Delimiter - разделитель параметров в строке;

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

Автор: VID, ICQ:132234868, Махачкала

Copyright: (c) не моё

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

unit getstrparam;

interface

uses Windows;

function GetParamsCount (const SourceStr, Delimiter:String): integer;

function GetParamFromString(const SourceStr,Delimiter:String; Ind:integer):string;

implementation

function GetDTextItem(DText,delimeter:pchar;var idx:integer):Pchar;

var nextpos:Pchar;i,len, p:integer;

begin

result:=DText;

len:=length(delimeter);

if (len=0) or (DText='') then exit;

i:=1;

while TRUE do

begin

p:=pos(delimeter,result);

if (p<>0) then

nextpos:=pointer(integer(result)+p-1)

else nextpos:=pointer(integer(result)+length(result));

if (i=idx) or (p=0) then break;

result:=pointer(integer(nextpos)+len);

inc(i);

end;

if i=idx then byte(nextpos^):=0else byte(result^):=0;

end;

function GetDTextCount(DText,delimeter:pchar):integer;

var subpos:Pchar;i,len:integer;

begin

result:=0;

len:=length(delimeter);

if (len=0) or (DText='') then exit;

subpos:=DText;

i:=pos(delimeter,subpos);

while i<>0do

begin

inc(result);

subpos:=pointer(integer(subpos)+i+len-1);

i:=pos(delimeter,subpos);

end;

if (byte(subpos^))<>0then inc(result);

end;

function GetParamsCount (const SourceStr, Delimiter:String): integer;

begin

Result:=GetDTextCount(PChar(SourceStr), PChar(Delimiter));

end;

function GetParamFromString(const SourceStr,Delimiter:String; Ind:integer):string;

var TmpS, TmpRes:PChar;

LRes:integer;

begin

GetMem (Tmps, Length(SourceStr)+1);

try

CopyMemory(Tmps, PChar(SourceStr), Length(SourceStr));

Byte(Pointer(Integer(Tmps)+Length(SourceStr))^):=0;

TmpRes:=GetDTextItem(TmpS, PChar(Delimiter), Ind);

LRes:=Length(TmpRes);

SetLength(Result,LRes);

CopyMemory(@Result[1], TmpRes, LRes);

finally

FreeMem(TmpS);

end;

end;

end.

Code:

showmessage(GetParamFromString('1;2a;3;4', ';',2));

showmessage(inttostr(GetParamsCount('1;2;3;4', ';')));

Code:

function Soundex(OriginalWord: string): string;

var

Tempstring1, Tempstring2: string;

Count: integer;

begin

Tempstring1 := '';

Tempstring2 := '';

OriginalWord := Uppercase(OriginalWord);

{Переводим исходное слово в верхний регистр}

Appendstr(Tempstring1, OriginalWord[1]); {Используем первую букву слова}

for Count := 2to length(OriginalWord) do

{Назначаем числовое значение каждой букве, за исключением первой}

case OriginalWord[Count] of

'B', 'F', 'P', 'V': Appendstr(Tempstring1, '1');

'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z': Appendstr(Tempstring1, '2');

'D', 'T': Appendstr(Tempstring1, '3');

'L': Appendstr(Tempstring1, '4');

'M', 'N': Appendstr(Tempstring1, '5');

'R': Appendstr(Tempstring1, '6');

{Все другие буквы, цифры и знаки пунктуации игнорируются}

end;

Appendstr(Tempstring2, OriginalWord[1]);

{Удаляем из результата все последовательно повторяющиеся цифры.}

for Count := 2to length(Tempstring1) do

if Tempstring1[Count - 1] <> Tempstring1[Count] then

Appendstr(Tempstring2, Tempstring1[Count]);

Soundex := Tempstring2; {Это - значение soundex}

end;

Code:

function SoundAlike(Word1, Word2: string): boolean;

begin

if (Word1 = '') and (Word2 = '') then

result := True

elseif (Word1 = '') or (Word2 = '') then

result := False

elseif (Soundex(Word1) = Soundex(Word2)) then

result := True

else

result := False;

end;

Code:

function GetAnsistringRefcount(const S: string): Cardinal;

asm

or eax, eax

jz @done

sub eax, 8

mov eax, dword ptr [eax]

@done:

end;

procedure TForm1.Button1Click(Sender: TObject);

var

S1, S2: string;

begin

memo1.lines.Add(Format('Refcount at start: %d',

[GetAnsistringRefcount(S1)]));

S1 := StringOfChar('A', 10);

memo1.lines.Add(Format('Refcount after assignment: %d',

[GetAnsistringRefcount(S1)]));

S2 := S1;

memo1.lines.Add(Format('Refcount after S2:=S1: %d',

[GetAnsistringRefcount(S1)]));

S2 := S1 + S2;

memo1.lines.Add(Format('Refcount after S2:=S1+S2: %d',

[GetAnsistringRefcount(S1)]));

end;

Code:

function GetAnsistringRefcount(const S: string): Cardinal;

asm

or eax, eax

jz @done

sub eax, 8

mov eax, dword ptr [eax]

@done:

end;

procedure TForm1.Button1Click(Sender: TObject);

var

S1, S2: string;

begin

memo1.lines.Add(Format('Refcount at start: %d',

[GetAnsistringRefcount(S1)]));

S1 := StringOfChar('A', 10);

memo1.lines.Add(Format('Refcount after assignment: %d',

[GetAnsistringRefcount(S1)]));

S2 := S1;

memo1.lines.Add(Format('Refcount after S2:=S1: %d',

[GetAnsistringRefcount(S1)]));

S2 := S1 + S2;

memo1.lines.Add(Format('Refcount after S2:=S1+S2: %d',

[GetAnsistringRefcount(S1)]));

end;

Code:

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

>> Проверка значения строки

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

Зависимости: нет

Автор: Separator, vilgelm @ mail.kz, Алматы

Copyright: Сергей Вильгельм

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

type

TTypeStr = (tsString, tsDate, tsNumber);

function CheckString(const Value: string): TTypeStr;

begin

if StrToDateTimeDef(Value, 0) = 0then

if StrToIntDef(Value, 0) = 0then

Result := tsString

else

Result := tsNumber

else

Result := tsDate

end;