Разные вопросы

Explode / Implode a String?

2013-08-22T14:40:57+07:00

// 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

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

2013-08-22T17:10:04+07:00

Code:

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

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

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

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

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

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

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

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

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

ch := p^;

inc(p);

until ch > ' ';

repeat;

q^ := ch;

ch := p^;

inc(q);

inc(p);

until ch <= ' ';

q^ := ' ';

inc(q);

until p > t;

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;

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;

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

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;

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

s2 := Sha_SpaceCompress(s1);

Sha_SpaceCompressInpace(s);

Sha_SpaceCompressPChar(pch);

Генерация GUID как строки

2013-08-22T14:39:37+07:00

Как в 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

Инкрементация строкового поля

2013-08-22T14:42:41+07:00

Свойства text элемента управления является строкой, в свою очередь являющейся массивом символом. Вы не можете осуществить преобразование символа в строку. Тем не менее, вы можете получить доступ ко всем символам строки через их индекс.

Попробуйте это:

Code:

var

s: string;

begin

s := RevField.text;

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

RevField.text := s;

end;

Здесь кроется 2 проблемы:

Для увеличения значения вам необходимо извлекать символы из строки.

Хотя вы можете получить доступ к отдельным символам через выделение подстроки, данный метод не срабатывает у некоторых свойств, таких как, например, свойство TStringField Text.

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

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

Как определить, что два слова имеют схожее произношение

2013-08-22T17:16:34+07:00

Автор: Lloyd

Функция Soundex определяет схожесть звучания двух слов. Алгоритм Soundex опубликован в одной из статей журнала PC Magazine и предназначен для работы с английским языком (может кто-нибудь портирует для работы с нашим могучим? Пишите). Функции передается строка. Возвращаемое Soundex значение также имеет тип строки. Эта величина может сохраняться в базе данных или сравниваться с другим значением Soundex. Если два слова имеют одинаковое значение Soundex, можно предположить, что звучат они одинаково (более или менее).

Вы должны иметь в виду, что алгоритм Soundex игнорирует первую букву слова. Таким образом, "won" и "one" будут иметь различное значение Soundex, а "Won" и "Wunn" - одинаковое.

Soundex будет особенно полезен в базах данных, когда пользователь затрудняется с правописанием имен и фамилий.

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;

SoundAlike - функция, проверяющая схожесть звучания двух слов. При схожести звучания она возвратит значение True и значение False в противном случае. Она демонстрирует пример использования функции Soundex.

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;

Дополнение

Существует алгоритм ("параметрической корреляции", если я вообще правильно называю его), основанный на оценке схожести слов по количеству совпадающих букв идущих друг за другом. Примечание: буквы не обязательно идут *непосредственно* друг за другом, т.е. без других букв.

Пример:

Андрей vs. Андрей - 6

ндрей vs. Андрей - 5

Анрей vs. Андрей - 5

Андрей vs. Александр - 4

Андрей vs. Иннокентий - 2

АнXрей vs. Андрей - 3, но в то же время с другими словами результат

будет на уровне 0..2

Как получить количество активных ссылок на строку?

2013-08-22T14:41:47+07:00

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;

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

2013-08-22T14:49:09+07:00

Code:

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

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

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

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

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

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;

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;

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

2013-08-22T17:11:05+07:00

Code:

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

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

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

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

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

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

за один раз.

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

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

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

//пример:

function ClassName(hwnd: tHandle): shortstring;

begin

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

end;

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

2013-08-22T14:44:00+07:00

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, Махачкала

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

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.

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

Code:

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

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

Получить количество ссылок AnsiString

2013-08-22T17:14:40+07:00

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;

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

2013-08-22T17:11:56+07:00

Code:

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

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

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

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

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

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

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;

Расстояние (разность) между двумя строками. Функция Левенштейна

2013-08-22T14:45:11+07:00

Code:

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

>> Расстояние (разность) между двумя строками. Функция Левенштейна

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

Автор: Андрей aka wicked, wilk@ua.fm, ICQ:92356239, Тернополь

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

const cuthalf = 100; // константа, ограничивающая макс. длину

// обрабатываемых строк

var buf: array [0..((cuthalf * 2) - 1)] of integer; // рабочий буффер, заменяет

// матрицу, представленную

// в описании

function min3(a, b, c: integer): integer; // вспомогательная функция

begin

Result := a;

if b < Result then Result := b;

if c < Result then Result := c;

end;

// реализация функции в принципе соответствует описанию с одной оговоркой:

// матрица из описания заменена статическим буффером, длина которого

