Code:

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

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

 

 

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

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

 

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

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

 

 

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

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

Copyright: DiVo 2002, creator Ru

 

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

 

function DecStr(Input: string): string;

var

i, j, t: integer;

s: string;

begin

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

begin

while length(Input) <> 0do

begin

if Input[1] = ','then

begin

i := strtoint(s);

delete(Input, 1, 1);

result := result + s + ',';

s := '';

end

else

begin

if Input[1] = '-'then

begin

i := strtoint(s);

delete(Input, 1, 1);

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

result := result + s + ',';

s := '';

if t = 0then

begin

j := strtoint(Input);

Input := '';

end

else

begin

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

delete(Input, 1, t);

end;

inc(i);

while i < j + 1do

begin

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

inc(i);

end;

end

else

begin

s := s + Input[1];

delete(Input, 1, 1);

end;

end;

end;

end

else

result := Input;

if s <> ''then

result := result + s;

end;

 

 

 

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

 

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

 

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

 

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

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

 

Code:

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

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

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

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

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

 

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

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

type

TRetCount = packedrecord

lngSubRows: Word;

lngCountLike: Word;

end;

 

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

 

function Matching(StrInputA: WideString;

StrInputB: WideString;

lngLen: Integer): TRetCount;

var

TempRet: TRetCount;

PosStrB: Integer;

PosStrA: Integer;

StrA: WideString;

StrB: WideString;

StrTempA: WideString;

StrTempB: WideString;

begin

StrA := string(StrInputA);

StrB := string(StrInputB);

 

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

begin

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

 

PosStrB := 1;

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

begin

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

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

begin

Inc(TempRet.lngCountLike);

break;

end;

end;

 

Inc(TempRet.lngSubRows);

end; // PosStrA

 

Matching.lngCountLike := TempRet.lngCountLike;

Matching.lngSubRows := TempRet.lngSubRows;

end; { function }

 

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

 

function IndistinctMatching(MaxMatching: Integer;

strInputMatching: WideString;

strInputStandart: WideString): Integer;

var

gret: TRetCount;

tret: TRetCount;

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

begin

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

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

(Length(strInputStandart) = 0) then

begin

IndistinctMatching := 0;

exit;

end;

 

gret.lngCountLike := 0;

gret.lngSubRows := 0;

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

for lngCurLen := 1to MaxMatching do

begin

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

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

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

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

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

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

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

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

end;

 

if gret.lngSubRows = 0then

begin

IndistinctMatching := 0;

exit;

end;

 

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

end;

 

 

https://delphiworld.narod

DelphiWorld 6.0

 

 


 

Code:

uses

Math;

 

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

var

i, iMin, iMax, iSameCount: Integer;

begin

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

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

iSameCount := -1;

for i := 0to iMax do

begin

if i > iMin then

break;

if s1[i] = s2[i] then

Inc(iSameCount)

else

break;

end;

if iSameCount > 0then

Result := (iSameCount / iMax) * 100

else

Result := 0.00;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

var

match: Double;

begin

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

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

// Resultat: 85%

// Result : 85%

end;

 

 

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

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

 

// 1. ...............................................

 

Code:

type

TStrArray = arrayofstring;

 

function Explode(var a: TStrArray; Border, S: string): Integer;

var

S2: string;

begin

Result := 0;

S2 := S + Border;

repeat

SetLength(A, Length(A) + 1);

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

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

Inc(Result);

until S2 = '';

end;

 

// How to use it:

 

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

S: string;

A: TStrArray;

AnzTokens, i: Integer;

begin

S := 'Ein=Text=durch=Geleichzeichen=getrennt';

AnzTokens := Explode(A, '=', S);

for i := 0to AnzTokens -1do

Memo1.Lines.Add(A[i]);

end;

 

 

// 2. ...............................................

 

Code:

{

* These 2 functions are from the programming language PHP, unite certainly well-known.

* Now one can use it also in Delphi:)

}

 

{...}

 

//* Needed type declaration

type

TExplodeArray = arrayofString;

 

{...}

 

function Implode(const cSeparator: String; const cArray: TExplodeArray): String;

var

i: Integer;

begin

Result := '';

for i := 0to Length(cArray) -1dobegin

Result := Result + cSeparator + cArray[i];

end;

System.Delete(Result, 1, Length(cSeparator));

end;

 

function Explode(const cSeparator, vString: String): TExplodeArray;

var

i: Integer;

S: String;

begin

S := vString;

SetLength(Result, 0);

i := 0;

while Pos(cSeparator, S) > 0dobegin

SetLength(Result, Length(Result) +1);

Result[i] := Copy(S, 1, Pos(cSeparator, S) -1);

Inc(i);

S := Copy(S, Pos(cSeparator, S) + Length(cSeparator), Length(S));

end;

SetLength(Result, Length(Result) +1);

Result[i] := Copy(S, 1, Length(S));

end;

 

 

 

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

Как в Run-time сгененрировать строку типа

 

'{821AB2C7-559D-48E0-A3EE-6DD50E83234C}'

 

Типа как в среде при нажатии Ctrl-Shift-G. Функция CoCreateGuid выводит значение типа TGUID, я нигде не нашёл функции конвертации TGUID -> String. Может кто знает такую функцию?

 

 

Автор:Vit

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

 

 Есть такая функция. Как ни странно называется она GUIDToString, и живет в SysUtils.

 

 

 

Автор:Fantasist

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

 

 


Можно GUIDToString написать и вручную, будет выглядеть примерно так:

 

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;

 

  Автор:Jin X