Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



После первого щелчка начать редактировать

Автор: Rick Rogers

Включите goAlwaysShowEditor в свойство TStringGrid Options.




Вставка и удаление строк в StringGrid

Автор: Dennis Passmore

...я не нашел никаких методов для вставки и удаления строк...

Поскольку свойство Cols[x] компонента TStringGrid реально является компонентом TStrings, все методы TStrings применимы также и к Cols[x].

Недавно в интернете я нашел реализацию расширенных функций TStringGrid:


 (*
 Создано:               Dennis Passmore
                        1929 Mango Tree Drive
                        Edgewater, Fl. 32141
                        CIS: 71640,2464
                        Март 1, 1996
 Данный код свободен в использовании при одном условии:
 в исходном коде должна присутствовать указанная выше кредитка
 со ссылкой на автора.
 
 Примечание по использованию кода:
 Всякий раз при удалении Row (строки) или Column (колонки)
 проверяйте наличие и удаляйте любые объекты, которые могли
 быть назначены любой ячейке в строке или колонке, которые вы
 собираетесь удалять, поскольку данный код не может знать ни
 размера, ни типа ассигнованных ими объектов.
 
 *)
 
 unit GridFunc;
 
 interface
 
 uses
   Sysutils, WinProcs, Grids;
 
 procedure InsertRow(Sender: TStringGrid; ToIndex: Longint);
 procedure DeleteRow(Sender: TStringGrid; FromIndex: Longint);
 procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
 procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);
 
 implementation
 
 type
   TCSGrid = class(TStringGrid)
   private
   public
     procedure MoveRow(FromIndex, ToIndex: Longint);
     procedure MoveColumn(FromIndex, ToIndex: Longint);
   end;
 
 procedure TCSGrid.MoveRow(FromIndex, ToIndex: Longint);
 begin
   RowMoved(FromIndex, ToIndex); { Защищенный метод TStringGrid }
 end;
 
 procedure TCSGrid.MoveColumn(FromIndex, ToIndex: Longint);
 begin
   ColumnMoved(FromIndex, ToIndex); { Защищенный метод TStringGrid }
 end;
 
 procedure InsertRow(Sender: TStringGrid; ToIndex: Longint);
 var
   xx, yy: Integer;
 begin
   if ToIndex >= 0 then
     with TCSGrid(Sender) do
       if (ToIndex <= RowCount) then
       begin
         RowCount := RowCount + 1;
         xx := RowCount - 1;
         for yy := 0 to ColCount - 1 do
         begin
           Cells[yy, xx] := ' ';
           ObJects[yy, xx] := nil;
         end;
         if ToIndex < RowCount - 1 then
           MoveRow(RowCount - 1, ToIndex);
       end
       else
         MessageBeep(0)
     else
       MessageBeep(0);
 end;
 
 procedure DeleteRow(Sender: TStringGrid; FromIndex: Longint);
 begin
   if FromIndex > l;
   = 0 then
     with TCSGrid(Sender) do
       if (RowCount > 0) and (FromIndex < RowCount) then
       begin
         if (FromIndex < RowCount - 1) then
           MoveRow(FromIndex, RowCount - 1);
         Rows[RowCount - 1].Clear;
         RowCount := RowCount - 1;
       end
       else
         MessageBeep(0)
     else
       MessageBeep(0);
 end;
 
 procedure InsertColumn(Sender: TStringGrid; ToIndex: Longint);
 var
   xx, yy: Integer;
 begin
   if ToIndex >= 0 then
     with TCSGrid(Sender) do
       if (ToIndex <= ColCount) then
       begin
         ColCount := ColCount + 1;
         xx := ColCount - 1;
         Cols[xx].BeginUpdate;
         for yy := 0 to RowCount - 1 do
         begin
           Cells[xx, yy] := ' ';
           ObJects[xx, yy] := nil;
         end;
         Cols[xx].EndUpdate;
         if ToIndex < ColCount - 1 then
           MoveColumn(ColCount - 1, ToIndex);
       end
       else
         MessageBeep(0)
     else
       MessageBeep(0);
 end;
 
 procedure DeleteColumn(Sender: TStringGrid; FromIndex: Longint);
 begin
   if FromIndex >= 0 then
     with TCSGrid(Sender) do
       if (ColCount > 0) and (FromIndex < ColCount) then
       begin
         if (FromIndex < ColCount - 1) then
           MoveColumn(FromIndex, ColCount - 1);
         Cols[ColCount - 1].Clear;
         ColCount := ColCount - 1;
       end
       else
         MessageBeep(0)
     else
       MessageBeep(0);
 end;
 
 end.
 




Сортировка StringGrid с целыми значения


  program H;
 
  uses WinCrt, SysUtils;
 
    const
      min = 10;
      max = 13;
      maxHeap = 1 shl max;
 
    type
      heap = array [1..maxHeap] of integer;
      heapBase = ^heap;
 
    var
      currentSize, heapSize: integer;
      A: heapBase;
 
    procedure SwapInts (var a, b: integer);
    var
      t: integer;
    begin
      t := a;
      a := b;
      b := t
    end;
 
    procedure InitHeap (size: integer);
    var
      i: integer;
    begin
      heapSize := size;
      currentSize := size;
      Randomize;
      for i := 1 to size do
        A^[i] := Random(size) + 1;
    end;
 
    procedure Heapify (i: integer);
    var
      left, right, largest: integer;
    begin
      largest := i;
      left := 2 * i;
      right := left + 1;
      if left <= heapSize then
        if A^[left] > A^[i] then
          largest := left;
      if right <= heapSize then
        if A^[right] > A^[largest] then
          largest := right;
      if largest <> i then
        begin
          SwapInts (A^[largest], A^[i]);
          Heapify (largest)
        end
    end;
 
    procedure BuildHeap;
    var
      i: integer;
    begin
      for i := heapSize div 2 downto 1 do
        Heapify (i)
    end;
 
    procedure HeapSort;
    var
      i: integer;
    begin
      BuildHeap;
      for i := currentSize downto 2 do
        begin
          SwapInts (A^[i], A^[1]);
          dec (heapSize);
          Heapify (1)
        end
    end;
 
  type
    TAvgTimes = array [min..max] of TDateTime;
  var
    sTime, eTime, tTime: TDateTime;
    i, idx, size: integer;
    avgTimes: TAvgTimes;
 
 
  begin
    tTime := 0;
    i := min;
    size := 1 shl min;
    new (A);
    while i <= max do
      begin
        for idx := 1 to 10 do
          begin
            InitHeap (size);
            sTime := Time;
            HeapSort;
            eTime := Time;
            tTime := tTime + (eTime - sTime)
          end;
        avgTimes[i] := tTime / 10.0;
        inc (i);
        size := size shl 1;
      end;
  end.
 




StringGrid как DBGrid

Ну это может выглядеть приблизительно так (возможно нужна некоторая доработка, написал от руки, не проверяя):


 table.first;
 row := 0;
 grid.rowcount := table.recordCount;
 while not table.eof do
 begin
   for i := 0 to table.fieldCount-1 do
     grid.cells[i,row] := table.fields[i].asString;
   inc (row);
   table.next;
 end;
 

У меня тоже имееются свои причины использования TStringGrid. Вот мой код, который загружает данные из отфильтрованной таблицы. Он не очень изящен, т.к. реально является лишь черновиком. У меня это работает, а большего мне и не нужно. Работает очень быстро, даже в случае сотни загруженных колонок. Есть много ссылок на внешние переменные. Надеюсь что они не слишком заумные.


 procedure TformLookupDB.FillCells;
 var
   Row, i: INTEGER;
   w: INTEGER;
   grid: TStringGrid;
 begin
   doGrid.RowCount := 0;
   if not ASSIGNED(fDB) then
     EXIT;
   Row := 0;
   for i := LOW(fColWidths) to HIGH(fColWidths) do
     fColWidths[i] := 100
     // Данный временный объект-сетка используется для предохранения от огромного
     // количества подразумеваемых событий Application.ProcessMessages,
     // инициируемых базой данных, и вызывающих противное моргание объекта
     // doGrid. Итак, мы загружаем данные в объект-сетку
     // и затем копируем их в стобцы, начиная с верхней части.
 
     grid := TStringGrid.Create(Self);
   grid.Visible := FALSE;
   with fDB do
   try
 
     grid.ColCount := fFields.Count;
     DisableControls;
     // Фильтр был установлен с помощью свойства Self.Filter
     First;
     while not EOF do
     try
       grid.RowCount := Row + 1;
       for i := 0 to grid.ColCount - 1 do
       begin
         grid.Cells[i, Row] :=
           FieldByName(fFields.Strings[i]).AsString
           w := doGrid.Canvas.TEXTWIDTH(grid.Cells[i,
           Row]);
         if fColWidths[i] < w then
           fColWidths[i] := w;
       end
         INC(Row);
     finally
       Next;
     end
   finally
     doGrid.RowCount := grid.RowCount;
     doGrid.ColCount := grid.ColCount;
     for i := 0 to grid.ColCount - 1 do
     begin
       doGrid.Cols[i] := grid.Cols[i];
       doGrid.ColWidths[i] := fColWidths[i] + 4
     end
       grid.Free;
     EnableControls
   end
 end;
 




Ограничение длины поля TStringGrid

Вероятно, это не очень эффективное решение, но оно будет работать: поместите следующий код в обработчик события onKeyPress:


 if key <> #8 then
 begin {допускаем backspace/Del}
   len := length(grid.cells[grid.col, grid.row]);
   if len >= ваша желаемая максимальная длина then
   begin
     messageBeep (0);
     key := #0;
   end;
 end;
 

После получения вышеуказанным кодом строки s проверяется условие и,


 if Length(s) > maxlengthoffield then exit;
 




Перетащить колонки и строки в StringGrid

В процессе социологического опроса, проведенного в корпорации "Мелкий-Мягкий", выяснено, что: 99% сотрудников корпорации любят все большое и негибкое.


 {
   The user can move rows and columns of a StringGrid with the mouse.
   Can it also be done by code?
   In the help for TCustomGrid you can see the methods MoveColumn and MoveRow,
   but they are hidden in TStringGrid.
   We can make them accessible again by subclassing TStringGrid and
   declaring these methods as public:
 }
 
 type
   TStringGridHack = class(TStringGrid)
   public
     procedure MoveColumn(FromIndex, ToIndex: Longint);
     procedure MoveRow(FromIndex, ToIndex: Longint);
   end;
 
 {
   The implementation of these methods simply consists of invoking the
   corresponding method of the ancestor:
 }
 
 procedure TStringGridHack.MoveColumn(FromIndex, ToIndex: Integer);
 begin
   inherited;
 end;
 
 procedure TStringGridHack.MoveRow(FromIndex, ToIndex: Integer);
 begin
   inherited;
 end;
 
 
 // Example, Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   TStringGridHack(StringGrid1).MoveColumn(1, 3);
 end;
 




Множественный выбор в TStringGrid

То же самое я проделывал и с DBGrid. (Пока не реализован Shift-MouseDown, только Ctrl-MouseDown).

Для TStringGrid вам нужно выполнить следующие шаги:

  1. Заполните сетку, связывая Objects[0, ARow] с некоторым логическим объектом типа:

  2.  TBooleanObject = class(TObject)
     public
       Flag: Boolean;
     end;
     

  3. В обработчике события OnMouseDown и OnKeyDown измените флаг, как того требует ситуация.
  4. В обработчике события OnDrawCell отрисуйте строку согласно флагу Objects[0,ARow].



Правое выравнивание ячеек TStringGrid

Я полагаю, это лучший метод:


 procedure TForm1.GridSumaDrawCell(Sender: TObject; ACol, ARow: Longint;
   ARect: TRect; State: TGridDrawState);
 var
   dx: integer;
 begin
   with (Sender as TStringGrid).Canvas do
   begin
     Font := GridSuma.Font;
     Pen.Color := clBlack;
     if (ACol = 0) or (ARow = 0) then
     begin
       { Рисуем заголовок }
       Brush.Color := clBtnFace;
       FillRect(ARect);
       TextOut(ARect.Left, ARect.Top, GridSuma.Cells[ACol, ARow])
     end
     else
     begin
       { Рисуем ячейку с правым выравниванием }
       Brush.Color := clWhite;
       FillRect(ARect);
       dx := TextWidth(GridSuma.Cells[ACol, ARow]) + 2;
       TextOut(ARect.Right - dx, ARect.Top, GridSuma.Cells[ACol, ARow])
     end
   end
 end;
 




Сменить цвет выделения в StringGrid


 procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
   Rect: TRect; State: TGridDrawState);
 const
   SelectedColor = Clblue;
 begin
   if (state = [gdSelected]) then
     with TStringGrid(Sender), Canvas do
     begin
       Brush.Color := SelectedColor;
       FillRect(Rect);
       TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Cells[aCol, aRow]);
     end;
 end;
 




Фокус ячейки TStringGrid

Автор: Simon


 procedure SetGridFocus(SGrid: TStringGrid; r, c: integer);
 var
   SRect: TGridRect;
 begin
   with SGrid do
   begin
     SetFocus; {Передаем фокус сетке}
     Row := r; {Устанавливаем Row/Col}
     Col := c;
     SRect.Top := r; {Определяем выбранную область}
     SRect.Left := c;
     SRect.Bottom := r;
     SRect.Right := c;
     Selection := SRect; {Устанавливаем выбор}
   end;
 end;
 

Для вызова процедуры:


 SetGridFocus(StringGrid1, 10, 2);
 

Это всегда срабатывает в случае, если никакая ячейка не выбрана или фокус имеет другой элемент управления.

Надеюсь что помог вам.




Текст в ячейке StringGrid не помещается и переносится на следующую ячейку

Сначала нужно обработать событие OnDrawCell компонента TStringGrid:


 procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
 Rect: TRect; State: TGridDrawState);
 var
   i, x, y: Integer;
 begin
   if gdFixed in State then
     Exit;
   if ARow > 1 then
     Exit;
   {Draw row 1 with text from cell 1,1 spanning all cells in the row}
   with sender as TStringGrid do
   begin
     {Extend rect to include grid line on right, if not last cell in row}
     if aCol < Pred(ColCount) then
       Rect.Right := Rect.Right + GridlineWidth;
     {Figure out where the text of the first cell would start
     relative to the current cells rect}
     y := Rect.Top + 2;
     x := Rect.Left + 2;
     for i:= 1 to aCol - 1 do
       x := x - ColWidths[i] - GridlineWidth;
     {Paint cell pale yellow}
     Canvas.Brush.Color := $7FFFFF;
     Canvas.Brush.Style := bsSolid;
     Canvas.FillRect( Rect );
     {Paint text of cell 1,1 clipped to current cell}
     Canvas.TextRect( Rect, x, y, Cells[1, 1] );
   end;
 end;
 

По созданию окна изобразим следующее


 procedure TForm1.FormCreate(Sender: TObject);
 var
   i, k: Integer;
 begin
   with StringGrid1 do
   begin
     cells[1, 1] := 'A rather long line which will span cells';
     for i:= 1 to colcount-1 do
       for k:= 2 to rowcount -1 do
         cells[i,k] := Format( 'Cell[%d, %d]', [i, k]);
   end;
 end;
 




Сохранить StringGrid в Excel файле


 function SaveAsExcelFile(stringGrid: TstringGrid; FileName: string): Boolean;
 const
   xlWBATWorksheet = -4167;
 var
   Row, Col: Integer;
   GridPrevFile: string;
   XLApp, Sheet: OLEVariant;
 begin
   Result := False;
   XLApp  := CreateOleObject('Excel.Application');
   try
     XLApp.Visible := False;
     XLApp.Workbooks.Add(xlWBatWorkSheet);
     Sheet      := XLApp.Workbooks[1].WorkSheets[1];
     Sheet.Name := 'My Sheet Name';
     for col := 0 to stringGrid.ColCount - 1 do
       for row := 0 to stringGrid.RowCount - 1 do
         Sheet.Cells[row + 1, col + 1] := stringGrid.Cells[col, row];
     try
       XLApp.Workbooks[1].SaveAs(FileName);
       Result := True;
     except
       // Error ? 
     end;
   finally
     if not VarIsEmpty(XLApp) then
     begin
       XLApp.DisplayAlerts := False;
       XLApp.Quit;
       XLAPP := Unassigned;
       Sheet := Unassigned;
     end;
   end;
 end;
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if SaveAsExcelFile(stringGrid1, 'c:\MyExcelFile.xls') then
     ShowMessage('stringGrid saved!');
 end;
 {*************************************************}
 // Reiner Schlay http://www.assu-assist.nl/ 
 
 function RefToCell(ARow, ACol: Integer): string;
 begin
   Result := Chr(Ord('A') + ACol - 1) + i2s(ARow);
 end;
 
 procedure StringGridToExcel(AGrid: TstringGrid);
 var
   i, j: Integer;
   Excel: Application_;
   Book: Workbook;
   Sheet: _WorkSheet;
   Data: OLEVariant;
 begin
   Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount],
     varVariant);
   for i := 0 to AGrid.ColCount - 1 do
     for j := 0 to AGrid.RowCount - 1 do
       Data[j + 1, i + 1] := AGrid.Cells[i, j];
   Excel := CoApplication_.Create;
   Book  := Excel.WorkBooks.Add(EmptyParam, 0);
   Sheet := Excel.Sheets.Add(EmptyParam, EmptyParam, 1,
     xlWorksheet, 0) as _WorkSheet;
   Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount,
     AGrid.ColCount)].Value := Data;
   Excel.Visible[0] := True;
   Excel.UserControl := True;
 end;
 