// равна удвоенной максимальной длине строк

// это сделано для 1) экономии памяти и во избежание её перераспределений

// 2) повышения быстродействия (у меня функция работает

// в обработчике onfilterRecord)

// таким образом, в реализации половинами буффера представлены только

// две последние строки матрицы, которые меняются местами каждую

// итерацию внешнего цикла (по i)... для определения того, какая из половин

// буффера является "нижней строкой", служит переменная flip

// т. е. при flip = false первая половина буффера является предпоследней

// строкой, а вторая - последней; при flip = true наоборот,

// первая половина - последняя строка, вторая половина - предпоследняя

function LeveDist(s, t: string): integer;

var i, j, m, n: integer;

cost: integer;

flip: boolean;

begin

s := copy(s, 1, cuthalf - 1);

t := copy(t, 1, cuthalf - 1);

m := length(s);

n := length(t);

if m = 0then Result := n

elseif n = 0then Result := m

elsebegin

flip := false;

for i := 0to n do buf[i] := i;

for i := 1to m dobegin

if flip then buf[0] := i

else buf[cuthalf] := i;

for j := 1to n dobegin

if s[i] = t[j] then cost := 0

else cost := 1;

if flip then

buf[j] := min3((buf[cuthalf + j] + 1),

(buf[j - 1] + 1),

(buf[cuthalf + j - 1] + cost))

else

buf[cuthalf + j] := min3((buf[j] + 1),

(buf[cuthalf + j - 1] + 1),

(buf[j - 1] + cost));

end;

flip := not flip;

end;

if flip then Result := buf[cuthalf + n]

else Result := buf[n];

end;

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

Code:

// на форме имеются поля Edit1 и Edit2, метка Label1

.....

Label1.Caption := IntToStr(LeveDist(Edit1.Text, Edit2.Text));

.....

Сase для строки

2013-08-22T17:09:04+07:00

Code:

const

vlist = 'первый, второй, третий';

var

Values: TStringList;

procedure SetValues(VL : TStringList; S: String);

var

I : Integer;

begin

VL.CommaText := S;

for I := 0to CL.Count-1do

VL.Objects[I] := Pointer(I);

VL.Sorted := True;

end;

function GetValueIndex(VL : TStringList; Match: String): Integer;

begin

Result := VL.IndexOf(Match);

if Result >= 0then

Result := Integer(VL.Objects[Result]);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

case GetValueIndex(Values, Edit1.Text) of

-1: {не найден} ;

0: Caption := '0';

1: Caption := '1';

2: Caption := '2';

end;

initialization

VL := TStringList.Create;

SetValues(VL, vlist);

finalization

VL.Free;

Сумма и количество прописью, работа с падежами

2013-08-22T17:08:20+07:00

Code:

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

>> Сумма и количество прописью, работа с падежами

Несколько функций для работы с строками:

function SumToString(Value : String) : string;//Сумма прописью

function KolToStrin(Value : String) : string;//Количество прописью

function padeg(s:string):string;//Склоняет фамилию имя и отчество (кому)

function padegot(s:string):string;//Склоняет фамилию имя и отчество (от кого)

function fio(s:string):string;//фамилия имя и отчество сокращенно

function longdate(s:string):string;//Длинная дата

procedure getfullfio(s:string;var fnam,lnam,onam:string);//Получить из строки фамилию имя и отчество сокращенно

Зависимости: uses SysUtils, StrUtils,Classes;

Автор: Eda, eda @ arhadm.net.ru, Архангельск

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

unit sumstr;

interface

uses

SysUtils, StrUtils,Classes;

var rub:byte;

function SumToString(Value : String) : string;//Сумма прописью

function KolToStrin(Value : String) : string;//Количество прописью

function padeg(s:string):string;//Склоняет фамилию имя и отчество (кому)

function padegot(s:string):string;//Склоняет фамилию имя и отчество (от кого)

function fio(s:string):string;//фамилия имя и отчество сокращенно

function longdate(s:string):string;//Длинная дата

procedure getfullfio(s:string;var fnam,lnam,onam:string);//Получить из строки фамилию имя и отчество сокращенно

implementation

const a:array[0..8,0..9] ofstring=(

('','один ','два ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('тысяч ','одна тысяча ','две тысячи ','три тысячи ','четыре тысячи ','пять тысяч ','шесть тысяч ','семь тысяч ','восемь тысяч ','девять тысяч '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('миллионов ','один миллион ','два миллиона ','три миллиона ','четыре миллиона ','пять миллионов ','шесть миллионов ','семь миллионов ','восемь миллионов ','девять миллионов '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '));

