Работа со строками

Выравнивание текста по ширине

2013-08-20T17:17:39+07:00

Текст выглядит лучше, если он выровнен по двух краям. Для этого пробелы в каждой строке нужно удлинять или укорачивать так, чтобы все строки имели одну длину.

Здесь создана процедура GetLine, которая возвращает одну строку, начиная с заданного символа. Программа находит разницу между шириной текста и реальной длинной строки и при выводе компенсирует эту разницу удлинением пробелов.

Эта программа выводит на экран текст из файла C:\text.txt, выравнивая его по двум краям.

Code:

type

...

TLine = record

s: string;

wrap: boolean;

length: integer;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

const

FileName = 'C:\text.txt';

var

s: string;

bm: TBitMap;

LineH: integer;

MaxTextWidth: integer;

procedure TForm1.FormCreate(Sender: TObject);

var

F: TFileStream;

buf: array [0..127] of char;

l: integer;

begin

ScrollBar1.Kind := sbVertical;

bm := TBitMap.Create;

with bm.Canvas.Font do

begin

name := 'Serif';

Size := 12;

end;

LineH := bm.Canvas.TextHeight('123');

ifnot FileExists(FileName) then

begin

ShowMessage('Can not find file ' + FileName);

Exit;

end;

F := TFileStream.Create(FileName, fmOpenRead);

repeat

l := F.read(buf, 128);

if l = 128then

s := s + buf

else

s := s + copy(buf, 1, l);

until

l < 128;

F.Destroy;

end;

procedure TForm1.FormResize(Sender: TObject);

begin

PaintBox1.Left := 0;

PaintBox1.Top := 0;

PaintBox1.Height := Form1.ClientHeight;

PaintBox1.Width := Form1.ClientWidth - ScrollBar1.Width;

ScrollBar1.Left := PaintBox1.Width;

ScrollBar1.Top := 0;

ScrollBar1.Height := PaintBox1.Height;

bm.Width := PaintBox1.Width;

bm.Height := PaintBox1.Height;

ScrollBar1.Max := 1000;

MaxTextWidth := PaintBox1.Width - 20;

end;

function RealTextWidth(s: string): integer;

var

i: integer;

begin

result := bm.Canvas.TextWidth(s);

for i := 1to Length(s) do

if s[i] = #9then