StringGrid без выделенной ячейки

Автор: Jeff Fisher

Я пытаюсь показать StringGrid без выделенной ячейки. Первая нефиксированная ячейка всегда имеет состояние "инвертированного" цвета. Я не хочу позволить пользователю редактировать сетку, но эта выделенная ячейка производит впечатление того, что сетка имеет возможность редактирования...

Вам необходимо создать обработчик события OnDrawCell. Это легче чем вы думаете. Вот образец кода, который сделает вас счастливым:


 procedure TForm.sgrDrawCells(Sender: TObject; Col, Row: Longint; Rect: TRect;
   State: TGridDrawState);
 var
   ACol: longint absolute Col;
   ARow: longint absolute Row;
   Buf: array[byte] of char;
 begin
   if State = gdFixed then
     Exit;
 
   with sgrGrid do
   begin
     Canvas.Font := Font;
     Canvas.Font.Color := clWindowText;
     Canvas.Brush.Color := clWindow;
 
     Canvas.FillRect(Rect);
     StrPCopy(Buf, Cells[ACol, ARow]);
     DrawText(Canvas.Handle, Buf, -1, Rect,
       DT_SINGLELINE or DT_VCENTER or DT_NOCLIP or DT_LEFT);
   end;
 end;
 




Манипуляция словами в TStringGrid


 procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
 var
   s: string;
   c: Byte;
 begin
   with StringGrid1 do
     s := Cells[Col, Row];
   if Length(s) = 0 then
   begin
     if Key in ['a'..'z'] then
     begin
       c := Ord(Key) - 32;
       Key := Chr(c);
     end;
     exit;
   end;
   if s[Length(s)] = ' ' then
     if Key in ['a'..'z'] then
     begin
       c := Ord(Key) - 32;
       Key := Chr(c);
     end;
 end;
 

В обработчике события onKeyPress сделайте следующее:


 if length(field.text) = 0 then
   key := upCase (key);
 




Копирование StringList в Memo-поле и обратно

Нижеприведенный код иллюстрирует копирование TStringList в TMemoField и обратно:


 procedure TForm1.ButtonClick(Sender: TObject);
 var
   MemFld: TMemoField;
 begin
   MemFld := Table1.FieldByName(DBMemo1.DataField) as TMemoField;
   if Sender = Button1 then
     MemFld.Assign(StrList)
   else
   if Sender = Button2 then
     StrLst.Assign(MemFld);
 end;
 

Примечание: Table1 должна находиться в режиме редактирования перед нажатием кнопки Button1.




Обновление картинки в ячейке StringGrid

Автор: SottNick

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


 StringGrid1.Cells[i,j]:='';
 

или


 StringGrid1.Cells[i,j]:=StringGrid1.Cells[i,j];
 

если там что-то хранится




String и PChar

Автор: Den is Com

В 32-битном Дельфи String и PChar это одно и тоже. Старый String из Дельфи 1 - это shortstring. Используйте прямое преобразование PChar(String_variable) - это сохранит память при использовании функций WIN32.




Как преобразовать String в Binary и наоборот

Автор: Rem


 function BinStrToByte(a_sBinStr: string): byte;
 var
  i: integer;
 begin
  Result := 0;
  for i := 1 to length(a_sBinStr) do
    Result := (Result shl 1) or byte(a_sBinStr[i] = '1');
 end;
 
 function ByteToBinStr(a_bByte: byte): string;
 var
  i: integer;
 begin
  SetLength(Result, 8);
  for i := 8 downto 1 do
  begin
    Result[i] := chr($30 + (a_bByte and 1));
    a_bByte := a_bByte shr 1;
  end;
 end;
 
 // Примечание: вторая функция использует тот факт,
 // что в таблице ANSI коды '0' = $30 и '1' = $31
 




Создание формы на основе строки

Обзор

В данном документе рассказывается о том, как в Delрhi можно создать экземпляр формы на основе строки, содержащей имя типа. Код примера прилагается.

На кого расчитан данный документ?

На любого программиста, имеющего начальные знания для работы с Delphi. Имеет отношение к любой версии Delphi.

Создание формы на основе строки

Чтобы можно было создать экземпляр формы на основе строки, содержащей имя типа, вы должны в первую очередь зарегистрировать данный тип в Delphi. Это выполняется функцией "RegisterClass". RegisterClass описан следующим образом:


 procedure RegisterClass(AClass: TPersistentClass);
 

AClass - класс TPersistent. Другими словами, класс, который вы хотите регистрировать, в какой-то точке должен наследоваться от TPersistent. Поскольку все элементы управления Delphi, включая формы, соблюдают это требование, то проблем быть не должно. Но такой способ не пройдет, если регистрируемые классы наследуются непосредственно от TObject.

После регистрации класса, вы можете найти указатель на тип, передавая строку в FindClass. Функция возвратит ссылку на класс, которую можно использовать для создания формы. Небольшой поясняющий пример:


 procedure TForm1.Button2Click(Sender: TObject);
 var
 b : TForm;
 f : TFormClass;
 begin
 f := TFormClass(findClass('Tform2'));
 b := f.create(self);
 b.show;
 end;
 

Данный код создаст тип TForm2, который мы зарегистрировали с помощью RegisterClass.

Демонстрационный проект

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

В первой форме разместите поле редактирования и кнопку. Удалите все формы, кроме главной, из списка AutoCreate. Наконец, скопируйте приведенный ниже код в unit1, он позволит вам создавать форму по имени типа класса, введенному в поле редактирования.


 unit Unit1;
 
 interface
 
 uses
   Unit2, Unit3, Unit4, Unit5, Windows, Messages,
   SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Edit1: TEdit;
     Button1: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   RegisterClass(Tform2);
   RegisterClass(Tform3);
   RegisterClass(Tform4);
   RegisterClass(Tform5);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   f: Tformclass;
 begin
   f := tformclass(findClass(edit1.text));
   with f.create(self) do
     show;
 end;
 




Строковая нумерация

Автор: Peter Below

Просто объявите перечислимый тип, информацию о котором можно получить во время выполнения программы, и создайте класс, который использует данный тип в published-свойстве.

ClassInfo - метод класса, поэтому вы можете его использовать вместо экземпляра объекта. Но прежде вам необходимо заиметь этот класс, иначе никакого RTTI...


 {$Z+}
 type
   TMyEnum = (one, two, three);
   TEnumClass = class(TComponent)
   private
     FEnum: TMYEnum;
   published
     property Enum: TMyEnum read FEnum;
   end;
 
 procedure TForm1.BtnTestClick(Sender: TObject);
 var
   pOneName: PString;
   PropInfo: PPropInfo;
 begin
   PropInfo := GetPropInfo(TEnumClass.ClassInfo, 'ENUM');
   pOneName := GetEnumName(PropInfo^.PropType, Ord(One));
   if pOneName <> nil then
     ShowMessage(pOneName^)
   else
     ShowMessage('Nil!');
 end;
 

Черная магия <G>!




Чем отличается тип String в Delphi7 от аналогичного в Delphi 1?

Автор: Nomadic

B D2 и выше на самом деле используется тип LongString вместо String, а стаpый тип тепеpь обзывается ShortString (о чем, кстати, написано в help). Из того же help можно узнать, что указатель LongString указывает на nullterminated string и потому возможно обычное пpиведение типа LongString к PChar (о чем я и написал), котоpое сводится пpосто к смене вывески. Там же можно узнать, что длина стpоки хpанится в dword пеpед указателем. Есть также намек на то, что пpи пpисваивании дpугой стpоке инфоpмация не копиpуется, а увеличивается только счетчик ссылок. Более подpобную инфоpмацию можно почеpпнуть из system.pas:


 type
 StrRec = record
 allocSiz: Longint;
 refCnt: Longint;
 length: Longint;
 end;
 

От себя добавлю:

Сама пеpеменная LongString указывает на байт, непосpедственно следующий за этой пpоцедуpой, там же находится собственно значение стpоки. Значение '' (пустая стpока) пpедставляется как указатель nil, кстати, поэтому сpавнение str='' это быстpая опеpация.

Тепеpь подpобнее о счетчике ссылок. Я уже говоpил, что пpи пpисваивании копиpования не пpоисходит, а только увеличивается счетчик. Когда он уменьшается? Hу, очевидно, когда в pезультате опеpации значение стpоки меняется, то для стаpого значения счетчик уменьшается. Это понятно. Более непонятно, когда освобождаются значения, на котоpые ссылаются поля некого класса. Это пpоисходит в System. TObject.FreeInstance пpи вызове _FinalizeRecord, а инфоpмация беpется из vtInitTable (кстати, здесь же очищаются Variant). Ещё более непонятно, когда освобождаются пеpеменые String, котоpые описаны как локальные в пpоцедуpах/функциях/методах. Здесь pаботает компилятоp, котоpые вставляет эти неявные опеpации в код этой функции.

Тепеpь о типе PString. Hа самом деле пеpеменные этого типа указывают на такие же значения, как и LongString, но для пеpеменных этого типа для всех опеpаций по созданию/копиpованию/удалению нужно помнить об этих самых счетчиках ссылок. Иногда без этого типа не обойтись. Вот опеpации для этого типа (sysutils.pas):


 { String handling routines }
 { NewStr allocates a string on the heap.
 
 NewStr is provided for backwards compatibility only. }
 function NewStr(const S: string): PString;
 
 { DisposeStr disposes a string pointer that was
 
 previously allocated using NewStr.
 DisposeStr is provided for backwards compatibility only. }
 procedure DisposeStr(P: PString);
 
 { AssignStr assigns a new dynamically allocated
 
 string to the given string pointer.
 AssignStr is provided for backwards compatibility only. }
 procedure AssignStr(var P: PString; const S: string);
 

Можно отметить, что явно задать использование long strings можно декларацией


 var
 sMyLongString: AnsiString;    // long dinamically allocated string
 sMyWideString: WideString;    // wide string (UNICODE)
 sMyShortString1: ShortString; // old-style string
 sMyShortString2: String[255]; // old-style string, no more than 255 chars
 

Хотелось бы также предупредить наиболее частные ошибки при использовании длинных строк:

  • Если Вы передаёте указатель PChar на буфер, взятый от длинной строки, в функцию, которая может изменить содержание буфера, то убедитесь, что на этот буфер указывает только одна строка. Это верно в случаях сложения строк, вызова UniqueString или SetLength и некоторых других;
  • Если Вы используете длинные строки как аргументы или результаты для функций, располагающихся в DLL, то в DLL надо использовать модуль ShareMem;
  • Не используйте длинные строки как члены структур типа record. Используйте там короткие строки или array[0..n] of char. Также нельзя использовать в структурах типа record динамические массивы. Данные ограничения отсутствуют для классов.



Строка как объект StringList

Автор: Robert Wittig

Вы можете создать простой объект, инкапсулирующий строку:


 Type
   TStrObj = Class ( tObject )
     Data : String;
   End;
 

Затем вы могли бы делать следующее:


 With ListBox1 Do
 Begin
   AddObject(Table1.Fields[0].AsString, TStrObject.Create );
   {
   Объект добавляется в конец списка, поэтому для его
   чтения установите индекс равным Count-1
   }
   TStrObj(Objects[Count-1]).Data := Table1.Fields[1].AsString);
 End;
 

Теперь ваша обязанность заключается в том, что при удалении объекта из списка, вам необходимо также удалять связанный с ним объект:


 { для удаления элемента с Index I}
 With ListBox1 Do
 Begin
   Objects[I].Free;
   Delete(I);
 End;
 




Отобразить строку на определённую структуру

Новый фильм от создателей Матрицы : Romeo Must Die
Генеральный спонсор : Microsoft


 type
   TEmployee = record
     cNo: array [0..3] of Char;
     cName: array [0..7] of Char;
   end;
   PEmployee = ^TEmployee;
 
 procedure ParseData;
 const
   sData = '0001Mosquito';
 var
   sNo, sName: string;
 begin
   with PEmployee(Pointer((@sData)^))^ do
   begin
     sNo   := cNo;      // sNo = '0001' 
     sName := cName;    // sName = 'Mosquito' 
   end
 end;
 




Из строки в массив и наоборот

Программист с женой отправились в супермаркет. Сделав все необходимые закупки, они вышли на улицу, и жена сказала: - Стой здесь и смотри в оба за этими десятью сумками, пока я схожу и разыщу такси. Когда жена вернулась, то увидела обалдевшего мужа, переставляющего сумки с места на место. Программист: - Ты сказала, что здесь десять сумок, а я насчитал только 9! Жена: - Hо их было десять! Программист: - Hет, давай вместе считать: 0, 1, 2, 3......


 function StrToArrays(str, r: string; out Temp: TStrings): Boolean;
 var
   j: integer;
 begin
   if temp <> nil then
   begin
     temp.Clear;
     while str <> '' do
     begin
       j := Pos(r,str);
       if j=0 then
         j := Length(str) + 1;
       temp.Add(Copy(Str,1,j-1));
       Delete(Str,1,j+length(r)-1);
     end;
     Result:=True;
   end
   else
     Result:=False;
 end;
 


 function ArrayToStr(str: TStrings; r: string): string;
 var
   i: integer;
 begin
   Result:='';
   if str = nil then
     Exit;
   for i := 0 to Str.Count-1 do
     Result := Result + Str.Strings[i] + r;
 end;
 




Как сохранить и получить строку из INI-файла

Ниже показаны две функции, которые помещают и получают значение переменной (StringName) в ini-секции (IniSection) ini-файла (TheIniFile)}


 function IniGetStringValue(
   TheIniFile: string;
   IniSection: string;
   StringName: string;
   DefaultString: string): string;
 var
   TheIni: TIniFile;
 begin
   TheIni := TIniFile.Create(Self);
   try
     Result :=
       TheIni.ReadString(
       IniSection,
       StringName,
       DefaultString);
     if Result = '' then
       Result := DefaultString;
   finally
     TheIni.Free;
   end;
 end;
 
 function IniSetStringValue(
   TheIniFile: string;
   IniSection: string;
   StringName: string;
   StringValue: string): Boolean;
 var
   TheIni: TIniFile;
 begin
   TheIni := TIniFile.Create(Self);
   try
     try
       TheIni.WriteString(
         IniSection,
         StringName,
         StringValue);
       Result := True;
     except
       Result := False;
     end;
   finally
     TheIni.Free;
   end;
 end;
 