c:array[0..8,0..9] ofstring=(

('','одна ','две ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('тысячь ','одна тысяча ','две тысячи ','три тысячи ','четыре тысячи ','пять тысяч ','шесть тысяч ','семь тысяч ','восемь тысяч ','девять тысяч '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),

('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),

('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '));

b:array[0..9] ofstring=

('десять ','одинадцать ','двенадцать ','тринадцать ','четырнадцать ','пятнадцать ','шестнадцать ','семнадцать ','восемнадцать ','девятнадцать ');

var pol:boolean;

function longdate(s:string):string;//Длинная дата

var

Pr: TDateTime;

Y,M,D: Word;

begin

Pr:= strtodate(s);

DecodeDate(Pr,Y,M,D);

case m of

1:s:='Января';

2:s:='Февраля';

3:s:='Марта';

4:s:='Апреля';

5:s:='Мая';

6:s:='Июня';

7:s:='Июля';

8:s:='Августа';

9:s:='Сентября';

10:s:='Октября';

11:s:='Ноября';

12:s:='Декабря';

end;

result:=inttostr(d)+' '+s+' '+inttostr(y)

end;

function SumToStrin(Value : String) : string;

var s,t:string;

p,pp,i,k:integer;

begin

s:=value;

if s='0'then t:='Ноль 'elsebegin

p:=length(s);

pp:=p;

if p>1then

if (s[p-1]='1') and (s[p]>='0') thenbegin

t:=b[strtoint(s[p])];pp:=pp-2;end;

i:=pp;

while i>0dobegin

if (i=p-3) and (p>4) then

if s[p-4]='1'thenbegin

t:=b[strtoint(s[p-3])]+'тысяч '+t;i:=i-2;end;

if (i=p-6) and (p>7) then

if s[p-7]='1'thenbegin

t:=b[strtoint(s[p-6])]+'миллионов '+t;

i:=i-2;end;

if i>0thenbegin k:=strtoint(s[i]);

t:=a[p-i,k]+t;

i:=i-1;end;

end;end;

result:=t;

end;

function kolToStrin(Value : String) : string;

var s,t:string;

p,pp,i,k:integer;

begin

s:=value;

if s='0'then t:='Ноль 'elsebegin

p:=length(s);

pp:=p;

if p>1then

if (s[p-1]='1') and (s[p]>'0') thenbegin

t:=b[strtoint(s[p])];pp:=pp-2;end;

i:=pp;

while i>0dobegin

if (i=p-3) and (p>4) then

if s[p-4]='1'thenbegin

t:=b[strtoint(s[p-3])]+'тысяча '+t;i:=i-2;end;

if (i=p-6) and (p>7) then

if s[p-7]='1'thenbegin

t:=b[strtoint(s[p-6])]+'миллионов '+t;

i:=i-2;end;

if i>0thenbegin k:=strtoint(s[i]);

t:=c[p-i,k]+t;

i:=i-1;end;

end;end;

result:=t;

end;

procedure get2str(value:string;var hi,lo:string);

var p:integer;

begin

p:=pos(',',value);

lo:='';hi:='';

if p=0then p:=pos('.',value);

if p<>0then delete(value,p,1);

if p=0thenbegin hi:=value;lo:='00';exit;end;

if p>length(value) thenbegin hi:=value;lo:='00';exit;end;

if p=1thenbegin hi:='0';lo:=value;exit;end;

begin

hi:=copy(value,1,p-1);

lo:=copy(value,p,length(value));

if length(lo)<2then lo:=lo+'0';

end;

function sumtostring(value:string):string;

var hi,lo,valut,loval:string;

pr,er:integer;

begin

get2str(value,hi,lo);

if (hi='') or (lo='') thenbegin result:='';exit;end;

val(hi,pr,er);if er<>0thenbegin result:='';exit;end;

if rub=0thenbegin

if hi[length(hi)]='1'then valut:='рубль ';

if (hi[length(hi)]>='2') and (hi[length(hi)]<='4') then valut:='рубля ';

if (hi[length(hi)]='0') or (hi[length(hi)]>='5') or

((strtoint(copy(hi,length(hi)-1,2))>10) and (strtoint(copy(hi,length(hi)-1,2))<15)) then valut:='рублей ';

if (lo[length(lo)]='0') or (lo[length(lo)]>='5') then loval:=' копеек';

if lo[length(lo)]='1'then loval:=' копейка';

if (lo[length(lo)]>='2') and (lo[length(lo)]<='4') then loval:=' копейки';

end

elsebegin

if (hi[length(hi)]='0') or (hi[length(hi)]>='5') then valut:='долларов ';

if hi[length(hi)]='1'then valut:='доллар ';

if (hi[length(hi)]>='2') and (hi[length(hi)]<='4') then valut:='доллара ';

if (lo[length(lo)]='0') or (lo[length(lo)]>='5') then loval:=' центов';

if lo[length(lo)]='1'then loval:=' цент';

if (lo[length(lo)]>='2') and (lo[length(lo)]<='4') then loval:=' цента';

end;

hi:=sumtostrin(inttostr(pr))+valut;

if lo<>'00'thenbegin

val(lo,pr,er);if er<>0thenbegin result:='';exit;end;

lo:=inttostr(pr);

end;

if length(lo)<2then lo:='0'+lo;

lo:=lo+loval;

hi[1]:=AnsiUpperCase(hi[1])[1];

result:=hi+lo;

end;

function pfam(s:string):string;

begin

if (s[length(s)]='к') or(s[length(s)]='ч') and (pol=true) then s:=s+'у';

if s[length(s)]='в'then s:=s+'у';

if s[length(s)]='а'thenbegin delete(s,length(s),1);

result:=s+'ой';exit;end;

if s[length(s)]='н'then s:=s+'у';

if s[length(s)]='й'thenbegin delete(s,length(s)-1,2);

result:=s+'ому';end;

if s[length(s)]='я'thenbegin delete(s,length(s)-1,2);

result:=s+'ой';exit;end;

result:=s;

end;

function pnam(s:string):string;

begin

pol:=true;

if s[length(s)]='й'thenbegin delete(s,length(s),1);

s:=s+'ю';end;

if s[length(s)]='л'then s:=s+'у';

if s[length(s)]='р'then s:=s+'у';

if s[length(s)]='м'then s:=s+'у';

if s[length(s)]='н'then s:=s+'у';

if s[length(s)]='я'thenbegin pol:=false;delete(s,length(s),1);

s:=s+'е';end;

if s[length(s)]='а'thenbegin pol:=false;delete(s,length(s),1);

s:=s+'е';end;

result:=s;

end;

function potch(s:string):string;

begin

if s[length(s)]='а'thenbegin delete(s,length(s),1);

s:=s+'е';end;

if s[length(s)]='ч'then s:=s+'у';

result:=s;

end;

function ofam(s:string):string;

begin

if (s[length(s)]='к') or(s[length(s)]='ч') and (pol=true) then s:=s+'а';

if s[length(s)]='а'thenbegin delete(s,length(s),1);

result:=s+'ой';exit;end;

if s[length(s)]='в'then s:=s+'а';

if s[length(s)]='н'then s:=s+'а';

if s[length(s)]='й'thenbegin delete(s,length(s)-1,2);

result:=s+'ова';end;

if s[length(s)]='я'thenbegin delete(s,length(s)-1,2);

result:=s+'ой';exit;end;

result:=s;

end;

function onam(s:string):string;

begin

pol:=true;

if s[length(s)]='а'thenif s[length(s)-1]='г'then

begin pol:=false;delete(s,length(s),1);

s:=s+'и';endelse

begin pol:=false;delete(s,length(s),1);

s:=s+'ы';end;

if s[length(s)]='л'then s:=s+'а';

if s[length(s)]='р'then s:=s+'а';

if s[length(s)]='м'then s:=s+'а';

if s[length(s)]='н'then s:=s+'а';

if s[length(s)]='я'thenbegin pol:=false;delete(s,length(s),1);

s:=s+'и';end;

if s[length(s)]='й'thenbegin delete(s,length(s),1);

s:=s+'я';end;

result:=s;

end;

function ootch(s:string):string;

begin

if s[length(s)]='а'thenbegin delete(s,length(s),1);

s:=s+'ы';end;

if s[length(s)]='ч'then s:=s+'а';

result:=s;

end;

function padeg(s:string):string;

var q:tstringlist;

p:integer;

begin

if s<>''thenbegin

q:=tstringlist.Create;

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);end;

end;end;

if q.Count>1then result:=result+' '+pnam(q[1]);

if q.Count>0then result:=pfam(q[0])+result;

if q.Count>2then result:=result+' '+potch(q[2]);

q.Free;

end;

function fio(s:string):string;

var q:tstringlist;

p:integer;

begin

if s<>''thenbegin

q:=tstringlist.Create;

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(copy(s,1,1)) elsebegin

q.Add(copy(s,1,1));

end;

end;end;

if q.Count>1then result:=q[0]+' '+q[1]+'.';

if q.Count>2then result:=result+q[2]+'.';

q.Free;

end;

function padegot(s:string):string;

var q:tstringlist;

p:integer;

begin

if s<>''thenbegin

q:=tstringlist.Create;

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);

