FAQ VCL
Операции над строками

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

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


Как получить идентификатор ресурсной строки во время работы программы?

resourcestring
  MyStr = 'lalala';

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage( IntToStr( PResStringRec( @MyStr ).Identifier ) );
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;

При использовании материала - ссылка на сайт обязательна