Подсчитать количество слов в строке


 function Seps(As_Arg: Char): Boolean;
 begin
   Seps := As_Arg in
     [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\'];
 end;
 
 function WordCount(CText: string): Longint;
 var
   Ix: Word;
   Work_Count: Longint;
 begin
   Work_Count := 0;
   Ix         := 1;
   while Ix <= Length(CText) do
   begin
     while (Ix <= Length(CText)) and (Seps(CText[Ix])) do
       Inc(Ix);
     if Ix <= Length(CText) then
     begin
       Inc(Work_Count);
 
       while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do
         Inc(Ix);
     end;
   end;
   Word_Count := Work_Count;
 end;
 
 {
   To count the number opf words in a TMemo Component,
   call: WordCount(Memo1.Text)
 }
 




Паскалевский эквивалент StrTok

Автор: Mike Scott


 function NextToken( P : PChar ; Divider : PChar ) : PChar ;
 const
   next : PChar = nil ;
 begin
   if P = nil then
     P := next ;
   if P <> nil then
   begin
     next := StrPos( P, Divider ) ;
     if next <> nil then
     begin
       next^ := #0 ;
       next := @next[ StrLen( Divider ) ] ;
     end ;
   end ;
   NextToken := P ;
 end ;
 




StrTok для Delphi

Автор: Ralph Friedman

Я передалал это для работы в Delphi 2.0, код приведен ниже (эта функция первоначально была написана John Cooper 76356,3601 и модифицирована мной для адаптации под Delphi 2.0).

...вот этот код:


 function StrTok(Phrase: Pchar; Delimeter: PChar): Pchar;
 const
   tokenPtr: PChar = nil;
   workPtr: PChar = nil;
 var
   delimPtr: Pchar;
 begin
   if (Phrase <> nil) then
     workPtr := Phrase
   else
     workPtr := tokenPtr;
 
   if workPtr = nil then
   begin
     Result := nil;
     Exit;
   end;
 
   delimPtr := StrPos(workPtr, Delimeter);
 
   if (delimPtr <> nil) then
   begin
     delimPtr^ := Chr(0);
     tokenPtr := delimPtr + 1
   end
   else
     tokenPtr := nil;
 
   Result := workPtr;
 end;
 




Преобразование String в PChar


 function strtoPchar(s:string):Pchar;
 begin
   S := S+#0;
   result:=StrPCopy(@S[1], S) ;
 end;
 

или


 pch:=PChar(str);
 


 
str:=String(pch);




Расщепить строку в слова и обратно


 unit StrFuncs;
 
 interface
 
 uses SysUtils, Classes;
 
 function StrToArrays(str, r: string; out temp: TStrings): Boolean;
 function ArrayToStr(str: TStrings; r: string): string;
 
 implementation
 
 
 function StrToArrays(str, r: string; out temp: TStrings): Boolean;
 var
   j: Integer;
 begin
   if temp <> nil then
   begin
     temp.Clear;
     while str <> '' do
     begin
       j := Pos(r, str);
       if j = 0 then j := Length(str) + 1;
       temp.Add(Copy(Str, 1, j - 1));
       Delete(Str, 1, j + Length(r) - 1);
     end;
     Result := True;
     else
       Result := False;
   end;
 end;
 
 
 function ArrayToStr(str: TStrings; r: string): string;
 var
   i: Integer;
 begin
   Result := '';
   for i := 0 to Str.Count - 1 do
   begin
     Result := Result + Str.Strings[i] + r;
   end;
 end;
 end.
 




Итерация подкаталогов

Комп, как модель матриархата: на одной мамке можно завести папок сколько влезет.


 procedure TFormList.RecurseDir(PathInicial: string);
 var
   SearchRec: TSearchRec;
   Result: integer;
   tmpName: string;
 begin
   DirectoryListBox1.Directory := PathInicial;
   Result := FindFirst(PathInicial + '\*.*', faAnyFile, SearchRec);
   while Result = 0 do
   begin
     if ExtOk(SearchRec.Name) then
       { если каталог... }
       if SearchRec.Attr and faDirectory > 0 then
         { рекурсивно обрабатываем... }
         RecurseDir(PathInicial + '\' + SearchRec.Name)
       else
       begin
         tmpName := PathInicial + '\' + SearchRec.Name;
         tmpName := Copy(tmpName,
           Pos(PathOrigen, tmpName) + Length(PathOrigen),
           Length(tmpName) - Length(PathOrigen));
         ListBox1.Items.Add(LowerCase(tmpName));
       end;
     Application.ProcessMessages;
     Result := FindNext(SearchRec);
   end;
   DirectoryListBox1.Directory := PathInicial;
 end;
 




Подстановка в TEdit


Последние новости от Microsoft: Билл Гейтс привезет 10 октября в Москву последнюю разработку своей компании - партию картриджей для Dendy и Super Nintendo с новой версией операционной системы Windows и пакета MSOffice на русском языке, и лично будет продавать их на Митинском радиорынке (место G9) под усиленной охраной ОМОН.


 var
   words: TStringList;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   words := TStringList.Create;
   words.Sorted := true;
   words.Add('one');
   words.Add('two');
   words.Add('four');
   words.Add('five');
   words.Add('six');
   words.Add('seven');
   words.Add('eight');
   words.Add('nine');
   words.Add('ten');
 end;
 
 procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word;
 Shift: TShiftState);
 const
   chars: set of char = ['A'..'Z', 'a'..'z', 'А'..'Я', 'а'..'я'];
 var
   w: string;
   i: integer;
   s: string;
   full: string;
   SelSt: integer;
 begin
   case Key of
     VK_RETURN, VK_TAB:
     begin
       Edit1.SelStart := Edit1.SelStart + Edit1.SelLength;
       Edit1.SelLength := 0;
       Exit;
     end;
     VK_DELETE, VK_BACK:
     begin
       Edit1.ClearSelection;
       Exit;
     end;
   end;
   s := Edit1.Text;
   SelSt := Edit1.SelStart;
   i := SelSt;
   if (length(s) > i) and (s[i+1] in chars) then
     Exit;
   w := '';
   while (i >= 1) and (s[i] in chars) do
   begin
     w := s[i] + w;
     dec(i);
   end;
   if length(w) <= 0 then
     Exit;
   words.Find(w, i);
   if (i >= 0) and (UpperCase(copy(words[i], 1,
   length(w))) = UpperCase(w)) then
   begin
     full := words[i];
     insert(copy(full, length(w) + 1, length(full)), s, SelSt + 1);
     Edit1.Text := s;
     Edit1.SelStart := SelSt;
     Edit1.SelLength := length(full) - length(w);
   end;
 end;
 




Переопределение оконной процедуры и метода для другой формы



 unit SubSecon;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
 type
   TForm2 = class(TForm)
     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form2: TForm2;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 begin
   Caption := Format ('Cursor in %d, %d', [X, Y]);
 end;
 
 end.


 unit SubMain;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     BtnShow: TButton;
     BtnProc: TButton;
     BtnMeth: TButton;
     procedure BtnShowClick(Sender: TObject);
     procedure BtnMethClick(Sender: TObject);
     procedure BtnProcClick(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     OldWndMeth, NewWndMeth: Pointer;
     SubControl: TWinControl;
   public
     procedure NewWinMethod (var Msg: TMessage);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 uses SubSecon;
 
 {$R *.DFM}
 
 var
   OldWndProc: Pointer = nil;
 
 function NewWinProc (Handle: THandle;
   Msg, wParam, lParam: LongInt): LongInt; stdcall;
 begin
   if Msg = wm_RButtonDown then
   begin
     Beep;
     SetWindowText (Handle,
       PChar (Format ('Right click in %d, %d', [
         LoWord (lParam), HiWord (lParam)])));
   end;
   // pass call to old window proc
   Result := CallWindowProc (OldWndProc, Handle,
     Msg, wParam, lParam);
 end;
 
 procedure TForm1.NewWinMethod (var Msg: TMessage);
 begin
   if Msg.Msg = wm_LButtonDown then
   begin
     Beep;
     SubControl.SetTextBuf (
       PChar (Format ('Left click in %d, %d', [
         LoWord (Msg.lParam), HiWord (Msg.lParam)])));
   end
   else
     Msg.Result := CallWindowProc (OldWndMeth,
       SubControl.Handle, Msg.Msg, Msg.WParam, Msg.LParam);
 end;
 
 procedure TForm1.BtnShowClick(Sender: TObject);
 begin
   Form2.Show;
 end;
 
 procedure TForm1.BtnProcClick(Sender: TObject);
 begin
   OldWndProc := Pointer (SetWindowLong
     (Form2.Handle, gwl_WndProc, LongInt (@NewWinProc)));
   BtnProc.Enabled := False;
   end;
 
 procedure TForm1.BtnMethClick(Sender: TObject);
 begin
   SubControl := Form2;
   NewWndMeth := MakeObjectInstance (NewWinMethod);
   OldWndMeth := Pointer (SetWindowLong (
     SubControl.Handle, gwl_WndProc, Longint (NewWndMeth)));
   BtnMeth.Enabled := False;
     end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   if Assigned (NewWndMeth) then
     FreeObjectInstance (NewWndMeth);
 end;
 
 end.

Загрузить исходный код проекта




Сумма прописью - Способ 1

Автор: Константин Егоров

Создавайте отдельный модуль, где будут расположена эта функция, и подключайте его в нужные проекты.

Здесь опубликовывается конечный вид модуля:


 unit FullSum;
 
 interface
 
 uses SysUtils;
 
 {
 Функция перевода суммы, записанной цифрами в сумму прописью :
 например, 23.12 -> двадцать три рубля 12 копеек.
 переводит до 999999999 руб. 99 коп.
 Функция не отслеживает, правильное ли значение получено в параметре Number
 (т.е. положительное и округленное с точностью до сотых) - эту проверку
 необходимо провести до вызова функции.
 }
 
 //----------------- Copyright (c) 1999 by Константин Егоров
 //----------------- mailto: egor@vladi.elektra.ru
 
 function SumNumToFull(Number: real): string;
 
 implementation
 
 function SumNumToFull(Number:real):string;
 var
   PartNum, TruncNum, NumTMP, D: integer;
   NumStr : string;
   i, R : byte;
   Flag11 : boolean;
 begin
   D:=1000000;
   R:=4;
   //выделяем рубли
   TruncNum:=Trunc(Number);
   if TruncNum<>0 then
     repeat
       PartNum:=TruncNum div D;
       Dec(R);
       D:=D div 1000;
     until
       PartNum<>0
   else
     R:=0;
 
   // перевод рублей
   for i:=R downto 1 do
   begin
     Flag11:=False;
     // выделение цифры сотен
     NumTMP:=PartNum div 100;
     case NumTMP of
       1: NumStr:=NumStr+'сто ';
       2: NumStr:=NumStr+'двести ';
       3: NumStr:=NumStr+'триста ';
       4: NumStr:=NumStr+'четыреста ';
       5: NumStr:=NumStr+'пятьсот ';
       6: NumStr:=NumStr+'шестьсот ';
       7: NumStr:=NumStr+'семьсот ';
       8: NumStr:=NumStr+'восемьсот ';
       9: NumStr:=NumStr+'девятьсот ';
     end;
     // выделение цифры десятков
     NumTMP:=(PartNum mod 100) div 10;
     case NumTMP of
       1:
       begin
         NumTMP:=PartNum mod 100;
         case NumTMP of
           10: NumStr:=NumStr+'десять ';
           11: NumStr:=NumStr+'одиннадцать ';
           12: NumStr:=NumStr+'двенадцать ';
           13: NumStr:=NumStr+'тринадцать ';
           14: NumStr:=NumStr+'четырнадцать ';
           15: NumStr:=NumStr+'пятнадцать ';
           16: NumStr:=NumStr+'шестнадцать ';
           17: NumStr:=NumStr+'семнадцать ';
           18: NumStr:=NumStr+'восемнадцать ';
           19: NumStr:=NumStr+'девятнадцать ';
         end;
         case i of
           3: NumStr:=NumStr+'миллионов ';
           2: NumStr:=NumStr+'тысяч ';
           1: NumStr:=NumStr+'рублей ';
         end;
         Flag11:=True;
       end;
       2: NumStr:=NumStr+'двадцать ';
       3: NumStr:=NumStr+'тридцать ';
       4: NumStr:=NumStr+'сорок ';
       5: NumStr:=NumStr+'пятьдесят ';
       6: NumStr:=NumStr+'шестьдесят ';
       7: NumStr:=NumStr+'семьдесят ';
       8: NumStr:=NumStr+'восемьдесят ';
       9: NumStr:=NumStr+'девяносто ';
     end;
     // выделение цифры единиц
     NumTMP:=PartNum mod 10;
     if not Flag11 then
     begin
       case NumTMP of
         1:
           if i=2 then
             NumStr:=NumStr+'одна '
           else
             NumStr:=NumStr+'один ';
         2:
           if i=2 then
             NumStr:=NumStr+'две '
           else
             NumStr:=NumStr+'два ';
         3: NumStr:=NumStr+'три ';
         4: NumStr:=NumStr+'четыре ';
         5: NumStr:=NumStr+'пять ';
         6: NumStr:=NumStr+'шесть ';
         7: NumStr:=NumStr+'семь ';
         8: NumStr:=NumStr+'восемь ';
         9: NumStr:=NumStr+'девять ';
       end;
       case i of
         3:
           case NumTMP of
             1: NumStr:=NumStr+'миллион ';
             2,3,4: NumStr:=NumStr+'миллиона ';
             else
               NumStr:=NumStr+'миллионов ';
           end;
         2:
           case NumTMP of
             1 : NumStr:=NumStr+'тысяча ';
             2,3,4: NumStr:=NumStr+'тысячи ';
             else
               if PartNum<>0 then
                 NumStr:=NumStr+'тысяч ';
           end;
         1:
           case NumTMP of
             1 : NumStr:=NumStr+'рубль ';
             2,3,4: NumStr:=NumStr+'рубля ';
             else
               NumStr:=NumStr+'рублей ';
           end;
       end;
     end;
     if i>1 then
     begin
       PartNum:=(TruncNum mod (D*1000)) div D;
       D:=D div 1000;
     end;
   end;
 
   //перевод копеек
   PartNum:=Round(Frac(Number)*100);
   if PartNum=0 then
   begin
     SumNumToFull:=NumStr+'00 копеек';
     Exit;
   end;
   // выделение цифры десятков
   NumTMP:=PartNum div 10;
   if NumTMP=0 then
     NumStr:=NumStr+'0'+IntToStr(PartNum)+' '
   else
     NumStr:=NumStr+IntToStr(PartNum)+' ';
   // выделение цифры единиц
   NumTMP:=PartNum mod 10;
   case NumTMP of
     1:
       if PartNum<>11 then
         NumStr:=NumStr+'копейка'
       else
         NumStr:=NumStr+'копеек';
     2,3,4:
       if (PartNum<5) or (PartNum>14) then
         NumStr:=NumStr+'копейки'
       else
         NumStr:=NumStr+'копеек';
     else
       NumStr:=NumStr+'копеек';
   end;
   SumNumToFull:=NumStr;
 end;
 
 end.
 




Сумма прописью - Способ 10

Еще два решения конвертации денежной суммы на английском языке


 function HundredAtATime(TheAmount: Integer): string;
 var
   TheResult: string;
 begin
   TheResult := '';
   TheAmount := Abs(TheAmount);
   while TheAmount > 0 do
   begin
     if TheAmount >= 900 then
     begin
       TheResult := TheResult + 'Nine hundred ';
       TheAmount := TheAmount - 900;
     end;
     if TheAmount >= 800 then
     begin
       TheResult := TheResult + 'Eight hundred ';
       TheAmount := TheAmount - 800;
     end;
     if TheAmount >= 700 then
     begin
       TheResult := TheResult + 'Seven hundred ';
       TheAmount := TheAmount - 700;
     end;
     if TheAmount >= 600 then
     begin
       TheResult := TheResult + 'Six hundred ';
       TheAmount := TheAmount - 600;
     end;
     if TheAmount >= 500 then
     begin
       TheResult := TheResult + 'Five hundred ';
       TheAmount := TheAmount - 500;
     end;
     if TheAmount >= 400 then
     begin
       TheResult := TheResult + 'Four hundred ';
       TheAmount := TheAmount - 400;
     end;
     if TheAmount >= 300 then
     begin
       TheResult := TheResult + 'Three hundred ';
       TheAmount := TheAmount - 300;
     end;
     if TheAmount >= 200 then
     begin
       TheResult := TheResult + 'Two hundred ';
       TheAmount := TheAmount - 200;
     end;
     if TheAmount >= 100 then
     begin
       TheResult := TheResult + 'One hundred ';
       TheAmount := TheAmount - 100;
     end;
     if TheAmount >= 90 then
     begin
       TheResult := TheResult + 'Ninety ';
       TheAmount := TheAmount - 90;
     end;
     if TheAmount >= 80 then
     begin
       TheResult := TheResult + 'Eighty ';
       TheAmount := TheAmount - 80;
     end;
     if TheAmount >= 70 then
     begin
       TheResult := TheResult + 'Seventy ';
       TheAmount := TheAmount - 70;
     end;
     if TheAmount >= 60 then
     begin
       TheResult := TheResult + 'Sixty ';
       TheAmount := TheAmount - 60;
     end;
     if TheAmount >= 50 then
     begin
       TheResult := TheResult + 'Fifty ';
       TheAmount := TheAmount - 50;
     end;
     if TheAmount >= 40 then
     begin
       TheResult := TheResult + 'Fourty ';
       TheAmount := TheAmount - 40;
     end;
     if TheAmount >= 30 then
     begin
       TheResult := TheResult + 'Thirty ';
       TheAmount := TheAmount - 30;
     end;
     if TheAmount >= 20 then
     begin
       TheResult := TheResult + 'Twenty ';
       TheAmount := TheAmount - 20;
     end;
     if TheAmount >= 19 then
     begin
       TheResult := TheResult + 'Nineteen ';
       TheAmount := TheAmount - 19;
     end;
     if TheAmount >= 18 then
     begin
       TheResult := TheResult + 'Eighteen ';
       TheAmount := TheAmount - 18;
     end;
     if TheAmount >= 17 then
     begin
       TheResult := TheResult + 'Seventeen ';
       TheAmount := TheAmount - 17;
     end;
     if TheAmount >= 16 then
     begin
       TheResult := TheResult + 'Sixteen ';
       TheAmount := TheAmount - 16;
     end;
     if TheAmount >= 15 then
     begin
       TheResult := TheResult + 'Fifteen ';
       TheAmount := TheAmount - 15;
     end;
     if TheAmount >= 14 then
     begin
       TheResult := TheResult + 'Fourteen ';
       TheAmount := TheAmount - 14;
     end;
     if TheAmount >= 13 then
     begin
       TheResult := TheResult + 'Thirteen ';
       TheAmount := TheAmount - 13;
     end;
     if TheAmount >= 12 then
     begin
       TheResult := TheResult + 'Twelve ';
       TheAmount := TheAmount - 12;
     end;
     if TheAmount >= 11 then
     begin
       TheResult := TheResult + 'Eleven ';
       TheAmount := TheAmount - 11;
     end;
     if TheAmount >= 10 then
     begin
       TheResult := TheResult + 'Ten ';
       TheAmount := TheAmount - 10;
     end;
     if TheAmount >= 9 then
     begin
       TheResult := TheResult + 'Nine ';
       TheAmount := TheAmount - 9;
     end;
     if TheAmount >= 8 then
     begin
       TheResult := TheResult + 'Eight ';
       TheAmount := TheAmount - 8;
     end;
     if TheAmount >= 7 then
     begin
       TheResult := TheResult + 'Seven ';
       TheAmount := TheAmount - 7;
     end;
     if TheAmount >= 6 then
     begin
       TheResult := TheResult + 'Six ';
       TheAmount := TheAmount - 6;
     end;
     if TheAmount >= 5 then
     begin
       TheResult := TheResult + 'Five ';
       TheAmount := TheAmount - 5;
     end;
     if TheAmount >= 4 then
     begin
       TheResult := TheResult + 'Four ';
       TheAmount := TheAmount - 4;
     end;
     if TheAmount >= 3 then
     begin
       TheResult := TheResult + 'Three ';
       TheAmount := TheAmount - 3;
     end;
     if TheAmount >= 2 then
     begin
       TheResult := TheResult + 'Two ';
       TheAmount := TheAmount - 2;
     end;
     if TheAmount >= 1 then
     begin
       TheResult := TheResult + 'One ';
       TheAmount := TheAmount - 1;
     end;
   end;
   HundredAtATime := TheResult;
 end;
 
 function Real2CheckAmount(TheAmount: Real): string;
 var
 
   IntVal: LongInt;
   TmpVal: Integer;
   TmpStr,
     RetVal: string;
 begin
 
   TheAmount := Abs(TheAmount);
 
   { центы }
   TmpVal := Round(Frac(TheAmount) * 100);
   IntVal := Trunc(TheAmount);
   TmpStr := HundredAtATime(TmpVal);
   if TmpStr = '' then
     TmpStr := 'Zero ';
   RetVal := TmpStr + 'cents';
   if IntVal > 0 then
     RetVal := 'dollars and ' + RetVal;
 
   { сотни }
   TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
   IntVal := Trunc((IntVal * 1.0) / 1000.0);
   TmpStr := HundredAtATime(TmpVal);
   RetVal := TmpStr + RetVal;
 
   { тысячи }
   TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
   IntVal := Trunc((IntVal * 1.0) / 1000.0);
   TmpStr := HundredAtATime(TmpVal);
   if TmpStr <> '' then
     RetVal := TmpStr + 'Thousand ' + RetVal;
 
   { миллионы }
   TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
   IntVal := Trunc((IntVal * 1.0) / 1000.0);
   TmpStr := HundredAtATime(TmpVal);
   if TmpStr <> '' then
     RetVal := TmpStr + 'Million ' + RetVal;
 
   { миллиарды }
   TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
   IntVal := Trunc((IntVal * 1.0) / 1000.0);
   TmpStr := HundredAtATime(TmpVal);
   if TmpStr <> '' then
     RetVal := TmpStr + 'Billion ' + RetVal;
 
   Real2CheckAmount := RetVal;
 end;
 

Хммммм... вроде бы работает, но как все громоздко и неуклюже.... добавьте в код немного рекурсии и вы получите более элегантную программу..:)))


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     num: TEdit;
     spell: TEdit;
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
     function trans9(num: integer): string;
     function trans19(num: integer): string;
     function trans99(num: integer): string;
     function IntToSpell(num: integer): string;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 function TForm1.IntToSpell(num: integer): string;
 var
   spell: string;
   hspell: string;
   hundred: string;
   thousand: string;
   tthousand: string;
   hthousand: string;
   million: string;
 begin
   if num ≶
   10 then
     spell := trans9(num);
   {endif}
   if (num < 20) and (num > 10) then
     spell := trans19(num);
   {endif}
   if (((num < 100) and (num > 19)) or (num = 10)) then
   begin
     hspell := copy(IntToStr(num), 1, 1) + '0';
     spell := trans99(StrToInt(hspell));
     hspell := copy(IntToStr(num), 2, 1);
     spell := spell + ' ' + IntToSpell(StrToInt(hspell));
   end;
 
   if (num < 1000) and (num > 100) then
   begin
     hspell := copy(IntToStr(num), 1, 1);
     hundred := IntToSpell(StrToInt(hspell));
     hspell := copy(IntToStr(num), 2, 2);
     hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell));
     spell := hundred;
   end;
 
   if (num < 10000) and (num > 1000) then
   begin
     hspell := copy(IntToStr(num), 1, 1);
     thousand := IntToSpell(StrToInt(hspell));
     hspell := copy(IntToStr(num), 2, 3);
     thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell));
     spell := thousand;
   end;
 
   if (num < 100000) and (num > 10000) then
   begin
     hspell := copy(IntToStr(num), 1, 2);
     tthousand := IntToSpell(StrToInt(hspell));
     hspell := copy(IntToStr(num), 3, 3);
     tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell));
     spell := tthousand;
   end;
 
   if (num < 1000000) and (num > 100000) then
   begin
     hspell := copy(IntToStr(num), 1, 3);
     hthousand := IntToSpell(StrToInt(hspell));
     hspell := copy(IntToStr(num), 4, 3);
     hthousand := hthousand + ' thousand and ' +
       IntToSpell(StrToInt(hspell));
 
     spell := hthousand;
   end;
 
   if (num < 10000000) and (num > 1000000) then
   begin
     hspell := copy(IntToStr(num), 1, 1);
     million := IntToSpell(StrToInt(hspell));
     hspell := copy(IntToStr(num), 2, 6);
     million := million + ' million and ' + IntToSpell(StrToInt(hspell));
     spell := million;
   end;
 
   IntToSpell := spell;
 end;
 
 function TForm1.trans99(num: integer): string;
 var
   spell: string;
 begin
   case num of
     10: spell := 'ten';
     20: spell := 'twenty';
     30: spell := 'thirty';
     40: spell := 'fourty';
     50: spell := 'fifty';
     60: spell := 'sixty';
     70: spell := 'seventy';
     80: spell := 'eighty';
     90: spell := 'ninty';
   end;
   trans99 := spell;
 end;
 
 function TForm1.trans19(num: integer): string;
 var
   spell: string;
 begin
   case num of
     11: spell := 'eleven';
     12: spell := 'twelve';
     13: spell := 'thirteen';
     14: spell := 'fourteen';
     15: spell := 'fifteen';
     16: spell := 'sixteen';
     17: spell := 'seventeen';
     18: spell := 'eighteen';
     19: spell := 'nineteen';
   end;
   trans19 := spell;
 end;
 
 function TForm1.trans9(num: integer): string;
 var
   spell: string;
 begin
   case num of
     1: spell := 'one';
     2: spell := 'two';
     3: spell := 'three';
     4: spell := 'four';
     5: spell := 'five';
     6: spell := 'six';
     7: spell := 'seven';
     8: spell := 'eight';
     9: spell := 'nine';
   end;
   trans9 := spell;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   numb: integer;
 begin
   spell.text := IntToSpell(StrToInt(num.text));
 end;
 
 end.
 