p:=pos(' ',s);

if p=0then p:=pos('.',s);

if p=0then q.Add(s) elsebegin

q.Add(copy(s,1,p-1));

delete(s,1,p);end;

end;end;

if q.Count>1then result:=result+' '+onam(q[1]);

if q.Count>0then result:=ofam(q[0])+result;

if q.Count>2then result:=result+' '+ootch(q[2]);

q.Free;

end;

procedure getfullfio(s:string;var fnam,lnam,onam:string);//Получить из строки фамилию имя и отчество сокращенно

begin

fnam:='';lnam:='';onam:='';

fnam:=copy(s,1,pos(' ',s));

delete(s,1,pos(' ',s));

lnam:=copy(s,1,pos(' ',s));

delete(s,1,pos(' ',s));

onam:=s;

end;

begin

rub:=0;

end.

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

Code:

s:=SumToString('123.00');

Удаление из файла элементов HTML

2013-08-22T17:13:03+07:00

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

Следующие две процедуры показывают, как это можно сделать:

Code:

procedure TMainForm.LoadFileIntoList(TextFileName: string;

AWebPage: TStringList; WithFilter: Boolean);

var

CurrentFile: TStringList;

begin

CurrentFile := TStringList.Create;

CurrentFile.LoadFromFile(TextFileName);

