|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как разбить строку на несколько строк, чтобы текст умещался в окно по ширине?
// Функция WrapText возвращает копию Line, разбитую на несколько строк шириной MaxCol столбцов. Каждая строка разбивается,
// когда ее длина доходит до MaxCol символов. Разбиение производится там, где есть символы из множества BreakChars. При
// нахождении символа из BreakChars, после него вставляется строка BreakStr. (В Delphi 5 как существующие переводы строк
// рассматриваются символы #13 и #10, независимо от BreakStr.)
// Вторая форма WrapText использует [' ', ' -' , #9] (пробел, дефис, табуляция) в качестве BreakChars и #13#10 (возврат каретки,
// перевод строки) в качестве BreakStr. Получается эта форма просто переносит строку по словам.
procedure TForm1.FormResize(Sender: TObject);
var
S: string;
DC: HDC;
Metrics: TTextMetric;
CharsInWidth: Integer; //Сколько символов влезет в ширину окна
OldMapMode: Integer;
begin
S := 'Очень длинная строка, которую мы сейчас разбиваем на ';
S := S + 'кусочки и заполняем ими строки TListBox по всей ширине. ';
S := S + 'Ширину TListBox мы меняем, изменяя размеры формы, ';
S := S + 'т.к. у TListBox свойство Align равно alClient.';
DC := GetWindowDC(ListBox1.Handle); // Получаем контекст окна
SelectObject(DC, ListBox1.Font.Handle); // Выбираем в него шрифт окна
OldMapMode := GetMapMode(DC); // Запоминаем старый режим отображения
SetMapMode(DC, MM_TEXT); // Устанавливаем отображение в пикселях
GetTextMetrics(DC, Metrics); // Получаем параметры шрифта
SetMapMode(DC, OldMapMode); // Восстанавливаем режим отображения
ReleaseDC(ListBox1.Handle, DC); // Освобождаем контекст
// Получаем количество средних символов на ширину окна (в общем случае вычитаемое значение нужно подобрать вручную)
CharsInWidth := ListBox1.ClientWidth div Metrics.tmAveCharWidth - GetSystemMetrics(SM_CXSIZEFRAME);
ListBox1.Clear; // Очищаем TListBox
ListBox1.Items.Text := WrapText(S, CharsInWidth); //Заполняем TListBox
Caption := 'Количество строк в ListBox = ' + IntToStr(ListBox1.Count);
end;
|
Как заключить строку в кавычки?
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(QuotedStr('Строка'));
ShowMessage(AnsiQuotedStr('Строка', '"'));
end;
|
Как исключить из строки кавычки, обрамляющие её?
// Функция AnsiExtractQuotedStr выбирает из Src строку, заключенную в кавычки. Первый символ Src должен быть равен Quote,
// иначе функция сразу завершается, возвращая пустую строку. Повторяющиеся символы кавычек преобразуются в одиночные кавычки.
procedure TForm1.Button1Click(Sender: TObject);
var
s1: PChar;
s2: string;
begin
s1 := '/См. примечание /стр.56/';
s2 := AnsiExtractQuotedStr(s1, '/'); // s2 = 'См. примечание '
MessageDlg(s2, mtInformation, [mbOk], 0);
end;
|
Как сравнить строки с учетом чисел (натуральная сортировка)?
// Способ первый
function StrCmpLogicalW(psz1, psz2: PWideChar): Integer; stdcall; external 'Shlwapi.dll' name 'StrCmpLogicalW';
procedure TForm1.Button1Click(Sender: TObject);
var
Result: Integer;
begin
Result := StrCmpLogicalW(PWideChar('str_101'), PWideChar('str_23'));
end;
// Способ второй
// CompareStringOrdinal сравнивает две строки по аналогу проводника, т.е.
// "Новая папка (3)" < "Новая папка (103)"
//
// Возвращает следующие значения
// -1 - первая строка меньше второй
// 0 - строки эквивалентны
// 1 - первая строка больше второй
function CompareStringOrdinal(const S1, S2: string): Integer;
// Функция CharInSet появилась начиная с Delphi 2009,
// для более старых версий нужно реализовать ее аналог
(*
function CharInSet(AChar: Char; ASet: TSysCharSet): Boolean;
begin
Result := AChar in ASet;
end;
*)
var
S1IsInt, S2IsInt: Boolean;
S1Cursor, S2Cursor: PChar;
S1Int, S2Int, Mutiplier, S1ZeroCount, S2ZeroCount, S1IntLength, S2IntLength: Integer;
SingleByte: Byte;
begin
// Проверка на пустые строки
if S1 = '' then
if S2 = '' then
Exit(0)
else
Exit(-1);
if S2 = '' then
Exit(1);
S1Cursor := @AnsiLowerCase(S1)[1];
S2Cursor := @AnsiLowerCase(S2)[1];
while True do
begin
// Проверка на конец первой строки
if S1Cursor^ = #0 then
if S2Cursor^ = #0 then
Exit(0)
else
Exit(-1);
// Проверка на конец второй строки
if S2Cursor^ = #0 then
Exit(1);
// Проверка на начало числа в обоих строках
S1IsInt := CharInSet(S1Cursor^, ['0'..'9']);
S2IsInt := CharInSet(S2Cursor^, ['0'..'9']);
if S1IsInt and not S2IsInt then
Exit(-1);
if not S1IsInt and S2IsInt then
Exit(1);
// Посимвольное сравнение
if not (S1IsInt and S2IsInt) then
begin
if S1Cursor^ = S2Cursor^ then
begin
Inc(S1Cursor);
Inc(S2Cursor);
Continue;
end;
if S1Cursor^ < S2Cursor^ then
Exit(-1)
else
Exit(1);
end;
// Вытаскиваем числа из обоих строк и сравниваем
S1Int := 0;
Mutiplier := 1;
S1ZeroCount := 0;
S1IntLength := 0;
repeat
Inc(S1IntLength);
SingleByte := Byte(S1Cursor^) - Byte('0');
if (SingleByte = 0) and (S1Int = 0) then
Inc(S1ZeroCount); // Запоминаем количество нулей предшествующих числу
S1Int := S1Int * Mutiplier + SingleByte;
Inc(S1Cursor);
Mutiplier := 10;
until not CharInSet(S1Cursor^, ['0'..'9']);
S2Int := 0;
Mutiplier := 1;
S2ZeroCount := 0;
S2IntLength := 0;
repeat
Inc(S2IntLength);
SingleByte := Byte(S2Cursor^) - Byte('0');
if (SingleByte = 0) and (S2Int = 0) then
Inc(S2ZeroCount); // Запоминаем количество нулей предшествующих числу
S2Int := S2Int * Mutiplier + SingleByte;
Inc(S2Cursor);
Mutiplier := 10;
until not CharInSet(S2Cursor^, ['0'..'9']);
// Если длина числел одинаковая, сравниваем обычным способом
if S1IntLength = S2IntLength then
begin
if S1Int = S2Int then
Continue;
if S1Int < S2Int then
Exit(-1)
else
Exit(1);
end;
// В противном случае, если оба числа начинаются с нулей,
// то число, у которого нулей меньше идет первым
if (S1ZeroCount <> 0) and (S2ZeroCount <> 0) then
begin
if S1ZeroCount < S2ZeroCount then
Exit(-1);
if S1ZeroCount > S2ZeroCount then
Exit(1);
end;
// Если оба числа равны, то проверяем на наличие нулей перед одним из чисел
// если такое число находится - оно идет первым
if S1Int = S2Int then
begin
if S1ZeroCount > S2ZeroCount then
Exit(-1);
if S1ZeroCount < S2ZeroCount then
Exit(1);
Continue;
end;
// Ну а если не равны, то то котое меньше идет первым
if S1Int < S2Int then
Exit(-1)
else
Exit(1);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Result: Integer;
begin
Result := CompareStringOrdinal('str_101', 'str_23');
end;
// Способ третий
function CompareStr(Str1, Str2: string): Integer;
var
Num1, Num2: Double;
pStr1, pStr2: PChar;
Len1, Len2: Integer;
function IsNumber(ch: Char): Boolean;
begin
Result := ch in ['0'..'9'];
end;
function GetNumber(var pch: PChar; var Len: Integer): Double;
var
FoundPeriod: Boolean;
Count: Integer;
begin
FoundPeriod := False;
Result := 0;
while (pch^ <> #0) and (IsNumber(pch^) or ((not FoundPeriod) and (pch^ = '.'))) do
begin
if pch^ = '.' then
begin
FoundPeriod := True;
Count := 0;
end
else
begin
if FoundPeriod then
begin
Inc(Count);
Result := Result + (Ord(pch^) - Ord('0')) * Power(10, -Count);
end
else
Result := Result * 10 + Ord(pch^) - Ord('0');
end;
Inc(Len);
Inc(pch);
end;
end;
begin
if (Str1 <> '') and (Str2 <> '') then
begin
pStr1 := @Str1[1];
pStr2 := @Str2[1];
Result := 0;
while not ((pStr1^ = #0) or (pStr2^ = #0)) do
begin
Len1 := 0;
Len2 := 0;
while pStr1^ = ' ' do
begin
Inc(pStr1);
Inc(Len1);
end;
while pStr2^ = ' ' do
begin
Inc(pStr2);
Inc(Len2);
end;
if IsNumber(pStr1^) and IsNumber(pStr2^) then
begin
Num1 := GetNumber(pStr1, Len1);
Num2:=GetNumber(pStr2, Len2);
if Num1 < Num2 then
Result := -1
else if Num1 > Num2 then
Result := 1
else
begin
if Len1 < Len2 then
Result := -1
else
if Len1 > Len2 then
Result := 1;
end;
Dec(pStr1);
Dec(pStr2);
end
else
if pStr1^ <> pStr2^ then
begin
if pStr1^ < pStr2^ then
Result := -1
else
Result := 1;
end;
if Result <> 0 then
Break;
Inc(pStr1);
Inc(pStr2);
end;
end;
Num1 := Length(Str1);
Num2 := Length(Str2);
if (Result = 0) and (Num1 <> Num2) then
if Num1 < Num2 then
Result := -1
else
Result := 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Result: Integer;
begin
Result := CompareStr('str_101', 'str_23');
end;
// Способ четвертый
uses
{...,} JclStrings;
procedure TForm1.Button1Click(Sender: TObject);
var
Result: Integer;
begin
Result := CompareNaturalStr('str_101', 'str_23');
// Result := CompareNaturalText('str_101', 'str_23');
end;
// или
uses
{...,} JclAnsiStrings;
procedure TForm1.Button1Click(Sender: TObject);
var
Result: Integer;
begin
Result := AnsiCompareNaturalStr('str_101', 'str_23');
// Result := AnsiCompareNaturalText('str_101', 'str_23');
end;
|
Как поставить знак ударения в строке?
// Программа должна поддерживать Unicode
function AddAccentToString(Str: WideString; Position: Word): WideString;
var
W1, W2: WideString;
begin
W1 := Copy(Str, 1, Position);
W2 := Copy(Str, Position+1, Length(Str));
Result := W1 + WideChar(769) + W2;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := AddAccentToString(Caption, 1);
end;
|
Как привести строку к формату установленной OS?
(*
function AdjustLineBreaks(const S: string [; Style: TTextLineBreakStyle]): string;
Вот так определена эта функция в SysUtils:
TTextLineBreakStyle = (tlbsLF, tlbsCRLF);
function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle =
{$IFDEF LINUX} tlbsLF {$ENDIF}
{$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}): string;
А в модуле ComCtrls.pas эта функция написана на ассемблере для работы с PChar:
function AdjustLineBreaks(Dest, Source: PChar): Integer; assembler;
Функция AdjustLineBreaks приводит строку S к формату установленной OS, преобразуя символы
перевода строки (одиночные символы возврата каретки (#13), перевода строки (#10), и пары CR-LF)
применительно к данной ОС. Файлы, копируемые из систем Unix и Macintosh, содержат иные символы
окончания строк, чем могут "ввести в заблуждение" многие программы DOS и Windows. (В Macintosh
используется только символ возврата каретки; в Unix - только символ перевода строки.)
Второй необязательный параметр позволяет управлять форматированием. Можно адаптировать переносы строк,
как под Windows (tlbsCRLF), так и под Unix (tlbsLF). По умолчанию он определяется установленной ОС.
var
UnixStr: string;
begin // Преобразование текста под Unix
UnixStr := AdjustLineBreaks(Memo1.Text, tlbsLF);
end;
Эта функция часто может понадобиться, чтобы общаться с серверами в сети, т.к. серверы чаще всего
работают по никсами, а клиенты под виндой.
Наглядно продимонстрировать работу функции можно на примере WhoIs-клиента:
*)
procedure TForm1.Button1Click(Sender: TObject);
var
Result: string;
begin
Memo1.Clear;
try
// Получаем данные
Result := IdWhois1.WhoIs('http://decoding.dax.ru/');
// Обработка
Memo1.Text := AdjustLineBreaks(Result);
except
on E: Exception do
Memo1.Lines.Add('ОШИБКА: ' + E.Message);
end;
end;
|
Как перевести строку вида "1,2,3,5,7" в вид "1-3,5,7"?
// Способ первый
// формат строки 1,2,3,5,7
function NumSeparator(inp: string): string;
var
o, a, c, p, r: string;
begin
o := '';
p := '-1';
r := '';
a := inp;
while a <> '' do
begin
if Copy(a, 0, 1) = ',' then
a := Copy(a, 1);
if Pos(',', a) > 0 then
begin
c := Copy(a, 0, Pos(',', a) - 1);
a := Copy(a, Pos(',', a) + 1);
end
else
begin
c := a;
a := '';
end;
if p = '-1' then
o := o + c
else if StrToInt(p) + 1 <> StrToInt(c) then
begin
if r <> '' then
begin
o := o + '-' + r;
r := '';
end;
o := o + ',' + c;
end
else
r := c;
p := c;
end;
if r <> '' then
o := o + '-' + r;
Result := o;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(NumSeparator('1,2,3,5,7'));
ShowMessage(NumSeparator('1,2,3,5,7,10,11,12,13'));
ShowMessage(NumSeparator('1,2,3,4,5,7,13,70,71,72,73,80'));
end;
// Способ второй
// формат строки 1,2,3,5,7
function NumParser(numstr: string; rz: char = ','): string;
var
s: TStringList;
i: Integer;
ok: Boolean;
begin
s := TStringList.Create;
ExtractStrings([rz], [' '], PChar(numstr), s);
Result := '';
// Преобразование
ok := False;
for i := s.Count-2 downto 1 do
if ((s[i-1] = '-') or (StrToInt(s[i-1])+1 = StrToInt(s[i]))) and
((s[i+1] = '-') or (StrToInt(s[i+1])-1 = StrToInt(s[i]))) then
begin
s[i] := '-';
if ok then
s.Delete(i);
ok := True;
end
else
ok := False;
s.Delimiter := rz;
Result := StringReplace(s.DelimitedText, rz + '-' + rz, '-', [rfReplaceAll]);
s.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(NumParser('1,2,3,5,7'));
ShowMessage(NumParser('1,2,3,5,7,10,11,12,13'));
ShowMessage(NumParser('1,2,3,4,5,7,13,70,71,72,73,80'));
end;
|
Как подменить ресурсную строку в памяти во время работы программы?
// Подмена строки на примере русификации заголовка MessageDlg
uses
Consts;
const
_SMsgDlgWarning: PChar = 'Предупреждение';
_SMsgDlgError: PChar = 'Ошибка';
_SMsgDlgInformation: PChar = 'Информация';
_SMsgDlgConfirm: PChar = 'Подтверждение';
procedure HookResourceString(PResStr: PResStringRec; PNewStr: PChar);
var
LOldProtect: DWORD;
begin
VirtualProtect(PResStr, SizeOf(PResStr^), PAGE_EXECUTE_READWRITE, @LOldProtect);
PResStr^.Identifier := Integer(PNewStr);
VirtualProtect(PResStr, SizeOf(PResStr^), LOldProtect, @LOldProtect);
end;
procedure LocalizeDelphiDialogs;
begin
HookResourceString(@SMsgDlgWarning, _SMsgDlgWarning);
HookResourceString(@SMsgDlgError, _SMsgDlgError);
HookResourceString(@SMsgDlgInformation, _SMsgDlgInformation);
HookResourceString(@SMsgDlgConfirm, _SMsgDlgConfirm);
// или
// HookResourceString(@SMsgDlgWarning, PWideChar(WideString(_SMsgDlgWarning)));
// HookResourceString(@SMsgDlgError, PWideChar(WideString(_SMsgDlgError)));
// HookResourceString(@SMsgDlgInformation, PWideChar(WideString(_SMsgDlgInformation)));
// HookResourceString(@SMsgDlgConfirm, PWideChar(WideString(_SMsgDlgConfirm)));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LocalizeDelphiDialogs;
MessageDlg( '', mtWarning, [mbYes], 0 );
end;
|
Как определить длину строки в пикселах?
// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
s: PWideChar;
Size: TSize;
begin
s := 'My length in pixels is: ';
GetTextExtentPoint(Canvas.Handle, s, Length(s), Size);
ShowMessage(s + IntToStr(Size.cx));
// Также можно узнать и высоту текста
// ShowMessage(s + IntToStr(Size.cy));
end;
// Способ второй
procedure TForm1.Button2Click(Sender: TObject);
var
s: WideString;
w: Integer;
// h: Integer;
begin
s := 'My length in pixels is: ';
w := Canvas.TextWidth(s);
ShowMessage(s + IntToStr(w));
// Также можно узнать и высоту текста
// h := Canvas.TextHeight(s);
// ShowMessage(s + IntToStr(h));
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