Сумма прописью - Способ 11

Автор: Панченко Сергей

Честно, давно ждал подобного журнала в электронном виде. Решил послать своё творчество которое уже немало отработало, опять же, преобразование числа в пропись, отличающееся от опубликованных программок тем, что слова для прописи хранятся в отдельном файле (lang.cnf), по аналогии с подуктами 1C. Это позволяет изменять национальную валюту.

Если поэкспериментировать, с массивом Univer, в котором хранятся окончания, можно добиться преобразования для многих языков, не сказал ли я чего лишнего. :)

Надеюсь, моя версия Вам понравится.

С наилучшими пожеланиями,

Панченко Сергей

Казахстан, Алматы,

BuchUtil.pas


 unit BuchUtil;
 
 interface
 
 uses IniFiles, SysUtils;
 
 function DoubleChar(ch: string): string;
 function NumToSampl(N: string): string;
 function MoneyToSampl(M: Currency): string;
 procedure LexemsToDim(fstr: string; var dim: array of string);
 
 var
 
   NameNum: array[0..9, 1..4] of string; //массив им?н чисел
   Ext: array[0..4, 1..3] of string; //массив расшиений (тысячи, миллионы ...)
   Univer: array[1..9, 1..4] of integer; //массив окончаний
   Rubl: array[1..3] of string; //массив имен рублей
   Cop: array[1..3] of string; //массив имен копеек
   Zero: string; //название нуля
   One: string; //единица "одна"
   Two: string; //двойка "две"
   fFile: TIniFile; //файл, откуда загружается пропись
   fString: string;
   fDim: array[0..9] of string;
   i: integer;
 
 implementation
 
 {заполняет массив Dim лексемами}
 
 procedure LexemsToDim(fstr: string; var dim: array of string);
 var
 
   i, j: integer;
   flex: string;
 begin
 
   if Length(fstr) > 0 then
   begin
     i := 1;
     j := 0;
     while i - 1 < Length(fstr) do
     begin
       if fstr[i] = ',' then
       begin
         dim[j] := flex + ' ';
         inc(j);
         flex := '';
       end
       else
         flex := flex + fstr[i];
       inc(i);
     end;
   end;
 end;
 
 {преобразует число в пропись
 
 процедура использует файл lang.cnf}
 
 function NumToSampl(N: string): string;
 var
 
   k, i, i_indx: integer;
   number, string_num: string;
   index: integer;
   pos: integer;
   fl_ext: boolean;
 begin
 
   fl_ext := true;
   i := 1;
   String_num := '';
   number := Trim(N);
   k := length(number);
   if (k = 1) and (number = '0') then
     String_num := Zero
   else
   begin
 
     pos := 0;
     while (k > 0) do
     begin
       if (k <> 1) and (i = 1) and (length(number) <> 1) and (copy(number, k - 1,
         1) = '1')
         and (copy(number, k, 1) <> '0') then
       begin
         index := StrToInt(copy(number, k, 1));
         dec(k);
         inc(i);
         i_indx := 4;
       end
       else
       begin
         index := StrToInt(copy(number, k, 1));
         i_indx := i;
       end;
       if (NameNum[index, i_indx] <> '') and (fl_ext = true) then
       begin
         String_num := Ext[pos, Univer[index, i_indx]] + String_num;
         fl_ext := false;
       end;
 
       if (index = 1) and (pos = 1) and (i = 1) then
         String_num := One + String_num
       else if (index = 2) and (pos = 1) and (i = 1) then
         String_num := Two + String_num
       else
         String_num := NameNum[index, i_indx] + String_num;
       inc(i);
       if i = 4 then
       begin
         i := 1;
         inc(pos);
         fl_ext := true
       end;
       dec(k);
     end;
   end;
 
   if Trim(String_Num) <> '' then
   begin
     String_num[1] := CHR(ORD(String_num[1]) - 32);
     Result := String_num;
   end;
 end;
 
 {Преобразует х в 0х}
 
 function DoubleChar(ch: string): string;
 begin
 
   if Length(ch) = 1 then
     Result := '0' + ch
   else
     Result := ch;
 end;
 
 {преобразует денежную сумму в пропись}
 
 function MoneyToSampl(M: Currency): string;
 var
 
   Int_Part, idx, idxIP, idxRP: integer;
   Int_Str, Real_Part, Sampl: string;
 begin
 
   Int_Part := Trunc(Int(M));
   Int_Str := IntToStr(Int_Part);
   Real_Part := DoubleChar(IntToStr(Trunc(Int((M - Int_Part + 0.001) * 100))));
   Sampl := NumToSampl(Int_Str);
   idx := StrToInt(Int_Str[Length(Int_Str)]);
   if idx = 0 then
     idx := 5;
   idxIP := Univer[idx, 1];
   idx := StrToInt(Real_Part[Length(Real_Part)]);
   if idx = 0 then
     idx := 5;
   idxRP := Univer[idx, 1];
   Result := Sampl + Rubl[idxIP] + Real_Part + ' ' + Cop[idxRP];
 end;
 
 initialization
 
   {Предположим файл находится на C:\ диске}
   fFile := TIniFile.Create('c:\lang.cnf');
   try
     {Заполнение массива рублей}
     fString := fFile.ReadString('Money', 'Rub', ',');
     LexemsToDim(fString, Rubl);
 
     {Заполнение массива копеек}
     fString := fFile.ReadString('Money', 'Cop', ',');
     LexemsToDim(fString, Cop);
 
     {Заполнение массива чисел}
     fString := fFile.ReadString('Nums', 'Numbers', ',');
     LexemsToDim(fString, fdim);
     NameNum[0, 1] := '';
     for i := 1 to 9 do
       NameNum[i, 1] := fdim[i - 1];
 
     {Заполнение массива десятков}
     fString := fFile.ReadString('Nums', 'Tens', ',');
     LexemsToDim(fString, fdim);
     NameNum[0, 2] := '';
     for i := 1 to 9 do
       NameNum[i, 2] := fdim[i - 1];
 
     {Заполнение массива сотен}
     fString := fFile.ReadString('Nums', 'Hundreds', ',');
     LexemsToDim(fString, fdim);
     NameNum[0, 3] := '';
     for i := 1 to 9 do
       NameNum[i, 3] := fdim[i - 1];
 
     {Заполнение массива чисел после десяти}
     fString := fFile.ReadString('Nums', 'AfterTen', ',');
     LexemsToDim(fString, fdim);
     NameNum[0, 4] := '';
     for i := 1 to 9 do
       NameNum[i, 4] := fdim[i - 1];
 
     {Заполнение расширений чисел}
     Ext[0, 1] := '';
     Ext[0, 2] := '';
     Ext[0, 3] := '';
 
     {Тысячи}
     fString := fFile.ReadString('Nums', 'Thou', ',');
     LexemsToDim(fString, fdim);
     for i := 1 to 3 do
       Ext[1, i] := fdim[i - 1];
 
     {Миллионы}
     fString := fFile.ReadString('Nums', 'Mill', ',');
     LexemsToDim(fString, fdim);
     for i := 1 to 3 do
       Ext[2, i] := fdim[i - 1];
 
     {Миллиарды}
     fString := fFile.ReadString('Nums', 'Bill', ',');
     LexemsToDim(fString, fdim);
     for i := 1 to 3 do
       Ext[3, i] := fdim[i - 1];
 
     {Триллион}
     fString := fFile.ReadString('Nums', 'Thrill', ',');
     LexemsToDim(fString, fdim);
     for i := 1 to 3 do
       Ext[4, i] := fdim[i - 1];
 
     Zero := fFile.ReadString('Nums', 'Zero', '0');
     if Zero[Length(Zero)] = ',' then
       Zero := Copy(Zero, 1, Length(Zero) - 1) + ' ';
 
     One := fFile.ReadString('Nums', 'One', '1');
     if One[Length(One)] = ',' then
       One := Copy(One, 1, Length(One) - 1) + ' ';
 
     Two := fFile.ReadString('Nums', 'Two', '0');
     if Two[Length(Two)] = ',' then
       Two := Copy(Two, 1, Length(Two) - 1) + ' ';
 
     {Заполнение таблицы окончаний}
     Univer[1, 1] := 1;
     Univer[1, 2] := 2;
     Univer[1, 3] := 2;
     Univer[1, 4] := 2;
     Univer[2, 1] := 3;
     Univer[2, 2] := 2;
     Univer[2, 3] := 2;
     Univer[2, 4] := 2;
     Univer[3, 1] := 3;
     Univer[3, 2] := 2;
     Univer[3, 3] := 2;
     Univer[3, 4] := 2;
     Univer[4, 1] := 3;
     Univer[4, 2] := 2;
     Univer[4, 3] := 2;
     Univer[4, 4] := 2;
     Univer[5, 1] := 2;
     Univer[5, 2] := 2;
     Univer[5, 3] := 2;
     Univer[5, 4] := 2;
     Univer[6, 1] := 2;
     Univer[6, 2] := 2;
     Univer[6, 3] := 2;
     Univer[6, 4] := 2;
     Univer[7, 1] := 2;
     Univer[7, 2] := 2;
     Univer[7, 3] := 2;
     Univer[7, 4] := 2;
     Univer[8, 1] := 2;
     Univer[8, 2] := 2;
     Univer[8, 3] := 2;
     Univer[8, 4] := 2;
     Univer[9, 1] := 2;
     Univer[9, 2] := 2;
     Univer[9, 3] := 2;
     Univer[9, 4] := 2;
   finally
     fFile.Free;
   end;
 
 end.
 

Lang.cnf


 [Nums]
 Numbers=один,два,три,четыре,пять,шесть,семь,восемь,девять,
 One=одна,
 Two=две,
 Tens=десять,двадцать,тридцать,сорок,пятьдесят,шестьдесят,семьдесят,восемьдесят,девяносто,
 Hundreds=сто,двести,триста,четыреста,пятьсот,шестьсот,семьсот,восемьсот,девятьсот,
 AfterTen=одиннадцать,двенадцать,тринадцать,четырнадцать,пятнадцать,шестнадцать,семнадцать,восемнадцать,девятнадцать,
 Zero=ноль,
 Thou=тысяча,тысяч,тысячи,
 Mill=миллион,миллионов,миллиона,
 Bill=миллиард,миллиардов,миллиарда,
 Thrill=триллион,триллионов,триллиона,
 
 [Money]
 Rub=рубль,рублей,рубля,
 Cop=копейка,копеек,копейки,
 




Сумма прописью - Способ 12