if WithFilter then

FilterHTML(CurrentFile,AWebPage)

else

with AWebPage do

AddStrings(CurrentFile);

CurrentFile.Free;

end;

procedure TMainForm.FilterHTML(FilterInput, AWebPage: TStringList);

var

i, j: LongInt;

S: string;

begin

FilterMemo.Lines.Clear;

FilterMemo.Lines := FilterInput;

with AWebPage do

begin

FilterMemo.SelectAll;

j := FilterMemo.SelLength;

if j > 0then

begin

i := 0;

repeat

// ищем cr

if FilterMemo.Lines.GetText[i] = Char(VK_RETURN) then

S := S + #10#13;

else

if FilterMemo.Lines.GetText[i] = '<'then

repeat

inc(i);

until

FilterMemo.Lines.GetText[i] = '>'

else

// ищем tab

if FilterMemo.Lines.GetText[i] = Char(VK_TAB) then

S := S + ' '

else

S := S + FilterMemo.Lines.GetText[i]; // добавляем текст

inc(i);

until

i = j + 1;

Add(S); // добавляем строку в WebPage

end

else

Add('No data entered into field.'); // no data in text file

end;

Применение функции:

Всё, что нужно сделать - это вызвать :

LoadFileIntoList("filename.txt",Webpage, True);

Где:

filename

это имя файла, который вы хотите обработать.

WebPage

это TStringList

последний параметр в функции

указывает, применять или нет HTML-фильтр.

PS: В этом примере объект TMemo (который вызывается из "FilterMemo") лежит на форме и поэтому не видим.

Пример:

Code:

WebPage := TStringList.Create;

try

Screen.Cursor := crHourGlass;

AddHeader(WebPage);

with WebPage do

begin

Add('Personal Details');

LoadFileIntoList("filename.txt", Webpage, True);

end;

AddFooter(WebPage);

finally

WebPage.SaveToFile(HTMLFileName);

WebPage.Free;

Screen.Cursor := crDefault;

end;

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

2013-08-22T17:13:56+07:00

Code:

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

>> Функция проверки корректности ввода

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

символов

Rej - флаг режима

если Rej:=true, то Conf - строка недопустимых символов

если Rej:=false, то Conf - строка допустимых символов

Input - входная строка

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

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

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

function ConformStr(Input, Conf: string; Rej: boolean): boolean;

var

i: integer;

begin

result := true;

if Rej then

begin

for i := 1to length(Conf) do

begin

if pos(Conf[i], Input) <> 0then

begin

result := false;

break;

end

end;

end

else

begin

for i := 1to length(Input) do

begin

if pos(Input[i], Conf) = 0then

begin

result := false;

break;

end;

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

s := 'Приве6т!';

ifnot ConformStr(s, '0123456789') then

s := Strtst(s, '0123456789');

//после этого s='Привет!'