inc(result, 40 - bm.Canvas.TextWidth(#9));

end;

function GetLine(index: integer): TLine;

var

i: integer;

s1: string;

first: integer;

begin

if (s[index] = #13) and (s[index + 1] = #10) then

begin

result.s := '';

result.length := 2;

result.wrap := true;

Exit;

end;

first := index;

while (first <= Length(s)) and (s[first] in [#32]) do

inc(first);

i := first;

repeat

while (i <= Length(s)) and (not (s[i] in [#9, #32])) and (s[i] <> #13) do

inc(i);

s1 := copy(s, first, i - index);

inc(i);

until

(i >= Length(s)) or (s[i-1] = #13) or (RealTextWidth(s1) > MaxTextWidth);

if RealTextWidth(s1) > MaxTextWidth then

begin

result.wrap := false;

if i < Length(s) then

begin

dec(i, 2);

while (i > 0) and (not (s[i] in [#9, #32])) do

dec(i);

result.Length := i - index;

while (i > 0) and (s[i] in [#9, #32]) do

dec(i);

end;

result.s := copy(s, first, i - index + 1);

if result.s[length(result.s)] = #32then

delete(result.s, length(result.s) , 1);

end

else

begin

result.length := i - index + 1;

s1 := copy(s, first, i - index + 1);

if length(s1) > 0then

begin

if s1[Length(s1)] = #9then

delete(s1, Length(s1), 1);

if s1[length(s1) - 1] + s1[length(s1)] = #13#10then

delete(s1, length(s1) - 1, 2);

end;

result.s := s1;

result.wrap := true;

end;

procedure draw;

var

i, j: integer;

line: TLine;

OneWord: string;

LineN: integer;

SpaceCount: integer;

TextLeft: integer;

shift, allshift: integer;

d: integer;

LineCount: integer;

begin

with bm.Canvas do

begin

FillRect(ClipRect);

i := 1;

LineCount := 0;

for j := 1to Form1.ScrollBar1.Position do

begin

line := GetLine(i);

inc(i, line.length);

inc(LineCount);

end;

LineN := 0;

repeat

line := GetLine(i);

SpaceCount := 0;

TextLeft := 0;

for j := 1to Length(line.s) do

if line.s[j] = #32then

inc(SpaceCount);

if line.wrap = false then

allshift := MaxTextWidth - RealTextWidth(line.s)

else

allshift := 0;

if allshift > 40 * SpaceCount then

allshift := 0;

shift := 0;

for j := 1to Length(line.s) do

begin

if (not (line.s[j] in [#9, #32])) and (j < Length(line.s)) then

begin

OneWord := OneWord + line.s[j];

end

else

begin

OneWord := OneWord + line.s[j];

if OneWord = #9then

begin

inc(TextLeft, 40);

end

else

begin

if OneWord = #13#10then

begin

inc(LineN);

end

else

begin

TextOut(10 + TextLeft, LineN * LineH, OneWord);

if SpaceCount = 0then

d := 0

else

d := (allshift - shift) div (SpaceCount);

inc(shift, d);

inc(TextLeft, TextWidth(OneWord) + d);

dec(SpaceCount);

end;

OneWord := '';

end;

inc(i, line.length);

inc(LineN);

until

(LineN * LineH > Form1.PaintBox1.Height) or (i >= Length(s));

repeat

line := GetLine(i);

inc(i, line.length);

inc(LineCount);

until

i >= Length(s);

inc(LineCount, LineN);

Form1.ScrollBar1.Max := LineCount -

Form1.PaintBox1.Height div LineH;

end;

Form1.PaintBox1.Canvas.Draw(0, 0, bm);

end;

procedure TForm1.PaintBox1Paint(Sender: TObject);

begin

draw;

end;

procedure TForm1.ScrollBar1Change(Sender: TObject);

begin

draw;

end;

Дополнение строки пробелами

2013-08-20T17:09:49+07:00

Code:

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

>> Дополнение строки пробелами слева

Дополненяет строку слева пробелами до указанной длины

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

Автор: Anatoly Podgoretsky, anatoly@podgoretsky, Johvi

Дата: 26 апреля 2002 г.

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

function PADL(Src: string; Lg: Integer): string;

begin

Result := Src;

while Length(Result) < Lg do

Result := ' ' + Result;

end;

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

>> Дополнение строки пробелами справа

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

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

Автор: Anatoly Podgoretsky, anatoly@podgoretsky, Johvi

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

function PADR(Src: string; Lg: Integer): string;

begin

Result := Src;

while Length(Result) < Lg do

Result := Result + ' ';

end;

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

>> Дополнение строки пробелами с обоих сторон

Дополнение строки пробелами с обоих сторон до указанной длины

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

Автор: Anatoly Podgoretsky, anatoly@podgoretsky, Johvi

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

function PADC(Src: string; Lg: Integer): string;

begin

Result := Src;

while Length(Result) < Lg do

begin

Result := Result + ' ';

if Length(Result) < Lg then

begin

Result := ' ' + Result;

end;

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

S := PADL(S,32);

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

2013-08-20T19:28:34+07:00

Code:

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

>> Функция замены в строке всех вхождений одной подстроки на другую

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

заменить не только одно слово совершенно другим,

но и допустим, слово "Штаны" на "-Штаны-"

(Т.е. начальное слово после замены остается, но к нему добавляется какой нибудь

символ справа, или слева. В данном случае по краям слова добавлен знак минуса).

Я пересмотрел много примеров, и ни один из них не справился с этой задачей.

(Может я плохо искал?).

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

Автор: Матюшкин Сергей, seregam @ ua.fm, ICQ:162733776, Днепропетровск

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

function Replace(Str, X, Y: string): string;

{Str - строка, в которой будет производиться замена.

X - подстрока, которая должна быть заменена.

Y - подстрока, на которую будет произведена заменена}

var

buf1, buf2, buffer: string;

i: Integer;

begin

buf1 := '';

buf2 := Str;

Buffer := Str;

while Pos(X, buf2) > 0do

begin

buf2 := Copy(buf2, Pos(X, buf2), (Length(buf2) - Pos(X, buf2)) + 1);

buf1 := Copy(Buffer, 1, Length(Buffer) - Length(buf2)) + Y;

Delete(buf2, Pos(X, buf2), Length(X));

Buffer := buf1 + buf2;

end;

Replace := Buffer;

end;

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

procedure TForm1.Button1Click(Sender: TObject);

var

a: Integer;

begin

for a := 0to Memo1.Lines.Count do

Memo1.Lines[a] := Replace(Memo1.Lines[a], 'Штаны', '-Штаны-');

end;

Всё значительно проще! В Борланд уже всё сделали до нас:

Code:

//заменить первое вхождение подстроки с учётом регистра

S:=StringReplace(ИсходнаяСтрока, ЧтоЗаменять, НаЧтоЗаменять, [])

//заменить все вхождения подстроки с учётом регистра

S:=StringReplace(ИсходнаяСтрока, ЧтоЗаменять, НаЧтоЗаменять, [rfReplaceAll])

//заменить первое вхождение подстроки без учёта регистра

S:=StringReplace(ИсходнаяСтрока, ЧтоЗаменять, НаЧтоЗаменять, [rfIgnoreCase])

//заменить все вхождения подстроки без учёта регистра

S:=StringReplace(ИсходнаяСтрока, ЧтоЗаменять, НаЧтоЗаменять, [rfReplaceAll, rfIgnoreCase])

Как использовать format parameter больше одного раза?

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

Sometimes you probably have written something like this:

Code:

s := Format('Hello %s, your name is %s %s', [FirstName, FirstName, LastName]);

(an admittedly stupid example ;-) )

And if you do, you probably found it annoying that you need to specify the FirstName parameter twice, in particular if there are lots of similar lines. But this isn't necessary because you can specify the parameter position to use for the placeholder

in the format string like this:

Code:

s := Format('Hello %0:s, your name is %0:s %1:s', [FirstName, LastName]);

Just one more example from a code generator I am currently writing:

Code:

TableName := 'Customer';

...

s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);

which results in

Code:

s := ' fCustomerTableAuto := TCustomerTableAuto.Create(fCustmerTable);';

Как удалить переносы из строки

2013-08-20T18:35:41+07:00

Code:

function DeleteLineBreaks(const S: string): string;

var

Source, SourceEnd: PChar;

begin

Source := Pointer(S);

SourceEnd := Source + Length(S);

while Source < SourceEnd do

begin

case Source^ of

#10: Source^ := #32;

#13: Source^ := #32;

end;

Inc(Source);

end;

Result := S;

end;

https://delphiworld.narod

DelphiWorld 6.0

Можно значительно проще:

Code:

function DeleteLineBreaks(const S: string): string;

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

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

begin

Result := StringReplace(S, #10#13, '',[rfReplaceAll]);

end;

Наполнение строки

2013-08-20T19:32:15+07:00

Code:

function Spcs(num : byte) : string;

var

tmp : string;

begin

fillchar(tmp, num+1, ' '); {инициализация всей строки пробелами}

tmp[0] := chr(num); {устанавливаем длину строки с пробелами}

result := tmp;

end;

//Теперь достаточно написать

Edit1.Text := SurName + spcs(10) + FirstName

https://delphiworld.narod

DelphiWorld 6.0

Решением является создание функции, функционально похожей на функцию Clipper:

PadL(string, width, character)

Code:

function TfrmFunc.PadL(cVal: string; nWide: integer; cChr: char): string;

var

i1, nStart: integer;

begin

if length(cVal) < nWide then

begin

nStart:=length(cVal);

for i1:=nStart to nWide-1do

cVal:=cChar+cVal;

end;

PadL:=cVal;

end;

Затем это может вызываться c любой строкой, которой вы хотите задать определенную длину. Пользуйтесь функцией также, как вы привыкли пользоваться прежней - PadL(A,length(B),'0'); Она имеет большую гибкость - возможно заполнение любым символом до необходимой длины (удобно для задания текстовых счетчиков с фиксированным количеством символов -- PadL(A,6,'0').

https://delphiworld.narod

DelphiWorld 6.0

Code:

function LeftPad(S: string; Ch: Char; Len: Integer): string;

var

RestLen: Integer;

begin

Result := S;

RestLen := Len - Length(s);

if RestLen < 1then Exit;

Result := S + StringOfChar(Ch, RestLen);

end;

function RightPad(S: string; Ch: Char; Len: Integer): string;

var

RestLen: Integer;

begin

Result := S;

RestLen := Len - Length(s);

if RestLen < 1then Exit;

Result := StringOfChar(Ch, RestLen) + S;

end;

{Beispiel / Example}

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text := Rightpad(Edit2.Text, '-', 30);

end;

Обрезание строки по длине

2013-08-20T18:36:23+07:00

Автор: ___Nikolay

Code:

// Обрезание строки по длине

function TfmDW6Main.BeautyStr(s: string; iLength: integer): string;

var

bm: TBitmap;

sResult: string;

iStrLen: integer;

bAdd: boolean;

begin

Result := s;

if Trim(s) = ''then

exit;

bAdd := false;

sResult := s;

bm := TBitmap.Create;

bm.Width := 100;

bm.Height := 100;

iStrLen := bm.Canvas.TextWidth(sResult);

while iStrLen > iLength do

begin

if Length(sResult) < 4then

break;

Delete(sResult, Length(sResult) - 2, 3);

bAdd := true;

iStrLen := bm.Canvas.TextWidth(sResult);

end;

if (iStrLen <= iLength) and bAdd then

sResult := sResult + '...';

bm.Free;

Result := sResult;

end;

Очистка строки (символьное значение числа) от пробелов, нулей и точки

2013-08-20T18:45:07+07:00

Code:

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

>> Очистка строки (символьное значение числа) от пробелов, нулей и точки

Функция возращает строку очищенную от символов: пробел, ноль, точка.

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

Автор: Виталий, center_sapr @ mnogo.ru, Львов

Дата: 26 апреля 2002 г.

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

unit Unit2;

interface

function StrFl(st: string): string;

implementation

function StrFl(st: string): string;

label

p1, p2, p3;

var

poz: Byte;

k: integer;

stt: string;

begin

k := Length(st);

if k <= 1then

goto p2;

p1:

stt := Copy(st, 1, 1); {Очистка от пробелов}

if stt = ' 'then

begin

st := Copy(st, 2, k - 1);

k := k - 1;

goto p1;

end;

stt := Copy(st, k, 1);

if stt = ' 'then

begin

st := Copy(st, 1, k - 1);

k := k - 1;

goto p1;

end;

p3:

poz := Pos('.', st); {Очистка от нулей}

if poz = 0then

goto p2;

stt := Copy(st, k, 1);

if stt = '0'then

begin

st := Copy(st, 1, k - 1);

k := k - 1;

goto p3;

end;

if stt = '.'then{Очистка от точки}

begin

st := Copy(st, 1, k - 1);

end;

p2:

StrFl := st;

end;

end.

//Пример результатов:

//5.000 -> 5

//5.001 -> 5.001

//05.100 -> 05.1

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

2013-08-20T18:47:11+07:00

Code:

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

>> Очистка строки слева и справа от указанного символа

Функция возвращает строку Str, очищенную слева и справа от указанного символа Symbol.

Работает быстрее аналогичной функции UBPFD.TrimEx, так как не использует функцию

поиска Pos, имеет более компактный код.

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

Автор: lipskiy, lipskiyn@ mail.ru,

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

function TrimString(Str: string; Symbol: char): string;

begin

Result := Str;

if Str = ''then

exit;

Str := Trim(Str);

// Удаляем в начале строки

while (length(Str) > 0) and

(AnsiUpperCase(Str[1]) = AnsiUpperCase(Symbol)) do

Delete(Str, 1, 1);

// Удаляем в конце строки

while (length(Str) > 0) and

(AnsiUpperCase(Str[length(Str)]) = AnsiUpperCase(Symbol)) do

Delete(Str, length(Str), 1);

Result := Str;

end;

Code:

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

>> Очистка строки слева и справа от указанных символов

Функция возвращает word, очищеный от начальных и конечных символов, которые

попадают в строку TrimSymbols.

Например, ShowMessage (TrimEx('<MegaTeg>', '<>')), выведет сообщение "MegaTeg"

(без кавычек).

Зависимости: system, sysutils

Автор: VID, vidsnap @ mail.ru, ICQ:132234868, Махачкала

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

function TrimEX(Word, TrimSymbols: string): string;

var

x, a, b: Integer;

begin

Result := Word;

if TrimSymbols = ''then

exit;

Word := Trim(word);

if length(word) = 0then

exit;

x := 0;

repeat

x := x + 1;

until (pos(ansiuppercase(word[x]), ansiuppercase(TrimSymbols)) = 0)

or (x = length(word));

a := x;

x := length(word) + 1;

repeat

x := x - 1;

until (pos(ansiuppercase(word[x]), ansiuppercase(TrimSymbols)) = 0)

or (x = 1);

b := x;

word := copy(word, a, b - a + 1);

result := word;

end;