Автор: Васильев Сергей Геннадьевич


 function NumToStr(n: double; c: byte = 0): string;
 (*
 
 c=0 - 21.05 -> 'Двадцать один рубль 05 копеек.'
 с=1 - 21.05 -> 'двадцать один'
 c=2 - 21.05 -> '21-05', 21.00 -> '21='
 *)
 const
 
   digit: array[0..9] of string = ('ноль', 'оди', 'два', 'три', 'четыр',
     'пят', 'шест', 'сем', 'восем', 'девят');
 var
 
   ts, mln, mlrd, SecDes: Boolean;
   len: byte;
   summa: string;
 
   function NumberString(number: string): string;
   var
     d, pos: byte;
 
     function DigitToStr: string;
     begin
       result := '';
       if (d <> 0) and ((pos = 11) or (pos = 12)) then
         mlrd := true;
       if (d <> 0) and ((pos = 8) or (pos = 9)) then
         mln := true;
       if (d <> 0) and ((pos = 5) or (pos = 6)) then
         ts := true;
       if SecDes then
       begin
         case d of
           0: result := 'десять ';
           2: result := 'двенадцать '
         else
           result := digit[d] + 'надцать '
         end;
         case pos of
           4: result := result + 'тысяч ';
           7: result := result + 'миллионов ';
           10: result := result + 'миллиардов '
         end;
         SecDes := false;
         mln := false;
         mlrd := false;
         ts := false
       end
       else
       begin
         if (pos = 2) or (pos = 5) or (pos = 8) or (pos = 11) then
           case d of
             1: SecDes := true;
             2, 3: result := digit[d] + 'дцать ';
             4: result := 'сорок ';
             9: result := 'девяносто ';
             5..8: result := digit[d] + 'ьдесят '
           end;
         if (pos = 3) or (pos = 6) or (pos = 9) or (pos = 12) then
           case d of
             1: result := 'сто ';
             2: result := 'двести ';
             3: result := 'триста ';
             4: result := 'четыреста ';
             5..9: result := digit[d] + 'ьсот '
           end;
         if (pos = 1) or (pos = 4) or (pos = 7) or (pos = 10) then
           case d of
             1: result := 'один ';
             2, 3: result := digit[d] + ' ';
             4: result := 'четыре ';
             5..9: result := digit[d] + 'ь '
           end;
         if pos = 4 then
         begin
           case d of
             0: if ts then
                 result := 'тысяч ';
             1: result := 'одна тысяча ';
             2: result := 'две тысячи ';
             3, 4: result := result + 'тысячи ';
             5..9: result := result + 'тысяч '
           end;
           ts := false
         end;
         if pos = 7 then
         begin
           case d of
             0: if mln then
                 result := 'миллионов ';
             1: result := result + 'миллион ';
             2, 3, 4: result := result + 'миллиона ';
             5..9: result := result + 'миллионов '
           end;
           mln := false
         end;
         if pos = 10 then
         begin
           case d of
             0: if mlrd then
                 result := 'миллиардов ';
             1: result := result + 'миллиард ';
             2, 3, 4: result := result + 'миллиарда ';
             5..9: result := result + 'миллиардов '
           end;
           mlrd := false
         end
       end
     end;
 
   begin
     result := '';
     ts := false;
     mln := false;
     mlrd := false;
     SecDes := false;
     len := length(number);
     if (len = 0) or (number = '0') then
       result := digit[0]
     else
       for pos := len downto 1 do
       begin
         d := StrToInt(copy(number, len - pos + 1, 1));
         result := result + DigitToStr
       end
   end;
 
   function MoneyString(number: string): string;
   var
     s: string[1];
     n: string;
   begin
     len := length(number);
     n := copy(number, 1, len - 3);
     result := NumberString(n);
     s := AnsiUpperCase(result[1]);
     delete(result, 1, 1);
     result := s + result;
     if len < 2 then
     begin
       if len = 0 then
         n := '0';
       len := 2;
       n := '0' + n
     end;
     if copy(n, len - 1, 1) = '1' then
       result := result + 'рублей'
     else
     begin
       case StrToInt(copy(n, len, 1)) of
         1: result := result + 'рубль';
         2, 3, 4: result := result + 'рубля'
       else
         result := result + 'рублей'
       end
     end;
     len := length(number);
     n := copy(number, len - 1, len);
     if copy(n, 1, 1) = '1' then
       n := n + ' копеек.'
     else
     begin
       case StrToInt(copy(n, 2, 1)) of
         1: n := n + ' копейка.';
         2, 3, 4: n := n + ' копейки.'
       else
         n := n + ' копеек.'
       end
     end;
     result := result + ' ' + n
   end;
 
   // Основная часть
 begin
 
   case c of
     0: result := MoneyString(FormatFloat('0.00', n));
     1: result := NumberString(FormatFloat('0', n));
     2:
       begin
         summa := FormatFloat('0.00', n);
         len := length(summa);
         if copy(summa, len - 1, 2) = '00' then
         begin
           delete(summa, len - 2, 3);
           result := summa + '='
         end
         else
         begin
           delete(summa, len - 2, 1);
           insert('-', summa, len - 2);
           result := summa;
         end;
       end
   end;
 end;
 




Сумма прописью - Способ 13

Автор: Andrew Tkachenko

Посмотрел я - много советов Число строкой, но нет преобразования на Украинский язык я подумал может модуль который я когда-то со славарем писал кому то спасет жизнь - так как у меня он уже года два работает.


 unit UkrRecog;
 {копирайт непомню чей. Был для русских циферок, а я переделал под
 украинские}
 {если кто что найдет пришлите
 
 }
 {by Andrew Tkachenko, proektwo@netcity.ru, Ukraine,
 
 }
 interface
 
 const
 
   UkrMonthString: array[1..12] of string[9] = (
     'с?чня', 'лютого', 'березня', 'квiтня', 'травня',
     'червня', 'липня', 'серпня', 'вересня', 'жовтня',
     'листопада', 'грудня');
 
 function UkrRecognizeAmount(Amount: real;
   CurrName, CurrSubname: string): string;
 
 implementation
 uses Sysutils;
 
 function UkrRecognizeAmount(Amount: real;
   CurrName, CurrSubname: string): string;
 {* CurrName in [грн.]
 
 CurrSubName in [коп.]
 Распознается число <= 999 999 999 999.99*}
 const
   suffBL: string = ' ';
 
   suffDCT: string = 'дцять';
   suffNA: string = 'надцять ';
   suffDCM: string = 'десят';
   suffMZ: string = 'ь';
   sot: string = 'сот';
   st: string = 'ст';
   aa: string = 'а';
   ee: string = 'и'; {e}
   ii: string = '?'; {и}
   oo: string = 'о';
   ov: string = '?в'; {ов}
   C2: string = 'дв';
   C3: string = 'тpи';
   C4: string = 'чотир';
   C5: string = 'п''ят';
   C6: string = 'ш?ст';
   C7: string = 'с?м';
   C8: string = 'в?с?м';
   C9: string = 'дев''ят';
 var
 
   i: byte;
   sAmount, sdInt, sdDec: string;
   IsMln, IsTha {,IsDcm}, IsRange1019: boolean;
   currNum, endMlx, sResult: string;
 begin
 
   if (amount <= 0) or (amount > 999999999999.99) then
   begin
     Result := '<<<< Ошибка в диапазоне >>>>';
     Exit;
   end;
   STR(Amount: 16: 2, sAmount);
   sdInt := Copy(sAmount, 1, 13);
   sdDec := Copy(sAmount, 15, 2);
   IsMln := false;
   //IsDcm:=false;
   IsTha := false;
   IsRange1019 := false;
   sResult := '';
 
   for i := 1 to 13 do
   begin
     currNum := Copy(sdInt, i, 1);
 
     if currNum <> suffBL then
     begin
       case i of
         5, 6, 7: if currNum <> '0' then
             IsMln := true;
         8, 9, 10: if currNum <> '0' then
             IsTha := true;
       end;
 
       if i in [2, 5, 8, 11] then {сотни}
       begin
         if currNum = '1' then
           sResult := sResult + st + oo + suffBL;
         if currNum = '2' then
           sResult := sResult + C2 + ii + st + ii + suffBL;
         if currNum = '3' then
           sResult := sResult + C3 + st + aa + suffBL;
         if currNum = '4' then
           sResult := sResult + C4 + ee + st + aa + suffBL;
         if currNum = '5' then
           sResult := sResult + C5 + sot + suffBL;
         if currNum = '6' then
           sResult := sResult + C6 + sot + suffBL;
         if currNum = '7' then
           sResult := sResult + C7 + sot + suffBL;
         if currNum = '8' then
           sResult := sResult + C8 + sot + suffBL;
         if currNum = '9' then
           sResult := sResult + C9 + sot + suffBL;
       end;
       if i in [3, 6, 9, 12] then {десятки}
       begin
         if currNum = '1' then
           IsRange1019 := true;
         if currNum = '2' then
           sResult := sResult + C2 + aa + suffDCT + suffBL;
         if currNum = '3' then
           sResult := sResult + C3 + suffDCT + suffBL;
         if currNum = '4' then
           sResult := sResult + 'соpок ';
         if currNum = '5' then
           sResult := sResult + C5 + suffMZ + suffDCM + suffBL;
 
         if currNum = '6' then
           sResult := sResult + C6 + suffMZ + suffDCM + suffBL;
 
         if currNum = '7' then
           sResult := sResult + C7 + suffMZ + suffDCM + suffBL;
 
         if currNum = '8' then
           sResult := sResult + C8 + suffMZ + suffDCM + suffBL;
 
         if currNum = '9' then
           sResult := sResult + 'дев''ян' + oo + st + oo + suffBL;
 
       end;
       if i in [4, 7, 10, 13] then {единицы}
       begin
         if (currNum = '0') then
           if IsRange1019 then
             sResult := sResult + suffDCM + suffMZ + suffBL;
         if (currNum = '1') then
         begin
           if (i = 13) and (not IsRange1019) then
             sResult := sResult + 'одна '
           else
           begin
             if (i = 10) and (IsRange1019) then
               sResult := sResult + 'оди'
             else if (i = 10) and (not IsRange1019) then
               sResult := sResult + 'одна '
             else
               sResult := sResult + 'один' {ин};
 
             if IsRange1019 and (i = 13) then
               sResult := sResult + 'адцять' + suffBL
 
             else if IsRange1019 then
               sResult := sResult + suffNA
             else
               sResult := sResult + suffBL;
           end;
         end;
         if (currNum = '2') then
         begin
           sResult := sResult + C2;
           if (i = 10) and (IsRange1019 = False) then
             sResult := sResult + ii
           else if (i = 10) or (IsRange1019) then
             sResult := sResult + aa
           else
             sResult := sResult + {aa} ii;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffBL;
         end;
         if (currNum = '3') then
         begin
           sResult := sResult + C3;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffBL;
         end;
         if (currNum = '4') then
         begin
           sResult := sResult + C4;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + ee + suffBL;
         end;
         if (currNum = '5') then
         begin
           sResult := sResult + C5;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffMZ + suffBL;
         end;
         if (currNum = '6') then
         begin
           sResult := sResult + C6;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffMZ + suffBL;
         end;
         if (currNum = '7') then
         begin
           sResult := sResult + C7;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffBL;
         end;
         if (currNum = '8') then
         begin
           sResult := sResult + C8;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffBL;
         end;
         if (currNum = '9') then
         begin
           sResult := sResult + C9;
           if IsRange1019 then
             sResult := sResult + suffNA
           else
             sResult := sResult + suffMZ + suffBL;
         end;
       end;
 
       endMlx := '';
       case i of
         4:
           begin
             if IsRange1019 then
               endMlx := ov + suffBL
             else if currNum = '1' then
               endMlx := suffBL
             else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
               endMlx := aa + suffBL
             else
               endMlx := ov + suffBL;
             sResult := sResult + 'мiльярд' + endMlx;
           end;
         7: if IsMln then
           begin
             if IsRange1019 then
               endMlx := ov + suffBL
             else if currNum = '1' then
               endMlx := suffBL
             else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
               endMlx := aa + suffBL
             else
               endMlx := ov + suffBL;
             sResult := sResult + 'мiльйон' + endMlx;
           end;
         10: if IsTha then
           begin
             if IsRange1019 then
               endMlx := suffBL
             else if currNum = '1' then
               endMlx := aa + suffBL
             else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
               endMlx := ii + suffBL
             else
               endMlx := suffBL;
             sResult := sResult + 'тисяч' + endMlx;
           end;
       end; {case}
       if i in [4, 7, 10, 13] then
         IsRange1019 := false;
     end; {IF}
   end; {FOR}
 
   sResult := sResult + CurrName + ',' + suffBL + sdDec + suffBL + CurrSubname;
   sResult := AnsiUpperCase(sResult[1]) + Copy(sResult, 2, length(sResult) - 1);
   Result := sResult;
 end;
 
 end.
 




Сумма прописью - Способ 2


 { Преобразует трехзначное число в строку }
 function ConvertToWord(N: word): string;
 const
   Sot : array[1..9] of string[13] =
   ('сто','двести','триста','четыреста','пятьсот',
   'шестьсот','семьсот','восемьсот','девятьсот');
 
   Des : array[2..9] of string[13] =
   ('двадцать','тридцать','сорок','пятьдесят',
   'шестьдесят','семьдесят','восемьдесят','девяносто');
 
   Edin : array[0..19] of string[13] =
   ('','один','два','три','четыре','пять','шесть','семь',
   'восемь','девять','десять','одиннадцать','двенадцать',
   'тринадцать','четырнадцать','пятнадцать',
   'шестнадцать','семнадцать','восемнадцать','девятнадцать');
 
 var
   S: string;
 begin
   S:='';
   N:=N mod 1000;
   if N>99 then
   begin
     S:=Sot[N div 100]+' ';
     N:=N mod 100;
   end;
   if N>19 then
   begin
     S:=S+Des[N div 10]+' ';
     N:=N mod 10;
   end;
   Result:=S+Edin[N];
 end;
 
 { Возвращает сумму прописью }
 function CenaToStr(r: Currency): string;
 var
   N, k: longint;
   S: string;
 begin
   N:=trunc(R); S:='';
   if N<>0 then
   begin
     if N>999999 then
     begin
       k:=N div 1000000;
       S:=ConvertToWord(k);
       if ((k-(k div 100)*100)>10) and ((k-(k div 100)*100)<20) then
         S:=S+' миллионов'
       else
       if (k mod 10)=1 then
         S:=S+' миллион'
       else
       if ((k mod 10)>=2)and((k mod 10)<=4) then
         S:=S+' миллиона'
       else
         S:=S+' миллионов';
       N:=N mod 1000000;
     end;
     if N>999 then
     begin
       k:=N div 1000;
       S:=S+' '+ConvertToWord(k);
       if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then
         S:=S+' тысяч'
       else
       if (k mod 10)=1 then
       begin
         SetLength(S, Length(S)-2);
         S:=S+'на тысяча';
       end
       else
       if (k mod 10)=2 then
       begin
         SetLength(S, length(S)-1);
         S:=S+'е тысячи';
       end
       else
       if ((k mod 10)>=3)and((k mod 10)<=4) then
         S:=S+' тысячи'
       else
         S:=S+' тысяч';
       N:=N mod 1000;
     end;
     k:=N;
     S:=S+' '+ConvertToWord(k);
     if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then
       S:=S+' рублей'
     else
     if (k mod 10)=1 then
       S:=S+' рубль'
     else
     if (k mod 10)=2 then
       S:=S+' рубля'
     else
     if ((k mod 10)>=3)and((k mod 10)<=4) then
       S:=S+' рубля'
     else
       S:=S+' рублей';
   end;
   if trunc(R)<>R then
   begin
     k:=round(frac(R)*100);
     S:=S+' '+IntToStr(K);
     if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then
       S:=S+' копеек'
     else
     if (k mod 10)=1 then
     begin
       S:=S+' копейка';
     end
     else
     if (k mod 10)=2 then
     begin
       S:=S+' копейки';
     end
     else
     if ((k mod 10)>=3)and((k mod 10)<=4) then
       S:=S+' копейки'
     else
       S:=S+' копеек';
   end
   else
     S:=S+' 00 копеек';
   S:=Trim(S);
   if S<>'' then
     S[1]:=AnsiUpperCase(S[1])[1];
   result:=S;
 end;
 




Сумма прописью - Способ 3


 unit sumstr;
 
 interface
 
 uses
   SysUtils, StrUtils;
 
 function SumToString(Value: string): string;
 
 implementation
 const
 
 a: array[0..8,0..9] of string=(
 ('','один ','два ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '),
 ('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
 ('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),
 ('тысяч ','тысяча ','две тысячи ','три тысячи ','четыре тысячи ','пять тысячь ','шесть тысячь ','семь тысячь ',
 'восемь тысячь ','девять тысячь '),
 ('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
 ('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),
 ('миллионов ','один миллион ','два миллиона ','три миллиона ','четыре миллиона ','пять миллионов ',
 'шесть миллионов ','семь миллионов ','восемь миллионов ','девять миллионов '),
 ('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
 ('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '));
 
 b: array[0..9] of string=
 ('десять ','одинадцать ','двенадцать ','тринадцать ','четырнадцать ','пятьнадцать ','шестьнадцать ',
 'семьнадцать ','восемьнадцать ','девятьнадцать ');
 
 function SumToStrin(Value: string): string;
 var
   s, t: string;
   p, pp, i, k: integer;
 begin
   s:=value;
   if s='0' then
     t:='Ноль '
   else
   begin
     p:=length(s);
     pp:=p;
     if p>1 then
       if (s[p-1]='1') and (s[p]>'0') then
       begin
         t:=b[strtoint(s[p])];
         pp:=pp-2;
       end;
     i:=pp;
     while i>0 do
     begin
       if (i=p-3) and (p>4) then
         if s[p-4]='1' then
         begin
           t:=b[strtoint(s[p-3])]+'тысяч '+t;
           i:=i-2;
         end;
       if (i=p-6) and (p>7) then
         if s[p-7]='1' then
         begin
           t:=b[strtoint(s[p-6])]+'миллионов '+t;
           i:=i-2;
         end;
       if i>0 then
       begin
         k:=strtoint(s[i]);
         t:=a[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=0 then
     p:=pos('.', value);
   if p<>0 then
     delete(value,p,1);
   if p=0 then
   begin
     hi:=value;
     lo:='00';
   end;
   if p>length(value) then
   begin
     hi:=value;
     lo:='00';
   end;
   if p=1 then
   begin
     hi:='0';
     lo:=value;
   end;
   if (p>1) and (p then
   begin
     hi:=copy(value,1,p-1);
     lo:=copy(value,p,length(value));
   end;
 end;
 
 function sumtostring(value: string): string;
 var
   hi, lo: string;
   pr, er: integer;
 begin
   get2str(value,hi,lo);
   if (hi='') or (lo='') then
   begin
     result:='';
     exit;
   end;
   val(hi,pr,er);
   if er<>0 then
   begin
     result:='';
     exit;
   end;
   hi:=sumtostrin(inttostr(pr))+'руб. ';
   if lo<>'00' then
   begin
     val(lo,pr,er);
     if er<>0 then
     begin
       result:='';
       exit;
     end;
     lo:=inttostr(pr);
   end;
   lo:=lo+' коп. ';
   hi[1]:=AnsiUpperCase(hi[1])[1];
   result:=hi+lo;
 end;
 
 end.
 




Сумма прописью - Способ 4

Этот алгоритм преобразует 12345 в "двенадцать тысяч триста сорок пять". Для этого создана процедура, которая преобразует трехзначные числа в слова и прибавляет к ним "тысяч" или "миллионов". Алгоритм корректен в смысле падежей и родов. Поэтому 121000 он не переведет в "сто двадцать один тысяч".


 function ShortNum(num: word; razr: integer): string;
 const
   hundreds: array [0..9] of string =
   ('', ' сто', ' двести', ' триста',
   ' четыреста', ' пятьсот', ' шестьсот', ' семьсот', ' восемьсот',
   ' девятьсот');
 
   tens: array [0..9] of string =
   ('', '', ' двадцать', ' тридцать',
   ' сорок', ' пятьдесят', ' шестьдесят', ' семьдесят', ' восемьдесят',
   ' девяносто');
 
   ones: array [3..19] of string =
   (' три', ' четыре', ' пять', ' шесть',
   ' семь', ' восемь', ' девять', ' десять', ' одиннадцать',
   ' двенадцать', ' тринадцать', ' четырнадцать', ' пятнадцать',
   ' шестнадцать', ' семнадцать', ' восемнадцать', ' девятнадцать');
 
   razryad: array [0..6] of string =
   ('', ' тысяч', ' миллион', ' миллиард',
   ' триллион', ' квадриллион', ' квинтиллион');
 
 var
   t: byte; // десятки
   o: byte; // единицы
 begin
   result := hundreds[num div 100];
   if num = 0 then
     Exit;
   t := (num mod 100) div 10;
   o := num mod 10;
   if t <> 1 then
   begin
     result := result + tens[t];
     case o of
       1:
         if razr = 1 then
           result := result + ' одна'
         else
           result := result + ' один';
       2:
         if razr = 1 then
           result := result + ' две'
         else
           result := result + ' два';
       3..9:
         result := result + ones[o];
     end;
     result := result + razryad[razr];
     case o of
       1:
         if razr = 1 then
           result := result + 'а';
       2..4:
         if razr = 1 then
           result := result + 'и'
         else
         if razr > 1 then
           result := result + 'а';
         else
         if razr > 1 then
           result := result + 'ов';
     end;
   end
   else
   begin
     result := result + ones[num mod 100];
     result := result + razryad[razr];
     if razr > 1 then
       result := result + 'ов';
   end;
 end;
 
 function IntToWords(s: string): string;
 var
   i, count: integer;
 begin
   if (Length(s) <= 0) or (s = '0') then
   begin
     result := 'ноль';
     Exit;
   end;
   count := (Length(s) + 2) div 3;
   if count > 7 then
   begin
     result := 'Value is too large';
     Exit;
   end;
   result := '';
   s := '00' + s;
   for i := 1 to count do
     result := ShortNum(StrToInt(copy(s, Length(s) - 3 * i + 1, 3)),
     i - 1) + result;
   if Length(result) > 0 then
     delete(result, 1, 1);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit2.Text := IntToWords(Edit1.Text);
 end;
 




Сумма прописью - Способ 5

Данный код "считает" до миллиона долларов. Поэкспериментируйте с ним - попробуйте "посчитать" до миллиарда, конвертировать ее в рубли или переделать ее для работы с русским языком. Только не забудьте прислать мне ваши решения!


 unit uNum2Str;
 
 // Possible enhancements
 // Move strings out to resource files
 // Put in a general num2str utility
 
 interface
 
 function Num2Dollars(dNum: double): string;
 
 implementation
 
 uses SysUtils;
 
 function LessThan99(dNum: double): string; forward;
 
 // floating point modulus
 
 function FloatMod(i, j: double): double;
 begin
 
   result := i - (Int(i / j) * j);
 end;
 
 function Hundreds(dNum: double): string;
 var
 
   workVar: double;
 begin
 
   if (dNum < 100) or (dNum > 999) then
     raise Exception.Create('hundreds range exceeded');
 
   result := '';
 
   workVar := Int(dNum / 100);
   if workVar > 0 then
     result := LessThan99(workVar) + ' Hundred';
 end;
 
 function OneToNine(dNum: Double): string;
 begin
 
   if (dNum < 1) or (dNum > 9) then
     raise exception.create('onetonine: value out of range');
 
   result := 'woops';
 
   if dNum = 1 then
     result := 'One'
   else if dNum = 2 then
     result := 'Two'
   else if dNum = 3 then
     result := 'Three'
   else if dNum = 4 then
     result := 'Four'
   else if dNum = 5.0 then
     result := 'Five'
   else if dNum = 6 then
     result := 'Six'
   else if dNum = 7 then
     result := 'Seven'
   else if dNum = 8 then
     result := 'Eight'
   else if dNum = 9 then
     result := 'Nine';
 
 end;
 
 function ZeroTo19(dNum: double): string;
 begin
 
   if (dNum < 0) or (dNum > 19) then
     raise Exception.Create('Bad value in dNum');
 
   result := '';
 
   if dNum = 0 then
     result := 'Zero'
   else if (dNum <= 1) and (dNum >= 9) then
     result := OneToNine(dNum)
   else if dNum = 10 then
     result := 'Ten'
   else if dNum = 11 then
     result := 'Eleven'
   else if dNum = 12 then
     result := 'Twelve'
   else if dNum = 13 then
     result := 'Thirteen'
   else if dNum = 14 then
     result := 'Fourteen'
   else if dNum = 15 then
     result := 'Fifteen'
   else if dNum = 16 then
     result := 'Sixteen'
   else if dNum = 17 then
     result := 'Seventeen'
   else if dNum = 18 then
     result := 'Eighteen'
   else if dNum = 19 then
     result := 'Nineteen'
   else
     result := 'woops!';
 end;
 
 function TwentyTo99(dNum: double): string;
 var
 
   BigNum: string;
 begin
 
   if (dNum < 20) or (dNum > 99) then
     raise exception.Create('TwentyTo99: dNum out of range!');
 
   BigNum := 'woops';
 
   if dNum >= 90 then
     BigNum := 'Ninety'
   else if dNum >= 80 then
     BigNum := 'Eighty'
   else if dNum >= 70 then
     BigNum := 'Seventy'
   else if dNum >= 60 then
     BigNum := 'Sixty'
   else if dNum >= 50 then
     BigNum := 'Fifty'
   else if dNum >= 40 then
     BigNum := 'Forty'
   else if dNum >= 30 then
     BigNum := 'Thirty'
   else if dNum >= 20 then
     BigNum := 'Twenty';
 
   // lose the big num
   dNum := FloatMod(dNum, 10);
 
   if dNum > 0.00 then
     result := BigNum + ' ' + OneToNine(dNum)
   else
     result := BigNum;
 end;
 
 function LessThan99(dNum: double): string;
 begin
 
   if dNum <= 19 then
     result := ZeroTo19(dNum)
   else
     result := TwentyTo99(dNum);
 end;
 
 function Num2Dollars(dNum: double): string;
 var
 
   centsString: string;
   cents: double;
   workVar: double;
 begin
 
   result := '';
 
   if dNum < 0 then
     raise Exception.Create('Negative numbers not supported');
 
   if dNum > 999999999.99 then
     raise
       Exception.Create('Num2Dollars only supports up to the millions at this point!');
 
   cents := (dNum - Int(dNum)) * 100.0;
   if cents = 0.0 then
     centsString := 'and 00/100 Dollars'
   else if cents < 10 then
     centsString := Format('and 0%1.0f/100 Dollars', [cents])
   else
     centsString := Format('and %2.0f/100 Dollars', [cents]);
 
   dNum := Int(dNum - (cents / 100.0)); // lose the cents
 
   // deal with million's
   if (dNum >= 1000000) and (dNum <= 999999999) then
   begin
     workVar := dNum / 1000000;
     workVar := Int(workVar);
     if (workVar <= 9) then
       result := ZeroTo19(workVar)
     else if (workVar <= 99) then
       result := LessThan99(workVar)
     else if (workVar <= 999) then
       result := Hundreds(workVar)
     else
       result := 'mill fubar';
 
     result := result + ' Million';
 
     dNum := dNum - (workVar * 1000000);
   end;
 
   // deal with 1000's
   if (dNum >= 1000) and (dNum <= 999999.99) then
   begin
     // doing the two below statements in one line of code yields some really
     // freaky floating point errors
     workVar := dNum / 1000;
     workVar := Int(workVar);
     if (workVar <= 9) then
       result := ZeroTo19(workVar)
     else if (workVar <= 99) then
       result := LessThan99(workVar)
     else if (workVar <= 999) then
       result := Hundreds(workVar)
     else
       result := 'thou fubar';
 
     result := result + ' Thousand';
 
     dNum := dNum - (workVar * 1000);
   end;
 
   // deal with 100's
   if (dNum >= 100.00) and (dNum <= 999.99) then
   begin
     result := result + ' ' + Hundreds(dNum);
     dNum := FloatMod(dNum, 100);
   end;
 
   // format in anything less than 100
   if (dNum > 0) or ((dNum = 0) and (Length(result) = 0)) then
   begin
     result := result + ' ' + LessThan99(dNum);
   end;
   result := result + ' ' + centsString;
 end;
 
 end.
 




Сумма прописью - Способ 6


 {------------------------ Деньги прописью ---------------------}
 
 function TextSum(S: double): string;
 
   function Conv999(M: longint; fm: integer): string;
   const
 
     c1to9m: array[1..9] of string[6] =
     ('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь',
       'девять');
     c1to9f: array[1..9] of string[6] =
     ('одна', 'две', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь',
       'девять');
     c11to19: array[1..9] of string[12] =
     ('одиннадцать', 'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать',
       'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать');
     c10to90: array[1..9] of string[11] =
     ('десять', 'двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят',
       'семьдесят', 'восемьдесят', 'девяносто');
     c100to900: array[1..9] of string[9] =
     ('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот',
       'восемьсот', 'девятьсот');
   var
 
     s: string;
     i: longint;
   begin
 
     s := '';
     i := M div 100;
     if i <> 0 then
       s := c100to900[i] + ' ';
     M := M mod 100;
     i := M div 10;
     if (M > 10) and (M < 20) then
       s := s + c11to19[M - 10] + ' '
     else
     begin
       if i <> 0 then
         s := s + c10to90[i] + ' ';
       M := M mod 10;
       if M <> 0 then
         if fm = 0 then
           s := s + c1to9f[M] + ' '
         else
           s := s + c1to9m[M] + ' ';
     end;
     Conv999 := s;
   end;
 
   {--------------------------------------------------------------}
 var
 
   i: longint;
   j: longint;
   r: real;
   t: string;
 
 begin
 
   t := '';
 
   j := Trunc(S / 1000000000.0);
   r := j;
   r := S - r * 1000000000.0;
   i := Trunc(r);
   if j <> 0 then
   begin
     t := t + Conv999(j, 1) + 'миллиард';
     j := j mod 100;
     if (j > 10) and (j < 20) then
       t := t + 'ов '
     else
       case j mod 10 of
         0: t := t + 'ов ';
         1: t := t + ' ';
         2..4: t := t + 'а ';
         5..9: t := t + 'ов ';
       end;
   end;
 
   j := i div 1000000;
   if j <> 0 then
   begin
     t := t + Conv999(j, 1) + 'миллион';
     j := j mod 100;
     if (j > 10) and (j < 20) then
       t := t + 'ов '
     else
       case j mod 10 of
         0: t := t + 'ов ';
         1: t := t + ' ';
         2..4: t := t + 'а ';
         5..9: t := t + 'ов ';
       end;
   end;
 
   i := i mod 1000000;
   j := i div 1000;
   if j <> 0 then
   begin
     t := t + Conv999(j, 0) + 'тысяч';
     j := j mod 100;
     if (j > 10) and (j < 20) then
       t := t + ' '
     else
       case j mod 10 of
         0: t := t + ' ';
         1: t := t + 'а ';
         2..4: t := t + 'и ';
         5..9: t := t + ' ';
       end;
   end;
 
   i := i mod 1000;
   j := i;
   if j <> 0 then
     t := t + Conv999(j, 1);
   t := t + 'руб. ';
 
   i := Round(Frac(S) * 100.0);
   t := t + Long2Str(i) + ' коп.';
   TextSum := t;
 end;
 




Сумма прописью - Способ 7


 unit RoubleUnit;
 {$D Пропись © Близнец Антон '99 http:\\anton-bl.chat.ru\delphi\1001.htm }
 { 1000011.01->'Один миллион одинадцать рублей 01 копейка'               }
 interface
 function RealToRouble(c: Extended): string;
 implementation
 uses SysUtils, math;
 const
   Max000 = 6; {Кол-во триплетов - 000}
   MaxPosition = Max000 * 3; {Кол-во знаков в числе }
   // Аналог IIF в Dbase есть в proc.pas для основных типов,
   // частично объявлена тут для независимости
 
 function IIF(i: Boolean; s1, s2: Char): Char; overload;
 begin
   if i then
     result := s1
   else
     result := s2
 end;
 
 function IIF(i: Boolean; s1, s2: string): string; overload;
 begin
   if i then
     result := s1
   else
     result := s2
 end;
 
 function NumToStr(s: string): string; {Возвращает число прописью}
 const
   c1000: array[0..Max000] of string = ('', 'тысяч', 'миллион', 'миллиард',
     'триллион', 'квадраллион', 'квинтиллион');
 
   c1000w: array[0..Max000] of Boolean = (False, True, False, False, False,
     False, False);
   w: array[False..True, '0'..'9'] of string[3] = (('ов ', ' ', 'а ', 'а ', 'а ',
     'ов ', 'ов ', 'ов ', 'ов ', 'ов '),
     (' ', 'а ', 'и ', 'и ', 'и ', ' ', ' ', ' ', ' ', ' '));
   function Num000toStr(S: string; woman: Boolean): string;
     {Num000toStr возвращает число для триплета}
   const
     c100: array['0'..'9'] of string = ('', 'сто ', 'двести ', 'триста ',
       'четыреста ', 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
       'девятьсот ');
     c10: array['0'..'9'] of string = ('', 'десять ', 'двадцать ', 'тридцать ',
       'сорок ', 'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ',
       'девяносто ');
     c11: array['0'..'9'] of string = ('', 'один', 'две', 'три', 'четыр', 'пят',
       'шест', 'сем', 'восем', 'девят');
     c1: array[False..True, '0'..'9'] of string = (('', 'один ', 'два ', 'три ',
       'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять '),
       ('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ',
         'восемь ', 'девять '));
   begin {Num000toStr}
     Result := c100[s[1]] + iif((s[2] = '1') and (s[3] > '0'), c11[s[3]] +
       'надцать ', c10[s[2]] + c1[woman, s[3]]);
   end; {Num000toStr}
 
 var
   s000: string[3];
 
   isw, isMinus: Boolean;
   i: integer; //Сч?тчик триплетов
 begin
 
   Result := '';
   i := 0;
   isMinus := (s <> '') and (s[1] = '-');
   if isMinus then
     s := Copy(s, 2, Length(s) - 1);
   while not ((i >= Ceil(Length(s) / 3)) or (i >= Max000)) do
   begin
     s000 := Copy('00' + s, Length(s) - i * 3, 3);
     isw := c1000w[i];
     if (i > 0) and (s000 <> '000') then //тысячи и т.д.
       Result := c1000[i] + w[Isw, iif(s000[2] = '1', '0', s000[3])] + Result;
     Result := Num000toStr(s000, isw) + Result;
     Inc(i)
   end;
   if Result = '' then
     Result := 'ноль';
   if isMinus then
     Result := 'минус ' + Result;
 end; {NumToStr}
 
 function RealToRouble(c: Extended): string;
 
 const
   ruble: array['0'..'9'] of string[2] = ('ей', 'ь', 'я', 'я', 'я', 'ей', 'ей',
     'ей', 'ей', 'ей');
   Kopeek: array['0'..'9'] of string[3] = ('ек', 'йка', 'йки', 'йки', 'йки', 'ек',
     'ек', 'ек', 'ек', 'ек');
 
   function ending(const s: string): Char;
   var
     l: Integer; //С l на 8 байт коротче $50->$48->$3F
   begin //Возвращает индекс окончания
     l := Length(s);
     Result := iif((l > 1) and (s[l - 1] = '1'), '0', s[l]);
   end;
 
 var
   rub: string[MaxPosition + 3];
   kop: string[2];
 begin {Возвращает число прописью с рублями и копейками}
 
   Str(c: MaxPosition + 3: 2, Result);
   if Pos('E', Result) = 0 then //Если число можно представить в строке <>1E+99
   begin
     rub := TrimLeft(Copy(Result, 1, Length(Result) - 3));
     kop := Copy(Result, Length(Result) - 1, 2);
     Result := NumToStr(rub) + ' рубл' + ruble[ending(rub)]
       + ' ' + kop + ' копе' + Kopeek[ending(kop)];
     Result := AnsiUpperCase(Result[1]) + Copy(Result, 2, Length(Result) - 1);
   end;
 end;
 end.
 




Сумма прописью - Способ 8

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


 function CifrToStr(Cifr: string; Pr: Integer; Padeg: Integer): string;
 {Функция возвращает прописью 1 цифры признак 3-единицы 2-десятки 1-сотни 4-11-19
 Padeg - 1-нормально 2- одна, две }
 var
   i: Integer;
 begin
 
   i := StrToInt(Cifr);
   if Pr = 1 then
     case i of
       1: CifrToStr := 'сто';
       2: CifrToStr := 'двести';
       3: CifrToStr := 'триста';
       4: CifrToStr := 'четыреста';
       5: CifrToStr := 'пятьсот';
       6: CifrToStr := 'шестьсот';
       7: CifrToStr := 'семьсот';
       8: CifrToStr := 'восемьсот';
       9: CifrToStr := 'девятьсот';
       0: CifrToStr := '';
     end
   else if Pr = 2 then
     case i of
       1: CifrToStr := '';
       2: CifrToStr := 'двадцать';
       3: CifrToStr := 'тридцать';
       4: CifrToStr := 'сорок';
       5: CifrToStr := 'пятьдесят';
       6: CifrToStr := 'шестьдесят';
       7: CifrToStr := 'семьдесят';
       8: CifrToStr := 'восемьдесят';
       9: CifrToStr := 'девяносто';
       0: CifrToStr := '';
     end
   else if Pr = 3 then
     case i of
       1: if Padeg = 1 then
           CifrToStr := 'один'
         else
           CifrToStr := 'одна';
       2: if Padeg = 1 then
           CifrToStr := 'два'
         else
           CifrToStr := 'две';
       3: CifrToStr := 'три';
       4: CifrToStr := 'четыре';
       5: CifrToStr := 'пять';
       6: CifrToStr := 'шесть';
       7: CifrToStr := 'семь';
       8: CifrToStr := 'восемь';
       9: CifrToStr := 'девять';
       0: CifrToStr := '';
     end
   else if Pr = 4 then
     case i of
       1: CifrToStr := 'одиннадцать';
       2: CifrToStr := 'двенадцать';
       3: CifrToStr := 'тринадцать';
       4: CifrToStr := 'четырнадцать';
       5: CifrToStr := 'пятнадцать';
       6: CifrToStr := 'шестнадцать';
       7: CifrToStr := 'семнадцать';
       8: CifrToStr := 'восемнадцать';
       9: CifrToStr := 'девятнадцать';
       0: CifrToStr := 'десять';
 
     end;
 end;
 
 function Rasryad(K: Integer; V: string): string;
 {Функция возвращает наименование разряда в зависимости от последних 2 цифр его}
 var
   j: Integer;
 begin
 
   j := StrToInt(Copy(v, Length(v), 1));
   if (StrToInt(Copy(v, Length(v) - 1, 2)) > 9) and (StrToInt(Copy(v, Length(v) -
     1, 2)) < 20) then
     case K of
       0: Rasryad := '';
       1: Rasryad := 'тысяч';
       2: Rasryad := 'миллионов';
       3: Rasryad := 'миллиардов';
       4: Rasryad := 'триллионов';
     end
   else
     case K of
       0: Rasryad := '';
       1: case j of
           1: Rasryad := 'тысяча';
           2..4: Rasryad := 'тысячи';
         else
           Rasryad := 'тысяч';
         end;
       2: case j of
           1: Rasryad := 'миллион';
           2..4: Rasryad := 'миллионa';
         else
           Rasryad := 'миллионов';
         end;
       3: case j of
           1: Rasryad := 'миллиард';
           2..4: Rasryad := 'миллиарда';
         else
           Rasryad := 'миллиардов';
         end;
       4: case j of
           1: Rasryad := 'триллион';
           2..4: Rasryad := 'триллиона';
         else
           Rasryad := 'триллионов';
         end;
     end;
 end;
 
 function GroupToStr(Group: string; Padeg: Integer): string;
 {Функция возвращает прописью 3 цифры}
 var
   i: Integer;
 
   S: string;
 begin
 
   S := '';
   if (StrToInt(Copy(Group, Length(Group) - 1, 2)) > 9) and (StrToInt(Copy(Group,
     Length(Group) - 1, 2)) < 20) then
   begin
     if Length(Group) = 3 then
       S := S + ' ' + CifrToStr(Copy(Group, 1, 1), 1, Padeg);
     S := S + ' ' + CifrToStr(Copy(Group, Length(Group), 1), 4, Padeg);
   end
   else
     for i := 1 to Length(Group) do
       S := S + ' ' + CifrToStr(Copy(Group, i, 1), i - Length(Group) + 3, Padeg);
   GroupToStr := S;
 end;
 
 {Функция возвращает сумму прописью}
 
 function RubToStr(Rubs: Currency; Rub, Kop: string): string;
 var
   i, j: Integer;
 
   R, K, S: string;
 begin
 
   S := CurrToStr(Rubs);
   S := Trim(S);
   if Pos(',', S) = 0 then
   begin
     R := S;
     K := '00';
   end
   else
   begin
     R := Copy(S, 0, (Pos(',', S) - 1));
     K := Copy(S, (Pos(',', S) + 1), Length(S));
   end;
 
   S := '';
   i := 0;
   j := 1;
   while Length(R) > 3 do
   begin
     if i = 1 then
       j := 2
     else
       j := 1;
     S := GroupToStr(Copy(R, Length(R) - 2, 3), j) + ' ' + Rasryad(i, Copy(R,
       Length(R) - 2, 3)) + ' ' + S;
     R := Copy(R, 1, Length(R) - 3);
     i := i + 1;
   end;
   if i = 1 then
     j := 2
   else
     j := 1;
   S := Trim(GroupToStr(R, j) + ' ' + Rasryad(i, R) + ' ' + S + ' ' + Rub + ' ' +
     K + ' ' + Kop);
   S := ANSIUpperCase(Copy(S, 1, 1)) + Copy(S, 2, Length(S) - 1);
   RubToStr := S;
 end;
 




Сумма прописью - Способ 9


 unit Numinwrd;
 
 interface
 function sMoneyInWords(Nin: currency): string; export;
 function szMoneyInWords(Nin: currency): PChar; export;
 
 { Денежная сумма Nin в рублях и копейках прописью
 1997, в.2.1, by О.В.Болдырев}
 
 implementation
 uses SysUtils, Dialogs, Math;
 
 type
 
   tri = string[4];
   mood = 1..2;
   gender = (m, f);
   uns = array[0..9] of string[7];
   tns = array[0..9] of string[13];
   decs = array[0..9] of string[12];
   huns = array[0..9] of string[10];
   nums = array[0..4] of string[8];
   money = array[1..2] of string[5];
   endings = array[gender, mood, 1..3] of tri; {окончания числительных и денег}
 
 const
 
   units: uns = ('', 'один ', 'два ', 'три ', 'четыре ', 'пять ',
     'шесть ', 'семь ', 'восемь ', 'девять ');
   unitsf: uns = ('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ',
     'шесть ', 'семь ', 'восемь ', 'девять ');
   teens: tns = ('десять ', 'одиннадцать ', 'двенадцать ', 'тринадцать ',
     'четырнадцать ', 'пятнадцать ', 'шестнадцать ',
     'семнадцать ', 'восемнадцать ', 'девятнадцать ');
   decades: decs = ('', 'десять ', 'двадцать ', 'тридцать ', 'сорок ',
     'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ',
     'девяносто ');
   hundreds: huns = ('', 'сто ', 'двести ', 'триста ', 'четыреста ',
     'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
     'девятьсот ');
   numericals: nums = ('', 'тысяч', 'миллион', 'миллиард', 'триллион');
   RusMon: money = ('рубл', 'копе');
   ends: endings = ((('', 'а', 'ов'), ('ь', 'я', 'ей')),
     (('а', 'и', ''), ('йка', 'йки', 'ек')));
 threadvar
 
   str: string;
 
 function EndingIndex(Arg: integer): integer;
 begin
 
   if ((Arg div 10) mod 10) <> 1 then
     case (Arg mod 10) of
       1: Result := 1;
       2..4: Result := 2;
     else
       Result := 3;
     end
   else
     Result := 3;
 end;
 
 function sMoneyInWords(Nin: currency): string;
   { Число Nin прописью, как функция }
 var
   //  str: string;
 
   g: gender; //род
   Nr: comp; {целая часть числа}
   Fr: integer; {дробная часть числа}
   i, iTri, Order: longint; {триада}
 
   procedure Triad;
   var
     iTri2: integer;
     un, de, ce: byte; //единицы, десятки, сотни
 
     function GetDigit: byte;
     begin
       Result := iTri2 mod 10;
       iTri2 := iTri2 div 10;
     end;
 
   begin
     iTri := trunc(Nr / IntPower(1000, i));
     Nr := Nr - int(iTri * IntPower(1000, i));
     iTri2 := iTri;
     if iTri > 0 then
     begin
       un := GetDigit;
       de := GetDigit;
       ce := GetDigit;
       if i = 1 then
         g := f
       else
         g := m; {женского рода только тысяча}
 
       str := TrimRight(str) + ' ' + Hundreds[ce];
       if de = 1 then
         str := TrimRight(str) + ' ' + Teens[un]
       else
       begin
         str := TrimRight(str) + ' ' + Decades[de];
         case g of
           m: str := TrimRight(str) + ' ' + Units[un];
           f: str := TrimRight(str) + ' ' + UnitsF[un];
         end;
       end;
 
       if length(numericals[i]) > 1 then
       begin
         str := TrimRight(str) + ' ' + numericals[i];
         str := TrimRight(str) + ends[g, 1, EndingIndex(iTri)];
       end;
     end; //triad is 0 ?
 
     if i = 0 then
       Exit;
     Dec(i);
     Triad;
   end;
 
 begin
 
   str := '';
   Nr := int(Nin);
   Fr := round(Nin * 100 + 0.00000001) mod 100;
   if Nr > 0 then
     Order := trunc(Log10(Nr) / 3)
   else
   begin
     str := 'ноль';
     Order := 0
   end;
   if Order > High(numericals) then
     raise Exception.Create('Слишком большое число для суммы прописью');
   i := Order;
   Triad;
   str :=
     Format('%s %s%s %.2d %s%s', [Trim(str), RusMon[1], ends[m, 2,
       EndingIndex(iTri)],
     Fr, RusMon[2], ends[f, 2, EndingIndex(Fr)]]);
   str[1] := (ANSIUpperCase(copy(str, 1, 1)))[1];
   str[Length(str) + 1] := #0;
   Result := str;
 end;
 
 function szMoneyInWords(Nin: currency): PChar;
 begin
 
   sMoneyInWords(Nin);
   Result := @(str[1]);
 end;
 
 end.
 




Определение восхода и захода солнца и луны

Автор: Александр Ермолаев

sunproject.dpr


 program sunproject;
 
 uses
   Forms,
   main in 'main.pas' {Sun};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.Title := 'Sun';
   Application.CreateForm(TSun, Sun);
   Application.Run;
 end.
 

main.dfm


 object Sun: TSun
   Left = 210
     Top = 106
     BorderIcons = [biSystemMenu, biMinimize]
     BorderStyle = bsSingle
     Caption = 'Sun'
     ClientHeight = 257
     ClientWidth = 299
     Color = clBtnFace
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     OldCreateOrder = False
     Position = poDesktopCenter
     OnCreate = CreateForm
     PixelsPerInch = 96
     TextHeight = 13
     object GroupBoxInput: TGroupBox
     Left = 4
       Top = 4
       Width = 173
       Height = 93
       Caption = ' Ввод '
       TabOrder = 0
       object LabelLongitude: TLabel
       Left = 35
         Top = 44
         Width = 78
         Height = 13
         Alignment = taRightJustify
         Caption = 'Долгота (град):'
     end
     object LabelTimeZone: TLabel
       Left = 13
         Top = 68
         Width = 100
         Height = 13
         Alignment = taRightJustify
         Caption = 'Часовая зона (час):'
     end
     object LabelAtitude: TLabel
       Left = 40
         Top = 20
         Width = 73
         Height = 13
         Alignment = taRightJustify
         Caption = 'Широта (град):'
     end
     object EditB5: TEdit
       Tag = 1
         Left = 120
         Top = 16
         Width = 37
         Height = 21
         TabOrder = 0
         Text = '0'
     end
     object EditL5: TEdit
       Tag = 2
         Left = 120
         Top = 40
         Width = 37
         Height = 21
         TabOrder = 1
         Text = '0'
     end
     object EditH: TEdit
       Tag = 3
         Left = 120
         Top = 64
         Width = 37
         Height = 21
         TabOrder = 2
         Text = '0'
     end
   end
   object GroupBoxCalendar: TGroupBox
     Left = 184
       Top = 4
       Width = 109
       Height = 93
       Caption = ' Календарь '
       TabOrder = 1
       object LabelD: TLabel
       Left = 19
         Top = 20
         Width = 30
         Height = 13
         Alignment = taRightJustify
         Caption = 'День:'
     end
     object LabelM: TLabel
       Left = 13
         Top = 44
         Width = 36
         Height = 13
         Alignment = taRightJustify
         Caption = 'Месяц:'
     end
     object LabelY: TLabel
       Left = 28
         Top = 68
         Width = 21
         Height = 13
         Alignment = taRightJustify
         Caption = 'Год:'
     end
     object EditD: TEdit
       Tag = 1
         Left = 56
         Top = 16
         Width = 37
         Height = 21
         TabOrder = 0
         Text = '0'
     end
     object EditM: TEdit
       Tag = 2
         Left = 56
         Top = 40
         Width = 37
         Height = 21
         TabOrder = 1
         Text = '0'
     end
     object EditY: TEdit
       Tag = 3
         Left = 56
         Top = 64
         Width = 37
         Height = 21
         TabOrder = 2
         Text = '0'
     end
   end
   object ButtonCalc: TButton
     Left = 12
       Top = 227
       Width = 169
       Height = 25
       Caption = '&Вычислить'
       TabOrder = 2
       OnClick = ButtonCalcClick
   end
   object ListBox: TListBox
     Left = 4
       Top = 104
       Width = 289
       Height = 117
       ItemHeight = 13
       TabOrder = 3
   end
   object ButtonClear: TButton
     Left = 192
       Top = 227
       Width = 91
       Height = 25
       Caption = '&Очистить'
       TabOrder = 4
       OnClick = ButtonClearClick
   end
 end
 

main.pas


 {
 Программа вычисляет время восхода и захода
 солнца по дате (с точностью до минуты) в пределах
 нескольких текущих столетий. Производит корректировку, если
 географическая
 
 точка находится в арктическом или антарктическом регионе, где заход
 или восход солнца
 
 на текущую дату может не состояться. Вводимые данные: положительная
 северная широта и
 
 отрицательная западная долгота. Часовой пояс указывается относительно
 Гринвича
 
 (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в
 "Sky & Telescope" за август 1994, страница 84.
 
 }
 
 unit main;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,
 
   StdCtrls;
 
 type
 
   TSun = class(TForm)
     GroupBoxInput: TGroupBox;
     LabelLongitude: TLabel;
     EditB5: TEdit;
     EditL5: TEdit;
     LabelTimeZone: TLabel;
     EditH: TEdit;
     GroupBoxCalendar: TGroupBox;
     LabelD: TLabel;
     LabelM: TLabel;
     LabelY: TLabel;
     EditD: TEdit;
     EditM: TEdit;
     EditY: TEdit;
     ButtonCalc: TButton;
     ListBox: TListBox;
     ButtonClear: TButton;
     LabelAtitude: TLabel;
     procedure Calendar; // Календарь
     procedure GetTimeZone; // Получение часового пояса
     procedure PosOfSun; // Получаем положение солнца
     procedure OutInform; // Процедура вывода информации
     procedure PossibleEvents(Hour: integer); // Возможные события на
     полученный час
 
     procedure GetDate; //Получить значения даты
     procedure GetInput; //Получить значения широты,...
     procedure ButtonCalcClick(Sender: TObject);
     procedure CreateForm(Sender: TObject);
     procedure ButtonClearClick(Sender: TObject);
   private
     function Sgn(Value: Double): integer; // Сигнум
   public
     { Public declarations }
   end;
 
 var
 
   Sun: TSun;
   st: string;
   aA, aD: array[1..2] of double;
   B5: integer;
   L5: double;
   H: integer;
   Z, Z0, Z1: double;
   D: double;
   M, Y: integer;
   A5, D5, R5: double;
   J3: integer;
   T, T0, TT, T3: double;
   L0, L2: double;
   H0, H1, H2, H7, N7, D7: double;
   H3, M3: integer;
   M8, W8: double;
   A, B, A0, D0, A2, D1, D2, DA, DD: double;
   E, F, J, S, C, P, L, G, V, U, W: double;
   V0, V1, V2: double;
   C0: integer;
   AZ: double;
 
 const
 
   P2 = Pi * 2; // 2 * Pi
   DR = Pi / 180; // Радиан на градус
   K1 = 15 * DR * 1.0027379;
 
 implementation
 
 {$R *.DFM}
 
 function TSun.Sgn(Value: Double): integer;
 begin
 
   {if Value = 0 then} Result := 0;
   if Value > 0 then
     Result := 1;
   if Value < 0 then
     Result := -1;
 end;
 
 procedure TSun.Calendar;
 begin
 
   G := 1;
   if Y < 1583 then
     G := 0;
   D1 := Trunc(D);
   F := D - D1 - 0.5;
   J := -Trunc(7 * (Trunc((M + 9) / 12) + Y) / 4);
   if G = 1 then
   begin
     S := Sgn(M - 9);
     A := Abs(M - 9);
     J3 := Trunc(Y + S * Trunc(A / 7));
     J3 := -Trunc((Trunc(J3 / 100) + 1) * 3 / 4);
   end;
   J := J + Trunc(275 * M / 9) + D1 + G * J3;
   J := J + 1721027 + 2 * G + 367 * Y;
   if F >= 0 then
     Exit;
   F := F + 1;
   J := J - 1;
 end;
 
 procedure TSun.GetTimeZone;
 begin
 
   T0 := T / 36525;
   S := 24110.5 + 8640184.813 * T0;
   S := S + 86636.6 * Z0 + 86400 * L5;
   S := S / 86400;
   S := S - Trunc(S);
   T0 := S * 360 * DR;
 end;
 
 procedure TSun.PosOfSun;
 begin
 
   //      Фундаментальные константы
   //  (Van Flandern & Pulkkinen, 1979)
   L := 0.779072 + 0.00273790931 * T;
   G := 0.993126 + 0.0027377785 * T;
   L := L - Trunc(L);
   G := G - Trunc(G);
   L := L * P2;
   G := G * P2;
   V := 0.39785 * Sin(L);
   V := V - 0.01000 * Sin(L - G);
   V := V + 0.00333 * Sin(L + G);
   V := V - 0.00021 * TT * Sin(L);
   U := 1 - 0.03349 * Cos(G);
   U := U - 0.00014 * Cos(2 * L);
   U := U + 0.00008 * Cos(L);
   W := -0.00010 - 0.04129 * Sin(2 * L);
   W := W + 0.03211 * Sin(G);
   W := W + 0.00104 * Sin(2 * L - G);
   W := W - 0.00035 * Sin(2 * L + G);
   W := W - 0.00008 * TT * Sin(G);
 
   // Вычисление солнечных координат
   S := W / Sqrt(U - V * V);
   A5 := L + ArcTan(S / Sqrt(1 - S * S));
   S := V / Sqrt(U);
   D5 := ArcTan(S / Sqrt(1 - S * S));
   R5 := 1.00021 * Sqrt(U);
 end;
 
 procedure TSun.PossibleEvents(Hour: integer);
 var
   num: string;
 begin
 
   st := '';
   L0 := T0 + Hour * K1;
   L2 := L0 + K1;
   H0 := L0 - A0;
   H2 := L2 - A2;
   H1 := (H2 + H0) / 2; // Часовой угол,
   D1 := (D2 + D0) / 2; // наклон в получасе
   if Hour <= 0 then
     V0 := S * Sin(D0) + C * Cos(D0) * Cos(H0) - Z;
   V2 := S * Sin(D2) + C * Cos(D2) * Cos(H2) - Z;
   if Sgn(V0) = Sgn(V2) then
     Exit;
   V1 := S * Sin(D1) + C * Cos(D1) * Cos(H1) - Z;
   A := 2 * V2 - 4 * V1 + 2 * V0;
   B := 4 * V1 - 3 * V0 - V2;
   D := B * B - 4 * A * V0;
   if D < 0 then
     Exit;
   D := Sqrt(D);
   if (V0 < 0) and (V2 > 0) then
     st := st + 'Восход солнца в ';
   if (V0 < 0) and (V2 > 0) then
     M8 := 1;
   if (V0 > 0) and (V2 < 0) then
     st := st + 'Заход солнца в ';
   if (V0 > 0) and (V2 < 0) then
     W8 := 1;
   E := (-B + D) / (2 * A);
   if (E > 1) or (E < 0) then
     E := (-B - D) / (2 * A);
   T3 := Hour + E + 1 / 120; // Округление
   H3 := Trunc(T3);
   M3 := Trunc((T3 - H3) * 60);
   Str(H3: 2, num);
   st := st + num + ':';
   Str(M3: 2, num);
   st := st + num;
   H7 := H0 + E * (H2 - H0);
   N7 := -Cos(D1) * Sin(H7);
   D7 := C * Sin(D1) - S * Cos(D1) * COS(H7);
   AZ := ArcTan(N7 / D7) / DR;
   if (D7 < 0) then
     AZ := AZ + 180;
   if (AZ < 0) then
     AZ := AZ + 360;
   if (AZ > 360) then
     AZ := AZ - 360;
   Str(AZ: 4: 1, num);
   st := st + ', азимут ' + num;
 end;
 
 procedure TSun.OutInform;
 begin
 
   if (M8 = 0) and (W8 = 0) then
   begin
     if V2 < 0 then
       ListBox.Items.Add('Солнце заходит весь день ');
     if V2 > 0 then
       ListBox.Items.Add('Солнце восходит весь день ');
   end
   else
   begin
     if M8 = 0 then
       ListBox.Items.Add('В этот день солнце не восходит ');
     if W8 = 0 then
       ListBox.Items.Add('В этот день солнце не заходит ');
   end;
 end;
 
 procedure TSun.GetDate;
 begin
 
   D := StrToInt(EditD.text);
   M := StrToInt(EditM.text);
   Y := StrToInt(EditY.text);
 end;
 
 procedure TSun.GetInput;
 begin
 
   B5 := StrToInt(EditB5.Text);
   L5 := StrToInt(EditL5.Text);
   H := StrToInt(EditH.Text);
 end;
 
 procedure TSun.ButtonCalcClick(Sender: TObject);
 var
   C0: integer;
 begin
 
   GetDate;
   GetInput;
   ListBox.Items.Add('Широта: ' + EditB5.Text +
     ' Долгота: ' + EditL5.Text +
     ' Зона: ' + EditH.Text +
     ' Дата: ' + EditD.Text +
     '/' + EditM.Text +
     '/' + EditY.Text);
   L5 := L5 / 360;
   Z0 := H / 24;
   Calendar;
   T := (J - 2451545) + F;
   TT := T / 36525 + 1; // TT - столетия, начиная с 1900.0
   GetTimeZone; // Получение часового пояса
   T := T + Z0;
   PosOfSun; // Получаем положение солнца
   aA[1] := A5;
   aD[1] := D5;
   T := T + 1;
   PosOfSun;
   aA[2] := A5;
   aD[2] := D5;
   if aA[2] < aA[1] then
     aA[2] := aA[2] + P2;
   Z1 := DR * 90.833; // Вычисление зенита
   S := Sin(B5 * DR);
   C := Cos(B5 * DR);
   Z := Cos(Z1);
   M8 := 0;
   W8 := 0;
   A0 := aA[1];
   D0 := aD[1];
   DA := aA[2] - aA[1];
   DD := aD[2] - aD[1];
   for C0 := 0 to 23 do
   begin
     P := (C0 + 1) / 24;
     A2 := aA[1] + P * DA;
     D2 := aD[1] + P * DD;
     PossibleEvents(C0);
     if st <> '' then
       ListBox.Items.Add(st);
     A0 := A2;
     D0 := D2;
     V0 := V2;
   end;
   OutInform;
   ListBox.Items.Add(''); // Разделяем данные
 end;
 
 procedure TSun.CreateForm(Sender: TObject);
 begin
 
   EditD.Text := FormatDateTime('d', Date);
   EditM.Text := FormatDateTime('m', Date);
   EditY.Text := FormatDateTime('yyyy', Date);
 end;
 
 procedure TSun.ButtonClearClick(Sender: TObject);
 begin
   ListBox.Clear;
 end;
 
 end.
 




Поддержка многоязычного интерфейса

Программирование на С++ у госслужащих - как секс у подростков:
- все об этом думают;
- все об этом говорят;
- все думают, что их ближний это делает;
- почти никто этого не делает;
- тот, кто это делает, делает это плохо;
- все думают, что в следующий раз лучше получится;
- никто не принимает мер безопасности;
- любому стыдно признаться в том, что он чего-то не знает;
- если у кого-то что-то получается, от этого всегда много шума.

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

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

Для поддержки нескольких языков предлагается следующий простой подход. Интерфейс оформляется на родном языке - русском. Для всех остальных языков составляется словарь в виде:


 Строка на языке 1=Строка на языке 2
 Строка на языке 1=Строка на языке 2
 

Например:


 Файл=File
 Выход=Exit
 Отмена=Cancel
 

И так для всех ресурсов приложения. Словарь поместим в отдельный текстовый файл.

Далее, нам необходимо для каждого текстового свойства любого компонента приложения поискать перевод в нашем словаре. Здесь не обойтись без Delphi RTTI. Через Component.ClassInfo получим ссылку на информацию типа, а затем GetTypeData(TypeInf) даст нам указатель на структуру с его описанием.


 TypeInf := Component.ClassInfo;
 AName := TypeInf^.name;
 TypeData := GetTypeData(TypeInf);
 NumProps := TypeData^.PropCount;
 

Далее проходимся по всем свойствам данного (классового) типа:


 GetMem(PropList, NumProps * sizeof(pointer));
 
 try
   GetPropInfos(TypeInf, PropList);
 
   for i := 0 to NumProps-1 do
   begin
     PropName := PropList^[i]^.name;
 
     PropTypeInf := PropList^[i]^.PropType^;
     PropInfo := PropList^[i];
 
 
     case PropTypeInf^.Kind of
       tkString, tkLString: //... это то, что нам нужно
         if PropName <> 'Name' then { Переводить свойство Name не следует }
         begin
           { Получение значения свойства и поиск перевода в словаре }
           StringPropValue := GetStrProp(Component, PropInfo);
           SetStrProp(Component, PropInfo, TranslateString(StringPropValue));
         end;
 ...
 ...
 

Отдельный случай - списки TStrings и коллекции типа TTReeNodes и TListItems. Их придется обработать персонально.


 tkClass:
 begin
   PropObject := GetObjectProp(Component, PropInfo{, TPersistent});
 
   if Assigned(PropObject)then
   begin
     { Для дочерних свойств-классов вызов просмотра свойств }
     if (PropObject is TPersistent) then
       UpdateComponent(PropObject as TPersistent);
 
     { Индивидуальный подход к некоторым классам }
     if (PropObject is TStrings) then
     begin
       for j := 0 to (PropObject as TStrings).Count-1 do
         TStrings(PropObject)[j] := TranslateString(TStrings(PropObject)[j]);
     end;
     if (PropObject is TTreeNodes) then
     begin
       for j := 0 to (PropObject as TTreeNodes).Count-1 do
         TTreeNodes(PropObject).Item[j].Text :=
         TranslateString(TTreeNodes(PropObject).Item[j].Text);
     end;
     if (PropObject is TListItems) then
     begin
       for j := 0 to (PropObject as TListItems).Count-1 do
         TListItems(PropObject).Item[j].Caption
         := TranslateString(TListItems(PropObject).Item[j].Caption);
     end;
 { Здесь можно добавить обработку остальных классов }
 end;
 
 end;
 

Объединяя все написанное, получим компонент для перевода строковых ресурсов.


 unit glLanguageLoader;
 
 interface
 {$I glDEF.INC}
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, comctrls, grids;
 
 type
   TLanguageLoaderOptions = set of (lofTrimSpaces);
   {опция удаления начальных и завершающих пробелов}
 
   TglLanguageLoader = class(TComponent)
   private
     sl: TStringList;
     FOptions: TLanguageLoaderOptions;
     function TranslateString(sString: string): string;
   protected
     procedure UpdateComponent(Component: TPersistent); virtual;
   public
     {main function}
     procedure LoadLanguage(Component: TComponent; FileName: string);
   published
     property Options: TLanguageLoaderOptions read FOptions write FOptions;
   end;
 
   procedure LoadLanguage(Component: TComponent; FileName: string;
   Options: TLanguageLoaderOptions);
   procedure register;
 
 implementation
 
 uses
   TypInfo, dsgnintf;
 
 procedure register;
 begin
   RegisterComponents('Gl Components', [TglLanguageLoader]);
 end;
 
 {Ф-ия для загрузки словаря без предварительного создания компонента}
 procedure LoadLanguage(Component: TComponent; FileName: string;
 Options: TLanguageLoaderOptions);
 var
   LanguageLoader: TglLanguageLoader;
 begin
   LanguageLoader := TglLanguageLoader.Create(nil);
   try
     LanguageLoader.LoadLanguage(Component, FileName);
   finally
     LanguageLoader.Free;
   end;
 end;
 
 { TglLanguageLoader }
 
 { Загрузка словаря, обход указанного компонента и }
 { всех его дочерних компонентов }
 procedure TglLanguageLoader.LoadLanguage(Component: TComponent; FileName: string);
 
   procedure UpdateAllComponents(Component: TComponent);
   var
     i: integer;
   begin
     { обработка своцств компонента }
     UpdateComponent(Component);
     for i := 0 to Component.ComponentCount-1 do
       UpdateAllComponents(Component.Components[i]);
   end;
 
 begin
   sl := TStringList.Create;
   try
     { Загрузка словаря из заданного файла }
     sl.LoadFromFile(FileName);
     sl.Sorted := true;
     UpdateAllComponents(Component);
   finally
     sl.Free;
   end;
 end;
 
 { Проход по всем свойствам компонента }
 { Для всех строковых свойств - загрузка перевода из сооваря }
 procedure TglLanguageLoader.UpdateComponent(Component: TPersistent);
 var
   PropInfo: PPropInfo;
   TypeInf, PropTypeInf: PTypeInfo;
   TypeData: PTypeData;
   i, j: integer;
   AName, PropName, StringPropValue: string;
   PropList: PPropList;
   NumProps: word;
   PropObject: TObject;
 begin
   { Playing with RTTI }
   TypeInf := Component.ClassInfo;
   AName := TypeInf^.name;
   TypeData := GetTypeData(TypeInf);
   NumProps := TypeData^.PropCount;
 
   GetMem(PropList, NumProps*sizeof(pointer));
 
   try
     GetPropInfos(TypeInf, PropList);
 
     for i := 0 to NumProps-1 do
     begin
       PropName := PropList^[i]^.name;
 
       PropTypeInf := PropList^[i]^.PropType^;
       PropInfo := PropList^[i];
 
 
       case PropTypeInf^.Kind of
         tkString, tkLString:
           if PropName <> 'Name' then { Переводить свойство Name не следует }
           begin
             { Получение значения свойства и поиск перевода в словаре }
             StringPropValue := GetStrProp( Component, PropInfo );
             SetStrProp( Component, PropInfo, TranslateString(StringPropValue) );
           end;
         tkClass:
         begin
           PropObject := GetObjectProp(Component, PropInfo{, TPersistent});
           if Assigned(PropObject)then
           begin
             { Для дочерних свойств-классов вызов просмотра свойств }
             if (PropObject is TPersistent) then
               UpdateComponent(PropObject as TPersistent);
 
             { Индивидуальный подход к некоторым классам }
             if (PropObject is TStrings) then
             begin
               for j := 0 to (PropObject as TStrings).Count-1 do
                 TStrings(PropObject)[j] := TranslateString(TStrings(PropObject)[j]);
             end;
             if (PropObject is TTreeNodes) then
             begin
               for j := 0 to (PropObject as TTreeNodes).Count-1 do
                 TTreeNodes(PropObject).Item[j].Text :=
                 TranslateString(TTreeNodes(PropObject).Item[j].Text);
             end;
             if (PropObject is TListItems) then
             begin
               for j := 0 to (PropObject as TListItems).Count-1 do
                 TListItems(PropObject).Item[j].Caption :=
                 TranslateString(TListItems(PropObject).Item[j].Caption);
             end;
             { Здесь можно добавить обработку остальных классов }
           end;
         end;
       end;
     end;
   finally
     FreeMem(PropList, NumProps*sizeof(pointer));
   end;
 end;
 
 { Поиск перевода для заданной строки в словаре }
 function TglLanguageLoader.TranslateString(sString: string): string;
 begin
   if lofTrimSpaces in Options then
     sString := trim(sString);
   if sString = '' then
   begin
     Result := '';
     exit;
   end;
   if sl.IndexOfName(sString) <> -1 then
     Result := sl.Values[sString]
   else
     Result := sString;
 end;
 
 end.
 




Как узнать все форматы бумаги, поддерживаемые принтером по умолчанию

Ниже представлена процедура, которая имеет в качестве параметра любой объект StringList - Строки для Memo, Пункты Combo и т.д.


 procedure GetPaperFormats(aSL: TStringList);
 type
   TPaperName = array[0..63] of Char;
   TPaperNameArray = array[1..High(Cardinal) div
     Sizeof(TPaperName)] of
     TPaperName;
   PPapernameArray = ^TPaperNameArray;
 var
   Device, Driver, Port: array[0..255] of Char;
   hDevMode: THandle;
   i, numPaperformats: Integer;
   pPaperFormats: PPapernameArray;
 begin
   Printer.PrinterIndex := -1;
   Printer.GetPrinter(Device, Driver, Port, hDevmode);
   numPaperformats :=
     WinSpool.DeviceCapabilities(
     Device, Port, DC_PAPERNAMES, nil, nil);
   if numPaperformats > 0 then
   begin
     GetMem(pPaperformats,
       numPaperformats *
       Sizeof(TPapername));
     try
       WinSpool.DeviceCapabilities
         (Device, Port, DC_PAPERNAMES,
         Pchar(pPaperFormats), nil);
       aSL.clear;
       for i := 1 to numPaperformats do
         aSL.lines.add(pPaperformats^[i]);
     finally
       FreeMem(pPaperformats);
     end;
   end;
 end;
 

Использование:


 GetPaperFormats(Memo1.Lines);
 




Как поменять функции кнопок мышки

Хакер читает внуку сказку:
- ... стал он кликать золотую рыбку.
- А почему рыбку?
- А потому, дружок, что мышек, тогда еще не было.


 begin
   SwapMouseButton(true);  // Поменять
   SwapMouseButton(false); // Поменять обратно
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS