TMenuItem - создание и добавление событий во время работы приложения

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

... ppmProgram: TMenuItem; Private procedure PopulateMenu(Sender: TObject); procedure NewShortcutClick(Sender: TObject); ... procedure TForm1.PopulateMenu(Sender: TObject); var ppmAddNewShortcut : TMenuItem; begin ppmAddNewShortcut         := TMenuItem.Create(Self); ppmAddNewShortcut.Caption := '&Тест'; ppmAddNewShortcut.OnClick := NewShortcutClick; ppmProgram.Add(ppmAddNewShortcut); end; procedure TForm1.NewShortcutClick(Sender: TObject); begin { Здесь введите код для "Тест" } end;

[001623]

Битный CRC

Приведен модуль для Delphi 1.0 (для Delphi 2.0 должны быть сделаны небольшие изменения):

UNIT CRC32; {CRC32 рассчитывает код циклической избыточности (cyclic redundancy code - CRC), известный как CRC-32, с использованием алгоритма byte-wise ("мудрый байт"). (C) Авторские права 1989, 1995-1996 Earl F. Glynn, Overland Park, KS. Все права защищены. Данный модуль является производным от программы CRCT FORTRAN 77, опубликованной в "Byte-wise CRC Calculations" за авторством Aram Perez из IEEE Micro, Июнь 1983, страницы 40-50. Константы для полиномиального генератора CRC-32, приведенные здесь, опубликованы в "Microsoft Systems Journal", Март 1995, страницы 107-108. Данный CRC алгоритм имеет бОльшую скорость за счет 512 элементов таблицы поиска.} INTERFACE PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt); PROCEDURE CalcFileCRC32 (FromName: STRING; VAR CRCvalue: LongInt; VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt; VAR error:  WORD); IMPLEMENTATION CONST table:  ARRAY[0..255] OF LongInt = ($00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D); TYPE buffer = ARRAY[1..65521] OF BYTE;  { самый большой буфер, который     } { только можно распределить в Куче } VAR i:  WORD; q:  ^buffer; PROCEDURE CalcCRC32 (p:  pointer; nbyte:  WORD; VAR CRCvalue:  LongInt); {Ниже выполняется небольшое криптование (но выполняется очень быстро). Алгоритм работает следующим образом: 1.  совершаем операцию "И/ИЛИ" (XOR) входного байта с младшей частью регистра CRC для получения INDEX 2.  сдвигаем регистр CRC на восемь битов вправо 3.  совершаем операцию "И/ИЛИ" (XOR) с CRC регистром и Table[INDEX] 4.  повторяем шаги с 1 по 3 для всех байтов } BEGIN q := p; FOR   i := 1 TO nBYTE DO CRCvalue := (CRCvalue SHR 8)  XOR Table[ q^[i] XOR (CRCvalue AND $000000FF) ] END {CalcCRC32}; PROCEDURE CalcFileCRC32 (FromName:  STRING; VAR CRCvalue:  LongInt; VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:  LongInt; VAR error:  WORD); VAR BytesRead:  WORD; FromFile :  FILE; i        :  WORD; BEGIN FileMode := 0;  {Turbo по умолчанию 2 для R/W и 0 для R/O} CRCValue := $FFFFFFFF; ASSIGN (FromFile,FromName); {$I-} RESET (FromFile,1); {$I+} error := IOResult; IF   error = 0 THEN BEGIN TotalBytes := 0; REPEAT BlockRead (FromFile,IOBuffer^,BufferSize,BytesRead); CalcCRC32 (IOBuffer,BytesRead,CRCvalue); INC (TotalBytes, BytesRead) UNTIL BytesRead = 0; CLOSE (FromFile) END; CRCvalue := NOT CRCvalue END {CalcFileCRC32}; END {CRC}.

[000156]

Привожу FFT-алгоритм, позволяющий оперировать 256 точками данных примерно за 0.008 секунд на P66 (с 72MB, YMMV). Создан на Delphi.

Данный алгоритм я воспроизвел где-то около года назад. Вероятно он не самый оптимальный, но для повышения скорости расчета наверняка потребуются более мощное аппаратное обеспечение.

Но я не думаю что алгоритм слишком плох, в нем заложено немало математических трюков. Имеется некоторое количество рекурсий, но они занимается не копированием данных, а манипуляциями с указателями, если у нас есть массив размером N = 2^d, то глубина рекурсии составит всего d. Возможно имело бы смысл применить развертывающуюся рекурсию, но не пока не ясно, поможет ли ее применение в данном алгоритме. (Но вероятно мы смогли бы достаточно легко получить надежную математическую модель, развертывая в рекурсии один или два нижних слоя, то есть проще говоря:

if Depth < 2 then {производим какие-либо действия}

вместо текущего 'if Depth = 0 then...' Это должно устранить непродуктивные вызовы функций, что несомненно хорошо в то время, пока развертывающая рекурсия работает с ресурсами.)

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

Вероятно в машине с большим объемом оперативной памяти следует использовать VirtualAlloc(... PAGE_NOCACHE) для Src, Dest и таблиц поиска.

Если кто-либо обнаружит неверную на ваш взгляд или просто непонятную в данном совете функцию пожалуйста сообщите мне об этом.

Что делает данная технология вкратце. Имеется несколько FFT, образующих 'комплексный FT', который понимает и о котором заботится моя технология. Это означает, что если N = 2^d, Src^ и Dest^ образуют массив из N TComplexes, происходит вызов

FFT(d, Src, Dest)

, далее заполняем Dest с применением 'комплексного FT' после того, как результат вызова Dest^[j] будет равен

1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])

, где EiT(t) = cos(t) + i sin(t) . То есть, стандартное преобразование Фурье.

Публикую две версии: в первой версии я использую TComplex с функциями для работы с комплексными числами. Во второй версии все числа реальные - вместо массивов Src и Dest мы используем массивы реальных чисел SrcR, SrcI, DestR, DestI (в блоке вычислений реальных чисел), и вызовы всех функций осуществляются линейно. Первая версия достаточна легка в реализации, зато вторая - значительно быстрее. (Обе версии оперируют 'комплексными FFT'.) Технология работы была опробована на алгоритме Plancherel (также известным как Parseval). Обе версии работоспособны, btw: если это не работает у вас - значит я что-то выбросил вместе со своими глупыми коментариями :-) Итак, сложная версия:

unit cplx; interface type PReal = ^TReal; TReal = extended; PComplex = ^TComplex; TComplex = record r : TReal; i : TReal; end; function MakeComplex(x, y: TReal): TComplex; function Sum(x, y: TComplex) : TComplex; function Difference(x, y: TComplex) : TComplex; function Product(x, y: TComplex): TComplex; function TimesReal(x: TComplex; y: TReal): TComplex; function PlusReal(x: TComplex; y: TReal): TComplex; function EiT(t: TReal):TComplex; function ComplexToStr(x: TComplex): string; function AbsSquared(x: TComplex): TReal; implementation uses SysUtils; function MakeComplex(x, y: TReal): TComplex; begin with result do begin r:=x; i:= y; end; end; function Sum(x, y: TComplex) : TComplex; begin with result do begin r:= x.r + y.r; i:= x.i + y.i; end; end; function Difference(x, y: TComplex) : TComplex; begin with result do begin r:= x.r - y.r; i:= x.i - y.i; end; end; function EiT(t: TReal): TComplex; begin with result do begin r:= cos(t); i:= sin(t); end; end; function Product(x, y: TComplex): TComplex; begin with result do begin r:= x.r * y.r - x.i * y.i; i:= x.r * y.i + x.i * y.r; end; end; function TimesReal(x: TComplex; y: TReal): TComplex; begin with result do begin r:= x.r * y; i:= x.i * y; end; end; function PlusReal(x: TComplex; y: TReal): TComplex; begin with result do begin r:= x.r + y; i:= x.i; end; end; function ComplexToStr(x: TComplex): string; begin result:= FloatToStr(x.r) + ' + ' + FloatToStr(x.i) + 'i'; end; function AbsSquared(x: TComplex): TReal; begin result:= x.r*x.r + x.i*x.i; end; end.

unit cplxfft1; interface uses Cplx; type PScalar = ^TScalar; TScalar = TComplex; {Легко получаем преобразование в реальную величину} PScalars = ^TScalars; TScalars = array[0..High(integer) div SizeOf(TScalar) - 1] of TScalar; const TrigTableDepth: word = 0; TrigTable : PScalars = nil; procedure InitTrigTable(Depth: word); procedure FFT(Depth: word; Src: PScalars; Dest: PScalars); {Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение (integer(1) shl Depth) * SizeOf(TScalar) байт памяти!} implementation procedure DoFFT(Depth: word; Src: PScalars; SrcSpacing: word; Dest: PScalars); {рекурсивная часть, вызываемая при готовности FFT} var j, N: integer; Temp: TScalar; Shift: word; begin if Depth = 0 then begin Dest^[0]:= Src^[0]; exit; end; N:= integer(1) shl (Depth - 1); DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest); DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N] ); Shift:= TrigTableDepth - Depth; for j:= 0 to N - 1 do begin Temp:= Product(TrigTable^[j shl Shift], Dest^[j + N]); Dest^[j + N]:= Difference(Dest^[j], Temp); Dest^[j]    := Sum(Dest^[j], Temp); end; end; procedure FFT(Depth: word; Src: PScalars; Dest: PScalars); var j, N: integer; Normalizer: extended; begin N:= integer(1) shl depth; if Depth  TrigTableDepth then InitTrigTable(Depth); DoFFT(Depth, Src, 1, Dest); Normalizer:= 1 / sqrt(N) ; for j:=0 to N - 1 do Dest^[j]:= TimesReal(Dest^[j], Normalizer); end; procedure InitTrigTable(Depth: word); var j, N: integer; begin N:= integer(1) shl depth; ReAllocMem(TrigTable, N * SizeOf(TScalar)); for j:=0 to N - 1 do TrigTable^[j]:= EiT(-(2*Pi)*j/N); TrigTableDepth:= Depth; end; initialization ; finalization ReAllocMem(TrigTable, 0); end.

unit DemoForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; Edit1: TEdit; Label1: TLabel; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses cplx, cplxfft1, MMSystem; procedure TForm1.Button1Click(Sender: TObject); var j: integer; s:string; src, dest: PScalars; norm: extended; d,N,count:integer; st,et: longint; begin d:= StrToIntDef(edit1.text, -1) ; if d <1 then raise exception.Create('глубина рекурсии должны быть положительным целым числом'); N:= integer(1) shl d ; GetMem(Src, N*Sizeof(TScalar)); GetMem(Dest, N*SizeOf(TScalar)); for j:=0 to N-1 do begin src^[j]:= MakeComplex(random, random); end; begin st:= timeGetTime; FFT(d, Src, dest); et:= timeGetTime; end; Memo1.Lines.Add('N = ' + IntToStr(N)); Memo1.Lines.Add('норма ожидания: ' +#9+ FloatToStr(N*2/3)); norm:=0; for j:=0 to N-1 do norm:= norm + AbsSquared(src^[j]); Memo1.Lines.Add('Норма данных: '+#9+FloatToStr(norm)); norm:=0; for j:=0 to N-1 do norm:= norm + AbsSquared(dest^[j]); Memo1.Lines.Add('Норма FT: '+#9#9+FloatToStr(norm)); Memo1.Lines.Add('Время расчета FFT: '+#9 + inttostr(et - st) + ' мс.'); Memo1.Lines.Add(' '); FreeMem(Src); FreeMem(DEst); end; end.

**** Версия для работы с реальными числами:

unit cplxfft2; interface type PScalar = ^TScalar; TScalar = extended; PScalars = ^TScalars; TScalars = array[0..High(integer) div SizeOf(TScalar) - 1] of TScalar; const TrigTableDepth: word = 0; CosTable : PScalars = nil; SinTable : PScalars = nil; procedure InitTrigTables(Depth: word); procedure FFT(Depth: word; SrcR, SrcI: PScalars; DestR, DestI: PScalars); {Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение (integer(1) shl Depth) * SizeOf(TScalar) байт памяти!} implementation procedure DoFFT(Depth: word; SrcR, SrcI: PScalars; SrcSpacing: word; DestR, DestI: PScalars); {рекурсивная часть, вызываемая при готовности FFT} var j, N: integer; TempR, TempI: TScalar; Shift: word; c, s: extended; begin if Depth = 0 then begin DestR^[0]:= SrcR^[0]; DestI^[0]:= SrcI^[0]; exit; end; N:= integer(1) shl (Depth - 1); DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI); DoFFT(Depth - 1, @SrcR^[srcSpacing], @SrcI^[SrcSpacing], SrcSpacing * 2, @DestR^[N], @DestI^[N]); Shift:= TrigTableDepth - Depth; for j:= 0 to N - 1 do begin c:= CosTable^[j shl Shift]; s:= SinTable^[j shl Shift]; TempR:= c * DestR^[j + N] - s * DestI^[j + N]; TempI:= c * DestI^[j + N] + s * DestR^[j + N]; DestR^[j + N]:= DestR^[j] - TempR; DestI^[j + N]:= DestI^[j] - TempI; DestR^[j]:= DestR^[j] + TempR; DestI^[j]:= DestI^[j] + TempI; end; end; procedure FFT(Depth: word; SrcR, SrcI: PScalars; DestR, DestI: PScalars); var j, N: integer; Normalizer: extended; begin N:= integer(1) shl depth; if Depth  TrigTableDepth then InitTrigTables(Depth); DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI); Normalizer:= 1 / sqrt(N) ; for j:=0 to N - 1 do begin DestR^[j]:= DestR^[j] * Normalizer; DestI^[j]:= DestI^[j] * Normalizer; end; end; procedure InitTrigTables(Depth: word); var j, N: integer; begin N:= integer(1) shl depth; ReAllocMem(CosTable, N * SizeOf(TScalar)); ReAllocMem(SinTable, N * SizeOf(TScalar)); for j:=0 to N - 1 do begin CosTable^[j]:= cos(-(2*Pi)*j/N); SinTable^[j]:= sin(-(2*Pi)*j/N); end; TrigTableDepth:= Depth; end; initialization ; finalization ReAllocMem(CosTable, 0); ReAllocMem(SinTable, 0); end.

unit demofrm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, cplxfft2, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Memo1: TMemo; Edit1: TEdit; Label1: TLabel; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses MMSystem; procedure TForm1.Button1Click(Sender: TObject); var SR, SI, DR, DI: PScalars; j,d,N:integer; st, et: longint; norm: extended; begin d:= StrToIntDef(edit1.text, -1) ; if d <1 then raise exception.Create('глубина рекурсии должны быть положительным целым числом'); N:= integer(1) shl d; GetMem(SR, N * SizeOf(TScalar)); GetMem(SI, N * SizeOf(TScalar)); GetMem(DR, N * SizeOf(TScalar)); GetMem(DI, N * SizeOf(TScalar)); for j:=0 to N - 1 do begin SR^[j]:=random; SI^[j]:=random; end; st:= timeGetTime; FFT(d, SR, SI, DR, DI); et:= timeGetTime; memo1.Lines.Add('N = '+inttostr(N)); memo1.Lines.Add('норма ожидания: '+#9+FloatToStr(N*2/3)); norm:=0; for j:=0 to N - 1 do norm:= norm + SR^[j]*SR^[j] + SI^[j]*SI^[j]; memo1.Lines.Add('норма данных: '+#9+FloatToStr(norm)); norm:=0; for j:=0 to N - 1 do norm:= norm + DR^[j]*DR^[j] + DI^[j]*DI^[j]; memo1.Lines.Add('норма FT: '+#9#9+FloatToStr(norm)); memo1.Lines.Add('Время расчета FFT: '+#9+inttostr(et-st)); memo1.Lines.add(''); (*for j:=0 to N - 1 do Memo1.Lines.Add(FloatToStr(SR^[j]) + ' + ' + FloatToStr(SI^[j]) + 'i'); for j:=0 to N - 1 do Memo1.Lines.Add(FloatToStr(DR^[j]) + ' + ' + FloatToStr(DI^[j]) + 'i');*) FreeMem(SR, N * SizeOf(TScalar)); FreeMem(SI, N * SizeOf(TScalar)); FreeMem(DR, N * SizeOf(TScalar)); FreeMem(DI, N * SizeOf(TScalar)); end; end.

[000111]

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

Alexandr Kordyum советует:

Функция представления чисел с плавающей точкой и нужным числом разрядов.
Пример: Conv(2.005,2) возвращает 2.01; Conv(2.5,0) возвращает 3

function Conv(cs: double; numb: integer): double; var db, db1, db2: double; i: int64; ii, ink, i1: integer; st: string; begin db:=cs-int(cs); ink:=1; for ii:=1 to numb do ink:=ink*10; db1:=db*ink; db2:=cs*ink*100; i:=trunc(int(db2)/100); i1:=trunc(db2-i*100); if i1>49 then inc(i); result:=i/ink; end;

С уважением, Александр. [000897]

Генератор случайных чисел

Ниже я привожу ассемблерную версию генератора случайных чисел, взятую мною из журнала Dr Dobbs Journal несколько лет тому назад. Попробуйте это, у меня данный алгоритм показал лучшие результаты.

function __R( range : word ) : word; assembler; asm mov                ax,        Word(System.RandSeed)   { DS:[003eH] } mov                bx, Word(System.RandSeed+2) { DS:[0040H] } mov                cx,        ax mul                CS:word ptr [0598H] shl                cx,        1 shl                cx,        1 shl                cx,        1 add                ch, cl add                dx, cx add                dx,        bx shl                bx,        1 shl                bx,        1 add                dx,        bx add                dh,        bl mov                cx,        0005H @1: shl                bx,        1 loop        @1 add                dh,        bl add                ax,        0001 adc                dx,        0000 mov   word(System.RandSeed), ax        { [003eH],        ax } mov                word(System.RandSeed+2), dx { [0040H],        dx } xor                ax,        ax mov                bx,        range or                 bx,        bx je                 @2 xchg               dx,        ax div                bx xchg               dx,        ax @2: end;

[001973]

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

Nomadic советует:

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

Function RoundStr(Zn:Real;kol_zn:Integer):Real; {Zn-значение; Kol_Zn-Кол-во знаков после запятой} Var snl,s,s0,s1,s2:String; n,n1:Real; nn,i:Integer; begin s:=FloatToStr(Zn); if (Pos(',',s)>0) and (Zn>0) and (Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn) then begin s0 := Copy(s,1,Pos(',',s)+kol_zn-1); s1 := Copy(s,1,Pos(',',s)+kol_zn+2); s2 := Copy(s1,Pos(',',s1)+kol_zn,Length(s1)); n := StrToInt(s2)/100; nn := Round(n); if nn >= 10 then begin snl := '0,'; For i := 1 to kol_zn - 1 do snl := snl + '0'; snl := snl+'1'; n1 := StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl); s := FloatToStr(n1); if Pos(',',s) > 0 then s1 := Copy(s,1,Pos(',',s)+kol_zn); end else s1 := s0 + IntToStr(nn); if s1[Length(s1)]=',' then s1 := s1 + '0'; Result := StrToFloat(s1); end else Result := Zn; end;

Все-таки работа со строками здесь излишество -

function RoundEx( X: Double; Precision : Integer ): Double; {Precision : 1 - до целых, 10 - до десятых, 100 - до сотых...} var ScaledFractPart, Temp : Double; begin ScaledFractPart := Frac(X)*Precision; Temp := Frac(ScaledFractPart); ScaledFractPart := Int(ScaledFractPart); if Temp >= 0.5 then ScaledFractPart := ScaledFractPart + 1; if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1; RoundEx := Int(X) + ScaledFractPart/Precision; end;

[001146]

function sgn (a : real) : real; begin if a < 0  then  sgn := -1; else  sgn :=  1; end; function atan2 (y, x : real) : real; begin if x > 0       then  atan2 := arctan (y/x) else if x > 0  then  atan2 := arctan (y/x) + pi else                 atan2 := pi/2 * sgn (y); end; { Я сделал это некоторое время назад при портировании кода из FORTRAN на Pascal. К сожалению, это было так давно, что я не помню, тестировал я это, или нет. }

Nathan

-------------------------------------------------------------------------------

От: Terje Mathisen <Terje.Mathisen@hda.hydro.com>
Тема: На: Как продублировать C функцию ATAN2 в Delphi?
Дата: 18 Мая 1995 19:25:10 GMT

Я думаю вы должны для этого обратить пристальное внимание на инструкцию FPATAN!

Это x87 opcode реализация IEEE-compliant функции ATAN2(), с полной расширенной точностью, и поддержкой аппаратных реализаций низкоуровневых функций.

Если вы активизировали "числовые" исключения, и контроль за неверными входными числами, чип x87 выдаст верное значение без необходимости опережающего тестирования параметров.

p BP/TP/Delphi-совместимая версия должна выглядеть примерно так:

Function atan2(y : extended; x : extended): Extended; Assembler; asm fld [y] fld [x] fpatan end;

Общее время выполнение - менее 200 чиклов на Pentium, с вероятностью возникновения ошибки - максимально не более одной, если, конечно, у вас не Pentium с ошибкой FDIV, где ее вероятность появляется после первых 15-20 верных битов! :-)

Библиотечная функция ArcTan(x) реализуется как fpatan(1.0,x), если вы компилируете ее с реальной установкой IEEE {$N+}.

Terje

--
-Terje Mathisen (включая стандартное предупреждение) <Terje.Mathisen@hda.hydro.com>
"почти все программирование может быть рассмотрено как упражнение в кэшировании"

-------------------------------------------------------------------------------

Это может содержать потенциальную проблему: win87em.dll и библиотека sw не будет работать на машинах, не оснащенных CoP.

--
Name:          Dr Jon Jenkins
Интернет:    jenkinsj@ozy.dec.com [001972]

Расчет периодичности выплат долгов

PAYMENT()

Возвращает "периодическую" сумму, необходимую для погашения долга.

function payment(princ, int, term: double): double; var temp: double; begin int := int / 100; temp := exp(ln(int + 1) * term); result := princ * ((int * temp) / (temp - 1)); end;

Синтаксис

PAYMENT(<principal expN>, <interest expN>, <term expN>)

<principal expN>

Общий объем платежа за все время.

<interest expN>

Процентная ставка за период. Выражается как положительное десятичное число. Процентная ставка относится к указанному периоду времени. Должна быть определена в процентах. Внутри функции число умножается на 100.

<term expN>

Количество платежей. Определите желаемое количество платежей за указанный срок.

Описание

PAYMENT( ) используется для вычисления суммы периодических платежей (payment), требуемых для погашения суммы <principal expN> за <term expN> платежей. PAYMENT( ) возвращает числовое значение, основанное на фиксированной процентной ставке в расчете за определенный промежуток времени. Если <principal expN> положительный, PAYMENT( ) возвратит положительное число. Если <principal expN> отрицательный, PAYMENT( ) возвратит отрицательное число. Процентная ставка выражается десятичным числом. Для примера, если показатель годового процента 9.5%, <interest expN> = 9.5 для ежегодно осуществляемых платежей.

Значения <interest expN> и <term expN> определяют полный период времени платежей. К примеру, если платежи происходят ежемесячно и выражаются месячной процентной ставкой, то можно получить количество месяцев, в течение которых осуществляются платежи. И наоборот. Например, для чтобы выразить показатель месячного процента от годового 9.5%, нужно разделить 9.5/12, т.е. 9.5% разнести на 12 месяцев. Ниже приведена формула для вычисления PAYMENT( ): term int*(1 + int)^ pmt = princ * ------------------- term (1 + int)^ - 1 где int = rate / 100 (как процент).

Пример: Требуется вычислить размер ежемесячных платежей при условии, что полная сумма $16860.68 должна быть возвращена в течение пяти лет, по 9% ежемесячно. Формула выглядит следующим образом:

MyVar := PAYMENT(16860.68, 9/12, 60)       {Возвратит 350.00}

[001971]

Разбиение шестнадцатиричной величины

Function LoNibble ( X : Byte ) : Byte; Begin Result := X And $F; End; Function HiNibble ( X : Byte ) : Byte; Begin Result := X Shr 4; End;

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

Label1.Caption := 'Верхняя часть - ' + IntToHex ( HiNibble ( $2E ), 2 ); Label2.Caption := 'Нижняя часть - ' + IntToHex ( LoNibble ( $2E ), 2 );

- Robert Wittig [000849]

Возведение числа в степень I

В: Это может звучать тривиально, но как мне возвести число в степень? Например, 2^12 = 4095.

На самом деле вопрос далеко не тривиальный. Проблема в том, что сам алгоритм функции далеко не прост. Функцией Power(X, N) (т.е. X^N) должны четко отслеживаться несколько возможных ситуаций:

X любое число, N = 0 X = 1, N любое число X = 0 и N > 0 X = 0 и N < 0 X > 0 X < 0 и N нечетное целое X < 0 и N целое X < 0 и N нецелое Посмотрите на следующую, абсолютно правильно работающую функцию (тем не менее она может быть и не самой эффективной!):

interface type EPowerException = class(Exception) end; implementation function Power(X, N : real) : extended; var t : longint; r : real; isInteger : boolean; begin if N = 0 then begin result := 1.0; exit; end; if X = 1.0 then begin result := 1.0; exit; end; if X = 0.0 then begin if N > 0.0 then begin result := 0.0; exit; end else raise EPowerException.Create('Результат - бесконечность'); end; if (X > 0) then try result := exp(N * ln(X)); exit; except raise EPowerException.Create('Результат - переполнение или потеря значимости'); end; { X - отрицательный, но мы все еще можем вычислить результат, если n целое. } { пытаемся получить целую часть n с использованием типа longint, вычисление } { четности n не займет много времени } try t := trunc(n); if (n - t) = 0 then isInteger := true else isInteger := False; except { Лишний бит может вызвать переполнение или потерю значимости } r := int(n); if (n - r) = 0 then begin isInteger := true; if frac(r/2) = 0.5 then t := 1 else t := 2; end else isInteger := False; end; if isInteger then begin {n целое} if odd(t) then {n нечетное} try result := -exp(N * ln(-X)); exit; except raise EPowerException.Create('Результат - переполнение или потеря значимости'); end else {n четное} try result := exp(N * ln(-X)); exit; except raise EPowerException.Create('Результат - переполнение или потеря значимости'); end; end else raise EPowerException.Create('Результат невычисляем'); end;

[000157]

Возведение числа в степень II

X^Y = exp(ln(X) * Y) c некоторыми условиями (например, X не может быть нулем). [000495]

Вычислитель математических формул

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

FORMULA должна быть стокой, содержащей формулу. Допускаются переменные x, y и z, а также операторы, перечисленные ниже. Пример:

sin(x)*cos(x^y)+exp(cos(x))

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

uses EVALCOMP; var calc:    EVALVEC ; (evalvec - указатель на объект, определяемый evalcomp) FORMULA: string; begin FORMULA:='x+y+z'; new (calc,init(FORMULA)); (Построение дерева оценки) writeln ( calc^.eval1d(7) )     ; (x=7 y=0 z=0; result:  7) writeln ( calc^.eval2d(7,8) )   ; (x=7 y=8 z=0; result: 15) writeln ( calc^.eval3d(7,8,9) ) ; (x=7 y=8 z=9; result: 24) dispose(calc,done); (разрушение дерева оценки) end.

Допустимые операторы:

x <l;> y ; Логические операторы возвращают 1 в случае истины и 0 если ложь. x <l;= y x >= y x > y x <l; y x = y x + y x - y x eor y ( исключающее или ) x or y x * y x / y x and y x mod y x div y x ^ y ( степень ) x shl y x shr y not (x) sinc (x) sinh (x) cosh (x) tanh (x) coth (x) sin (x) cos (x) tan (x) cot (x) sqrt (x) sqr (x) arcsinh (x) arccosh (x) arctanh (x) arccoth (x) arcsin (x) arccos (x) arctan (x) arccot (x) heavy (x) ; 1 для положительных чисел, 0 для остальных sgn (x) ; 1 для положительных чисел, -1 для отрицательных и 0 для нуля frac (x) exp (x) abs (x) trunc (x) ln (x) odd (x) pred (x) succ (x) round (x) int (x) fac (x) ; x*(x-1)*(x-2)*...*3*2*1 rnd ; Случайное число в диапазоне [0,1] rnd (x) ; Случайное число в диапазоне [0,x] pi e

unit evalcomp; interface type fun= function(x,y:real):real; evalvec= ^evalobj; evalobj= object f1,f2:evalvec; f1x,f2y:real; f3:fun; function eval:real; function eval1d(x:real):real; function eval2d(x,y:real):real; function eval3d(x,y,z:real):real; constructor init(st:string); destructor done; end; var  evalx,evaly,evalz:real; implementation var analysetmp:fun; function search (text,code:string; var pos:integer):boolean; var i,count:integer; flag:boolean; newtext:string; begin if length(text)<l;length(code) then begin search:=false; exit; end; flag:=false; pos:=length(text)-length(code)+1; repeat if code=copy(text,pos,length(code)) then flag:=true else dec(pos); if flag then begin count:=0; for i:= pos+1 to length(text) do begin if copy(text,i,1) = '(' then inc(count); if copy(text,i,1) = ')' then dec(count); end; if count<l;>0 then begin dec(pos); flag:=false; end; end; until (flag=true) or (pos=0); search:=flag; end; function myid(x,y:real):real; begin myid:=x; end; function myunequal(x,y:real):real; begin if x<>y then myunequal:=1 else myunequal:=0; end; function mylessequal(x,y:real):real; begin if x<=y then mylessequal:=1 else mylessequal:=0; end; function mygreaterequal(x,y:real):real; begin if x>=y then mygreaterequal:=1 else mygreaterequal:=0; end; function mygreater(x,y:real):real; begin if x>y then mygreater:=1 else mygreater:=0; end; function myless(x,y:real):real; begin if x<y then myless:=1 else myless:=0; end; function myequal(x,y:real):real; begin if x=y then myequal:=1 else myequal:=0; end; function myadd(x,y:real):real; begin myadd:=x+y; end; function mysub(x,y:real):real; begin mysub:=x-y; end; function myeor(x,y:real):real; begin myeor:=trunc(x) xor trunc(y); end; function myor(x,y:real):real; begin myor:=trunc(x) or trunc(y); end; function mymult(x,y:real):real; begin mymult:=x*y; end; function mydivid(x,y:real):real; begin mydivid:=x/y; end; function myand(x,y:real):real; begin myand:=trunc(x) and trunc(y); end; function mymod(x,y:real):real; begin mymod:=trunc(x) mod trunc(y); end; function mydiv(x,y:real):real; begin mydiv:=trunc(x) div trunc(y); end; function mypower(x,y:real):real; begin if x=0 then mypower:=0 else if x>0 then mypower:=exp(y*ln(x)) else if trunc(y)<>y  then begin writeln (' Немогу вычислить x^y '); halt; end else if odd(trunc(y))=true then mypower:=-exp(y*ln(-x)) else mypower:=exp(y*ln(-x)) end; function myshl(x,y:real):real; begin myshl:=trunc(x) shl trunc(y); end; function myshr(x,y:real):real; begin myshr:=trunc(x) shr trunc(y); end; function mynot(x,y:real):real; begin mynot:=not trunc(x); end; function mysinc(x,y:real):real; begin if x=0 then mysinc:=1 else mysinc:=sin(x)/x end; function mysinh(x,y:real):real; begin mysinh:=0.5*(exp(x)-exp(-x)) end; function mycosh(x,y:real):real; begin mycosh:=0.5*(exp(x)+exp(-x)) end; function mytanh(x,y:real):real; begin mytanh:=mysinh(x,0)/mycosh(x,0) end; function mycoth(x,y:real):real; begin mycoth:=mycosh(x,0)/mysinh(x,0) end; function mysin(x,y:real):real; begin mysin:=sin(x) end; function mycos(x,y:real):real; begin mycos:=cos(x) end; function mytan(x,y:real):real; begin mytan:=sin(x)/cos(x) end; function mycot(x,y:real):real; begin mycot:=cos(x)/sin(x) end; function mysqrt(x,y:real):real; begin mysqrt:=sqrt(x) end; function mysqr(x,y:real):real; begin mysqr:=sqr(x) end; function myarcsinh(x,y:real):real; begin myarcsinh:=ln(x+sqrt(sqr(x)+1)) end; function mysgn(x,y:real):real; begin if x=0 then mysgn:=0 else mysgn:=x/abs(x) end; function myarccosh(x,y:real):real; begin myarccosh:=ln(x+mysgn(x,0)*sqrt(sqr(x)-1)) end; function myarctanh(x,y:real):real; begin myarctanh:=ln((1+x)/(1-x))/2 end; function myarccoth(x,y:real):real; begin myarccoth:=ln((1-x)/(1+x))/2 end; function myarcsin(x,y:real):real; begin if x=1 then myarcsin:=pi/2 else myarcsin:=arctan(x/sqrt(1-sqr(x))) end; function myarccos(x,y:real):real; begin myarccos:=pi/2-myarcsin(x,0) end; function myarctan(x,y:real):real; begin myarctan:=arctan(x); end; function myarccot(x,y:real):real; begin myarccot:=pi/2-arctan(x) end; function myheavy(x,y:real):real; begin myheavy:=mygreater(x,0) end; function myfrac(x,y:real):real; begin myfrac:=frac(x) end; function myexp(x,y:real):real; begin myexp:=exp(x) end; function myabs(x,y:real):real; begin myabs:=abs(x) end; function mytrunc(x,y:real):real; begin mytrunc:=trunc(x) end; function myln(x,y:real):real; begin myln:=ln(x) end; function myodd(x,y:real):real; begin if odd(trunc(x)) then myodd:=1 else myodd:=0; end; function mypred(x,y:real):real; begin mypred:=pred(trunc(x)); end; function mysucc(x,y:real):real; begin mysucc:=succ(trunc(x)); end; function myround(x,y:real):real; begin myround:=round(x); end; function myint(x,y:real):real; begin myint:=int(x); end; function myfac(x,y:real):real; var n : integer; r : real; begin if x<0 then begin writeln(' Немогу вычислить факториал '); halt; end; if x = 0 then myfac := 1 else begin r := 1; for n := 1 to trunc ( x ) do r := r * n; myfac:= r; end; end; function myrnd(x,y:real):real; begin myrnd:=random; end; function myrandom(x,y:real):real; begin myrandom:=random(trunc(x)); end; function myevalx(x,y:real):real; begin myevalx:=evalx; end; function myevaly(x,y:real):real; begin myevaly:=evaly; end; function myevalz(x,y:real):real; begin myevalz:=evalz; end; procedure analyse (st:string; var st2,st3:string); label start; var pos:integer; value:real; newterm,term:string; begin term:=st; start: if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end; newterm:=''; for pos:= 1 to length(term) do if copy(term,pos,1)<>' ' then newterm:=newterm+copy(term,pos,1); term:=newterm; if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end; val(term,value,pos); if pos=0 then begin analysetmp:=myid; st2:=term; st3:=''; exit; end; if search(term,'<>',pos) then begin analysetmp:=myunequal; st2:=copy(term,1,pos-1); st3:=copy(term,pos+2,length(term)-pos-1); exit; end; if search(term,'<=',pos) then begin analysetmp:=mylessequal; st2:=copy(term,1,pos-1); st3:=copy(term,pos+2,length(term)-pos-1); exit; end; if search(term,'>=',pos) then begin analysetmp:=mygreaterequal; st2:=copy(term,1,pos-1); st3:=copy(term,pos+2,length(term)-pos-1); exit; end; if search(term,'>',pos) then begin analysetmp:=mygreater; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'<',pos) then begin analysetmp:=myless; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'=',pos) then begin analysetmp:=myequal; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'+',pos) then begin analysetmp:=myadd; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'-',pos) then begin analysetmp:=mysub; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'eor',pos) then begin analysetmp:=myeor; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if search(term,'or',pos) then begin analysetmp:=myor; st2:=copy(term,1,pos-1); st3:=copy(term,pos+2,length(term)-pos-1); exit; end; if search(term,'*',pos) then begin analysetmp:=mymult; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'/',pos) then begin analysetmp:=mydivid; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'and',pos) then begin analysetmp:=myand; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if search(term,'mod',pos) then begin analysetmp:=mymod; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if search(term,'div',pos) then begin analysetmp:=mydiv; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if search(term,'^',pos) then begin analysetmp:=mypower; st2:=copy(term,1,pos-1); st3:=copy(term,pos+1,length(term)-pos); exit; end; if search(term,'shl',pos) then begin analysetmp:=myshl; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if search(term,'shr',pos) then begin analysetmp:=myshr; st2:=copy(term,1,pos-1); st3:=copy(term,pos+3,length(term)-pos-2); exit; end; if copy(term,1,1)='(' then begin term:=copy(term,2,length(term)-2); goto start; end; if copy(term,1,3)='not' then begin analysetmp:=mynot; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,4)='sinc' then begin analysetmp:=mysinc; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,4)='sinh' then begin analysetmp:=mysinh; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,4)='cosh' then begin analysetmp:=mycosh; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,4)='tanh' then begin analysetmp:=mytanh; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,4)='coth' then begin analysetmp:=mycoth; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,3)='sin' then begin analysetmp:=mysin; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,3)='cos' then begin analysetmp:=mycos; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,3)='tan' then begin analysetmp:=mytan; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,3)='cot' then begin analysetmp:=mycot; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,4)='sqrt' then begin analysetmp:=mysqrt; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,3)='sqr' then begin analysetmp:=mysqr; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,7)='arcsinh' then begin analysetmp:=myarcsinh; st2:=copy(term,8,length(term)-7); st3:=''; exit; end; if copy(term,1,7)='arccosh' then begin analysetmp:=myarccosh; st2:=copy(term,8,length(term)-7); st3:=''; exit; end; if copy(term,1,7)='arctanh' then begin analysetmp:=myarctanh; st2:=copy(term,8,length(term)-7); st3:=''; exit; end; if copy(term,1,7)='arccoth' then begin analysetmp:=myarccoth; st2:=copy(term,8,length(term)-7); st3:=''; exit; end; if copy(term,1,6)='arcsin' then begin analysetmp:=myarcsin; st2:=copy(term,7,length(term)-6); st3:=''; exit; end; if copy(term,1,6)='arccos' then begin analysetmp:=myarccos; st2:=copy(term,7,length(term)-6); st3:=''; exit; end; if copy(term,1,6)='arctan' then begin analysetmp:=myarctan; st2:=copy(term,7,length(term)-6); st3:=''; exit; end; if copy(term,1,6)='arccot' then begin analysetmp:=myarccot; st2:=copy(term,7,length(term)-6); st3:=''; exit; end; if copy(term,1,5)='heavy' then begin analysetmp:=myheavy; st2:=copy(term,6,length(term)-5); st3:=''; exit; end; if copy(term,1,3)='sgn' then begin analysetmp:=mysgn; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,4)='frac' then begin analysetmp:=myfrac; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,3)='exp' then begin analysetmp:=myexp; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,3)='abs' then begin analysetmp:=myabs; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,5)='trunc' then begin analysetmp:=mytrunc; st2:=copy(term,6,length(term)-5); st3:=''; exit; end; if copy(term,1,2)='ln' then begin analysetmp:=myln; st2:=copy(term,3,length(term)-2); st3:=''; exit; end; if copy(term,1,3)='odd' then begin analysetmp:=myodd; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,4)='pred' then begin analysetmp:=mypred; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,4)='succ' then begin analysetmp:=mysucc; st2:=copy(term,5,length(term)-4); st3:=''; exit; end; if copy(term,1,5)='round' then begin analysetmp:=myround; st2:=copy(term,6,length(term)-5); st3:=''; exit; end; if copy(term,1,3)='int' then begin analysetmp:=myint; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if copy(term,1,3)='fac' then begin analysetmp:=myfac; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if term='rnd' then begin analysetmp:=myrnd; st2:=''; st3:=''; exit; end; if copy(term,1,3)='rnd' then begin analysetmp:=myrandom; st2:=copy(term,4,length(term)-3); st3:=''; exit; end; if term='x' then begin analysetmp:=myevalx; st2:=''; st3:=''; exit; end; if term='y' then begin analysetmp:=myevaly; st2:=''; st3:=''; exit; end; if term='z' then begin analysetmp:=myevalz; st2:=''; st3:=''; exit; end; if (term='pi') then begin analysetmp:=myid; str(pi,st2); st3:=''; exit; end; if term='e' then begin analysetmp:=myid; str(exp(1),st2); sst3:=''; exit; end; writeln(' ВНИМАНИЕ : НЕДЕКОДИРУЕМАЯ ФОРМУЛА '); analysetmp:=myid; st2:=''; st3:=''; end; function evalobj.eval:real; var tmpx,tmpy:real; begin if f1=nil then tmpx:=f1x else tmpx:=f1^.eval; if f2=nil then tmpy:=f2y else tmpy:=f2^.eval; eval:=f3(tmpx,tmpy); end; function evalobj.eval1d(x:real):real; begin evalx:=x; evaly:=0; evalz:=0; eval1d:=eval; end; function evalobj.eval2d(x,y:real):real; begin evalx:=x; evaly:=y; evalz:=0; eval2d:=eval; end; function evalobj.eval3d(x,y,z:real):real; begin evalx:=x; evaly:=y; evalz:=z; eval3d:=eval; end; constructor evalobj.init(st:string); var st2,st3:string; error:integer; begin f1:=nil; f2:=nil; analyse(st,st2,st3); f3:=analysetmp; val(st2,f1x,error); if st2='' then begin f1x:=0; error:=0; end; if error<>0 then new (f1,init(st2)); val(st3,f2y,error); if st3='' then begin f2y:=0; error:=0; end; if error<>0 then new (f2,init(st3)); end; destructor evalobj.done; begin if f1<>nil then dispose(f1,done); if f2<>nil then dispose(f2,done); end; end.

[000159]

Как проиграть AVI на полный экран?

Своим опытом делится Олег Кулабухов:

Просто проиграть его на другой форме, развернутой на весь экран

{Code for Form 1} uses Unit2; procedure TForm1.Button1Click(Sender: TObject); begin Form2.Show; Form2.WindowState := wsMaximized; Form2.MediaPlayer1.Notify := false; Form2.MediaPlayer1.Display := Form2.Panel1; Form2.MediaPlayer1.FileName := 'C:\TheWall\DELCAR2.AVI'; Form2.MediaPlayer1.Open; Form2.MediaPlayer1.DisplayRect := Form2.ClientRect; Form2.MediaPlayer1.Play; end; {Code for Form 2} procedure TForm2.MediaPlayer1Notify(Sender: TObject); begin if MediaPlayer1.NotifyValue = nvSuccessful then Form2.Close; end;

[001852]

TMEDIAPLAYER: циклическое проигрывание

Используйте событие компонента TMediaPlayer OnNotify для определения момента завершения проигрывания:

procedure TForm1.BitBtn1Click(Sender: TObject); begin With MediaPlayer1 do Begin Open; Notify := True; Play; End; end; procedure TForm1.MediaPlayer1Notify(Sender: TObject); begin With MediaPlayer1 do If NotifyValue = nvSuccessful Then Begin Notify := True; Play; End; end;

[001985]

TMEDIAPLAYER: Определение CD трэка

{ Создаем таймер и помещаем данный код в обработчик события OnTimer: } var Trk, Min, Sec: Word; begin with MediaPlayer1 do begin Trk:= MCI_TMSF_TRACK(Position); Min:=MCI_TMSF_MINUTE(Position); Sec:=MCI_TMSF_SECOND(Position); Label1.Caption:=Format('%.2d',[Trk]); Label2.Caption:=Format('%.2d:%.2d',[Min,Sec]); end; end; { Добавьте MMSystem в список используемых модулей в Unit1 Данный код выводит текущий трэк и время. }

[001984]

Запись с помощью MediaPlayer

Компонент Mediaplayer работает только с корректными звуковыми файлами и не работает с файлами нулевого размера. Нижеприведенная функция создаст звуковой файл с размером 1. Вариантная запись. Хотелось бы видеть лучшее решение, но пока такой вариант работает у меня без проблем.

function CreateNewWave(NewFileName: String): Boolean; var DeviceID: Word; Return: LongInt; MciOpen: TMCI_Open_Parms; MciRecord: TMCI_Record_Parms; MciPlay: TMCI_Play_Parms; MciSave: TMCI_SaveParms; MCIResult: LongInt; Flags: Word; TempFileName: array[0..255] of char; begin MediaPlayer.Close; try StrPCopy(TempFileName, NewFilename); MciOpen.lpstrDeviceType := 'waveaudio'; MciOpen.lpstrElementName := ''; Flags := Mci_Open_Element or Mci_Open_Type; MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen)); DeviceID := MciOpen.wDeviceId; MciRecord.dwTo := 1; Flags := Mci_To or Mci_Wait; MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord)); mciPlay.dwFrom := 0; Flags := Mci_From or Mci_Wait; MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay)); mciSave.lpfileName := TempFilename.CString; Flags := MCI_Save_File or Mci_Wait; MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave)); Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0; end; end;

Nick Hodges [000509]

Добавление строк в Memo

Быстро-грязный (по-русски "кривой") способ добавить в Memo дополнительный текст заключается в его загрузке в невидимый TMemo и последующем использовании следующим образом:

Memo1.Lines.AddStrings(Memo2.Lines);

Вам необходима функциональность второго TMemo, а не просто TStringList, поскольку первый инкапсулирует множество функций для работы с текстом. В противном случае вы могли бы загрузить файл в TSTringList и сами искать первые 255 символов каждого параграфа.

Чтобы было по-настоящему все удобно, необходимо создать временный TMemoStrings; к сожалению, TMemoStrings определен в секции implementation файла StdCtrls.PAS, и, таким образом, нам недоступен.

Бывает и так, что два временных TStringLists удобнее одного временного TMemo. Например, такой случай:

TS1 := TStringList.Create; TS2 := TStringList.Create; TS1.Assign(Memo1.Lines); Memo1.Lines.LoadFromFile('BULLRUN.TXT'); TS2.Assign(Memo1.Lines); Memo1.Lines.Assign(TS1); Memo1.Lines.AddStrings(TS2); TS2.Free; TS1.Free;

Уф!! Гвоздь программы здесь - возможность разрывать строки в свойстве Memo Lines при добавлении НОВОГО текста. Итак, мы записываем существующий текст во временную переменную, считываем новый текст в Memo, снова передаем НОВЫЙ текст временной переменной, восстанавливаем оригинальный текст и, наконец, добавляем новый текст.

- Neil J. Rubenking [000802]

Импортирование файла в компонент Memo

Как мне импортировать файл в элемент управления TMemo начиная с позиции курсора? LoadFromFile заменяет содержимое TMemo содержимым текстового файла. Я хочу включить текстовый файл или в поцизию курсора или, если выбран текст, заменить этот текст содержимым текстового файла. Все это должно быть похоже на работу фунции PasteFromClipboard.

Самый простой путь вставки текста в компонент Memo заключается в посылке ему сообщения EM_REPLACESEL.

{ InsertFileInMemo-- ПРИМЕЧАНИЕ: если вы хотите заменить к настоящему времени выбранный в Memo текст, передайте в параметре ReplaceSel TRUE. FALSE необходим для простой вставки текста... } procedure InsertFileInMemo( Memo: TMemo; FileName: string; ReplaceSel: Boolean ); var Stream: TMemoryStream; NullTerminator: Char; begin Stream := TMemoryStream.Create; try { Загружаем текст... } Stream.LoadFromFile( FileName ); { Добавляем в конец текста терминирующий ноль... } Stream.Seek( 0, 2 ); NullTerminator := #0; Stream.Write( NullTerminator, 1 ); { Вставляем текст в Memo... } if not ReplaceSel then Memo.SelLength := 0; SendMessage( Memo.Handle, EM_ReplaceSel, 0, LongInt( Stream.Memory )); finally Stream.Free; end; end;

- Ed Jordan [001000]

Использование встроенного отката в Memo

...хорошо, если интегрированный откат вас устроит, то его вы можете получить легче, чем осуществить комбинацию Ctrl+Z:

Memo1.Perform(EM_UNDO, 0, 0);

Предварительно можно осведомиться о доступности отмены (т.е. наличие предыдущих состояний) для включения/выключения соответствующего элемента меню:

Undo1.Enabled := Memo1.Perform(EM_CANUNDO, 0, 0) <> 0;

- Neil [000480]

Изменение поведения Delete в компоненте Memo

Просто меняю обработчик Memo OnKeyDown следующим образом:

if Key = VK_DELETE then begin здесь делайте все, что вы хотите end; if Key = VK_BACK then begin аналогично end;

Вероятно, лучшим решением было бы использование конструкции CASE, но я не уверен, что она поймет как нужно VK_??. Возможно, после обработки нужно вызвать унаследованный обработчик, т.е. дать поработать обработчику верхнего уровня, у которого мы стырили управление. Не хотите подумать над этим?

Чтобы понять, где мы сейчас находимся, используйте SelStart, например, так:

var Lpos, Cpos : Integer; Lpos := SendMessage(memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0); Cpos := SendMessage(memo1.Handle,EM_LINEINDEX,Lpos,0); CPos := Memo1.SelStart-CPos;

Ответ: поскольку VK_? имеет целочисленный тип, то это будет работать:

case Key of VK_DELETE : begin Key := 0;  {этим мы не позволяем сообщению keydown передаваться дальше, например, форме или компонентам} выполняем нужный код; end; VK_BACK: begin Key := 0;  {этим мы не позволяем сообщению keydown передаваться дальше, например, форме или компонентам} выполняем нужный код; end; end;

[001468]

Эквивалент вкл/выкл эха в Memo

Memo1.Perform( WM_SETREDRAW, 0, 0 ); ... здесь можно добавлять строки Memo1.Perform( WM_SETREDRAW, 1, 0 ); Memo1.Refresh;

кстати, работает во всех управляемых элементах... [000477]

Как включить режим перезаписывания в TMemo и TEdit?

Олег Кулабухов приводит следующий код:

Эти два компонента не поддерживают режим перезаписывания. Но, если немного исхитриться с SetLength, то можно добиться желаемого результата.

type TForm1 = class(TForm) Memo1: TMemo; procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1KeyPress(Sender: TObject; var Key: Char); private { Private declarations } InsertOn : bool; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (Key = VK_INSERT) and (Shift = []) then InsertOn := not InsertOn; end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin if ((Memo1.SelLength = 0) and (not InsertOn)) then Memo1.SelLength := 1; end;

[001925]

Как вставить содержимое файла в TMemo с текущей позиции?

Олег Кулабухов приводит следующий код:

Используем TMemoryStream для чтения файла, после чего - SetSelTextBuf() для вставки текста.

var TheMStream : TMemoryStream; Zero : char; begin TheMStream := TMemoryStream.Create; TheMStream.LoadFromFile('C:\AUTOEXEC.BAT'); TheMStream.Seek(0, soFromEnd); //Null terminate the buffer! Zero := #0; TheMStream.Write(Zero, 1); TheMStream.Seek(0, soFromBeginning); Memo1.SetSelTextBuf(TheMStream.Memory); TheMStream.Free; end;

[001924]

Memo со своими шрифтами и др.

Кто-нибудь знает как использовать различные шрифты и стили в Memo-объекте?

Просто создайте собственный TxxxMemo: наследуйтесь от стандартного TMemo и перекройте метод Paint.

Вот мой старый пример, изменяющий цвет каждой строки:

unit Todrmemo; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TOwnerDrawMemo = class(TMemo) private { Private declarations } procedure WMPaint(var Message: TWMPaint); message WM_PAINT; protected { Protected declarations } public { Public declarations } published { Published declarations } end; procedure Register; implementation procedure TOwnerDrawMemo.WMPaint(var Message: TWMPaint); var Buffer: Array[0..255] of Char; PS: TPaintStruct; DC: HDC; i: Integer; X,Y,Z: Word; OldColor: LongInt; begin DC := Message.DC; if DC = 0 then DC := BeginPaint(Handle, PS); try X := 1; Y := 1; SetBkColor(DC, Color); SetBkMode(DC, Transparent); OldColor := Font.Color; for i:=0 to Pred(Lines.Count) do begin if odd(i) then SetTextColor(DC, clRed) else SetTextColor(DC, OldColor); Z := Length(Lines[i]); StrPCopy(Buffer, Lines[i]); Buffer[Z] := #0; { реально не нужно } TextOut(DC, X,Y, Buffer, Z); Inc(Y, abs(Font.Height)); end; finally if Message.DC = 0 then EndPaint(Handle, PS); end; end; procedure Register; begin RegisterComponents('Dr.Bob', [TOwnerDrawMemo]); end; end.

Dr. Bob (drbob@pi.net) [000683]

Memo в StringList и обратно

Если вам необходимо заменить все содержимое компонента Memo:

Memo1.Lines := StringList1.Strings;

Если вам необходимо добавить строки к списку компонента:

Memo1.Lines.AddStrings(StringList1.Strings);

[000457]

Обнаружение прокрутки TMemo

Создайте потомок TMemo, перехватывающий сообщения WM_HSCROLL и WM_VSCROLL:

TSMemo = class(TMemo) procedure WM_HScroll(var Msg: TWMHScroll); message WM_HSCROLL; procedure WM_VScroll(var Msg: TWMVScroll); message WM_VSCROLL; end; .. procedure TSMemo.WM_HScroll(var Msg: TWMHScroll); begin ShowMessage('HScroll'); end; procedure TSMemo.WM_VScroll(var Msg: TWMVScroll); begin ShowMessage('VScroll'); end;

- Xavier Pacheco [000803]

Ограничение размера Memo

Ограничение длины и количества строк компонента:

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, StdCtrls, ExtCtrls, Forms; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); procedure Memo1KeyPress(Sender: TObject; var Key: Char); public MaxCharsPerLine, MaxLines: Integer; function MemoLine: Integer; function LineLen(r: Integer): Integer; function NRows: Integer; end; var Form1: TForm1; implementation {$R *.DFM} function TForm1.NRows: Integer; begin with Memo1 do Result := 1 + SendMessage(Handle, EM_LINEFROMCHAR, GetTextLen-1, 0); end; function TForm1.LineLen(r: Integer): Integer; var r1, r2: Integer; begin with Memo1 do begin r1 := SendMessage(Handle, EM_LINEINDEX, r, 0); if (r > NRows-1) then r2 := SendMessage(Handle, EM_LINEINDEX, r+1, 0)-2 {-CR/LF} else r2 := GetTextLen; end; Result := r2-r1; end; function TForm1.MemoLine: Integer; begin with Memo1 do Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0); end; procedure TForm1.FormCreate(Sender: TObject); begin MaxCharsPerLine := 8; MaxLines := 4; end; procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); begin with Memo1 do begin case Key of ' '..#255: if (LineLen(MemoLine) >= MaxCharsPerLine) then Key := #0; #10, #13: if (NRows >= MaxLines) then Key := #0; #8: if (SelStart = SendMessage(Handle, EM_LINEINDEX, MemoLine, 0)) then Key := #0; end; end; end; end.

[000642]

Перемещение по Memo

procedure MemoCursorTo(Memo:TMemo; MemoLine, MemoCol: Integer); begin Memo.SelStart := SendMessage (Memo.Handle, EM_LINEINDEX, MemoLine, 0) + MemoCol - 1; end;

[001562]

Поиск и замена текста в Tmemo

procedure TForm1.FindDialog1Find(Sender: TObject); VAR Buff, P, FT : PChar; BuffLen     : Word; begin WITH Sender AS TFindDialog DO BEGIN GetMem(FT, Length(FindText) + 1); StrPCopy(FT, FindText); BuffLen := Memo1.GetTextLen + 1; GetMem(Buff, BuffLen); Memo1.GetTextBuf(Buff, BuffLen); P := Buff + Memo1.SelStart + Memo1.SelLength; P := StrPos(P, FT); IF P = NIL THEN MessageBeep(0) ELSE BEGIN Memo1.SelStart := P - Buff; Memo1.SelLength := Length(FindText); END; FreeMem(FT, Length(FindText) + 1); FreeMem(Buff, BuffLen); END; end; procedure TForm1.ReplaceDialog1Replace(Sender: TObject); begin WITH Sender AS TReplaceDialog DO WHILE True DO BEGIN IF Memo1.SelText <> FindText THEN FindDialog1Find(Sender); IF Memo1.SelLength = 0 THEN Break; Memo1.SelText := ReplaceText; IF NOT (frReplaceAll IN Options) THEN Break; END; end;

[000363]

Получение данных из компонента Memo

Для получения содержимого буфера используйте метод GetTextBuf, или воспользуйтесь приведенным ниже кодом (естественно, откорректируйте его под себя).

procedure TForm1.SpeedButton1Click(Sender: TObject); var LineNo : integer; ColNo  : integer; begin LineNo:=SendMessage(Memo1.Handle,EM_LINEFROMCHAR,Memo1.SelStart,0); ColNo:=Memo1.SelStart; if LineNo>0 then begin While SendMessage(Memo1.Handle,EM_LINEFROMCHAR,ColNo,0)=LineNo do ColNo:=ColNo-1; ColNo:=Memo1.SelStart-ColNo-1; end else ColNo:=Memo1.SelStart; Panel1.Caption:='Строка '+IntToStr(LineNo)+' ; Колонка '+IntToStr(ColNo); {Здесь вы можете получить текст через Memo1.Lines[LineNo].Text[ColNo] ...} end;

Предупреждение! Данный код был написан в среде WinNT/D2 с использованием элемента управления richedit. Я тестировал то же самое, но с компонентом Memo и в D1, но этот код я забыл дома. Код выше написан по памяти и не тестировался, но я думаю он должен работать. Если вы переберетесь на D2, измените вызов sendmessage на следующий:

SendMessage(Memo1.Handle,EM_EXLINEFROMCHAR,0,ColNo)

[001449]

?? Прокрутка Memo ??

И вот что я вам отвечу:

Var ScrollMessage:TWMVScroll; ScrollMessage.Msg:=WM_VScroll; for i := Memo1.Lines.Count DownTo 0 do begin ScrollMessage.ScrollCode:=sb_LineUp; ScrollMessage.Pos:=0; Memo1.Dispatch(ScrollMessage); end;

[000171]

Событие "Key press" и курсорные клавиши (стрелки) в Tmemo

Мне необходимо обновлять текущую строку в во время перемещения по ним с помощью курсорных клавиш.

Вам повезло. Совсем недавно мне пришлось помучиться с этой задачкой. Я переместил функции в отдельный модуль. Для тестирования кода создайте пустую форму с одним компонентом Tmemo.

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

Данный пример отображает в заголовке текущие координаты курсора (столбец, строка).

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

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

unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure Memo1Change(Sender: TObject); procedure Memo1Click(Sender: TObject); procedure Memo1Enter(Sender: TObject); procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Memo1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } Function GetLineIndex : Word; Function GetStrInsertIndex : Word; procedure GetCursorCoord; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} Function TForm1.GetLineIndex : Word; begin Result:=SendMessage(Memo1.handle,EM_LINEFROMCHAR,memo1.selstart,0); end; Function TForm1.GetStrInsertIndex : word; begin GetStrInsertIndex := memo1.Selstart-SendMessage(Memo1.handle,EM_LINEINDEX,GetLineIndex,0) end; procedure TForm1.GetCursorCoord; var LineIndex: word; LineChar : byte; SelSt : word; begin SelSt:=Memo1.selstart; LineIndex:=GetLineIndex; Linechar:=GetStrInsertIndex; if Memo1.seltext>'' then Caption:='Выбранный текст' else Caption:='Колонка '+ inttostr(LineChar+1)+' , ' + 'Строка '+ inttostr(Lineindex+1); end; procedure TForm1.Memo1Change(Sender: TObject); begin GetCursorCoord; end; procedure TForm1.Memo1Click(Sender: TObject); begin GetCursorCoord; end; procedure TForm1.Memo1Enter(Sender: TObject); begin GetCursorCoord; end; procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin GetCursorCoord; end; procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin GetCursorCoord; end; procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin GetCursorCoord; end; procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin GetCursorCoord; end; end.

[000172]

Сохранение Tmemo в EXE

Для того, чтобы помешать Delphi сохранять .EXE абзацы Memo в виде отдельных строк, перед тем, как загрузить текст, установите в режиме разработки свойство Memo WordWrap в False.

А во время загрузки приложения, в обработчике события формы OnCreate, установите свойство WordWrap в True. [000432]

Текущая позиция Tmemo I

CurrentLine :=SendMessage(Memo1.Handle, EM_LINEFROMCHAR,Memo1.SelStart, 0);

Это вернет номер строки, содержащей курсор. Нижеследующий код вернет позицию символа текущей строки, около которого находится курсор:

ColNum := Memo1.SelStart-SendMessage(Memo1.Handle, EM_LINEINDEX,CurrentLine, 0) + 1;

Описания EM_LINEFROMCHAR и EM_LINEINDEX вы можете найти в файлах помощи по Windows API.

Дополнение

А можно и так, сообщает Nomadic:

var X,Y: LongInt; ............ Y := Memo1.Perform( EM_LINEFROMCHAR, Memo1.SelStart, 0 ); X := Memo1.Parform( EM_LINEINDEX, Y, 0 ); inc( Y ); X := Memo1.SelStart - X + 1; ........

[000393]

Текущая позиция Tmemo II

procedure TMyForm.BitBtn1Click(Sender: TObject); var iLine : Integer ; begin iLine := Memo1.Perform(em_LineFromChar, $FFFF, 0); { Примечание: первая строка нулевая } messageDlg('Номер строки: ' + IntToStr(iLine), mtInformation, [mbOK], 0 ) ; end;

Роман Воробьев дополняет:

Не знаю, как было раньше (там в углу написано "Delphi 1"), но в Делфи5 у ТMemo есть св-во

property CaretPos: TPoint;

которое и решает эту проблему.

Т.е

Label1.Caption:='Строка '+IntToStr(memo1.caretpos.y); Label2.Caption:='Столбец '+IntToStr(memo1.caretpos.x);

должно вполне работать.

По материалам книги г-на Архангельского "100 компонентов общего назначения в DELPHI 5" (за точность названия/фамилии не ручаюсь, книги под рукой нет). [000482]

TMemo с row & col

Наследник TMemo со свойствами row & col:

unit C_rcmemo; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TRCMemo = class(TMemo) private { Private declarations } function GetRow : Integer; procedure SetRow(value : Integer); function GetCol : Integer; procedure SetCol(value : Integer); function GetPosn : LongInt; procedure SetPosn(value : LongInt); protected { Protected declarations } public { Public declarations } published { Published declarations } property Row : Integer Read GetRow Write SetRow; property Col : Integer Read GetCol Write SetCol; property Posn : LongInt Read GetPosn Write SetPosn; end; procedure Register; implementation function TRCMemo.GetRow : Integer; begin Result := Perform(EM_LINEFROMCHAR, $FFFF, 0); end; procedure TRCMemo.SetRow(value : Integer); begin SelStart := GetCol + Perform(EM_LINEINDEX, Value, 0); end; function TRCMemo.GetCol : Integer; begin Result := SelStart - Perform(EM_LINEINDEX, GetRow, 0); end; procedure TRCMemo.SetCol(value : Integer); begin SelStart := Perform(EM_LINEINDEX, GetRow, 0) + Value; end; function TRCMemo.GetPosn : LongInt; Var ro, co : Integer; begin ro := GetRow; co := SelStart - Perform(EM_LINEINDEX, ro, 0); Result := MakeLong(co,ro); end; procedure TRCMemo.SetPosn(value : LongInt); begin SelStart := Perform(EM_LINEINDEX, HiWord(Value), 0) + LoWord(Value); end; procedure Register; begin RegisterComponents('NJR', [TRCMemo]); end; end.

[000554]

Управление прокруткой Memo

У меня имеется компонент TMemo, и мне необходимо автоматически "тормозить" программным способом его прокрутку при добавлении новой строки Memo.Lines.Add(Строка).

В Delphi 2.0 простая установка 'SelStart:=0' НЕ срабатывает. Это ошибка в коде VCL. Значения различных частей 'сообщения' windows, используемые для "set selection" (установления выбранной части текста) в WIN32 были изменены (это использовалось для 'автоматической' прокрутки каретки/курсора, но больше не работает).

Попробуйте добавить следующую строку ПОСЛЕ 'SelStart:=0;':

SendMessage(Handle,EM_SCROLLCARET,0,0);

Это должно заставить компонент работать так, как вы и ожидаете. Я надеюсь что Borland знает об этой проблеме и скоро ее исправит.

Здесь я должен пояснить, что ошибка как раз не в самом TMemo, а в TCustomEdit (в методе SetSelLength в stdctrls.pas). Поэтому данная проблема может наблюдаться во всех наследниках TCustomEdit (как TMemo).

- Bob Sherman [000954]

Вставка текста в TMemo

Как мне вставить какой-либо текст в TMemo в позицию курсора (во время выполнения программы)?

Прямого метода в Delphi не существует, но можно воспользоваться сообщениями Windows:

Delphi 2.0:

SendMessage(Memo.Handle, EM_REPLACESEL, 0, PCHAR('Текст'));

В Delphi 1.0 вы не сможете просто так преобразовать строку в Pchar, поэтому вам следует сделать следующее:

Var TempBuf :Array [0..255] of Char; SendMessage(Memo.Handle, EM_REPLACESEL, 0, StrPCopy(TempBuf,'Текст'));

Имейте в виду, что это ЗАМЕНЯЕТ любой выбранный текст. Если вам нужно этого избежать, присвойте предварительно свойству Delphi Memo.SelLength 0.

- Dave Berg [000924]

Вставка текста в TMemo II

Используйте сообщение Windows API EM_REPLACESEL: (из справки по Windows API) EM_REPLACESEL wParam = 0; /* не используется, должен быть ноль */ lParam = (LPARAM) (LPCSTR) lpszReplace; /* адрес новой строки */ Для замены текущего выбранного текста в поле редактирования, приложение должно послать сообщение EM_REPLACESEL, где параметр lpszReplace содержит новый текст. Параметр Описание lpszReplace Значение lParam. Указатель на терминированную нулем строку, содержащую замещающий текст. { Указатель на строку } Возвращаемое значение Данное сообщение значение не возвращает. Комментарии Используйте сообщение EM_REPLACESEL, если вы хотите изменять только часть текста поля редактирования. Если вам нужно заменить весь текст, используйте сообщение WM_SETTEXT. В случае отсутствие выбранного текста, замещающий текст вставляется в текущую позицию курсора. Сделайте список с вашими стандартными фразами, и используйте события "OnClick" или "OnMouseDown" в комбинации с "Alt", "Shift" или "Ctrl". Пример: Когда пользователь нажимает клавишу "Alt" в комбинации с правой кнопкой мыши, выводится список заранее подготовленных фраз и выбранная вставляется в ваш TMemo-компонент.

Для вставки строки в Memo:

procedure TForm1.Button1Click(Sender: TObject); begin with Memo1 do begin SelStart:=10; SelLength:=0; SelText:='Эта строка включается в Memo, начиная с 10-й позиции '; end; end;

Для вставки строки И замены некоторого существующего текста:

procedure TForm1.Button1Click(Sender: TObject); begin with Memo1 do begin SelStart:=10; SelLength:=20; SelText:='Эта строка включается в Мемо, начиная с 10-й позиции и замещает собой 20 символов '; end; end;

Поместите текст, который вы хотите вставить, в переменную PChar, затем вставьте текст в Memo, используя команду SetSelTextBuf, где SelStart устанавливается в позицию курсора TMemo. Это классно работает ..

Другая полезность: вы можете обхойти предел TMemo в 32K в случае, если вы загружаете в него текст, пользуясь методом/командой Lines.LoadfromFile. Компонент имеет внутренний предел в 32K. Если вы загружаете нужный файл в указатель, и используете команду/метод SetTexBuf, то в этом случае в TMemo можно загрузить текста вплоть до 64K. [001544]

Советы по Delphi

Битный указатель

Все указатели в Delphi 32-битные. Вот простой тест. Разместите следующий код в обработчике события нажатия кнопки, и вы получите интересующую вас информацию.

ShowMessage( Format('Указатель имеет размер %d, или являются %d-битными', [sizeof(pointer),8*sizeof(pointer)]) );

Я думаю что вы путаете размер элемента данных с тем, как это может быть интерполировано на физический адрес. "Указатели" даже на старых 8086/8088 процессорах были 32-битные по величине; включали в себя 16-битный сегмент и 16-битное смещение, которые, наконец, объединились, чтобы создать 20-битный физический адрес; некоторые другие комбинации сегмента и смещения могли указывать на ту же самый адрес физической памяти, что приводило к необходимости "нормализации" указателей для некоторых целей.

Для 16-битного расширенного (Enhanced) режима Windows, указатели во всех Borland Pascal продуктах были интра-сегментированные (intra-segment), то есть, часть "сегмента" данного указателя должна всегда была работать с расширенным селектором памяти (extended memory selector); и затем учитывать следующее за ним 16-битное "смещение"; данная seg/ofs (сегмент/смещение) модель могла дать для структуры данных максимум 64kb. Windows содержит методы преодоления этого ограничения (например, использование процедуры _AHIncr), но это не происходит автоматически, как в случае с C-шной "Huge" (огромный) -директивой для данных. В этом случае 16-битная версия Delphi не имеет в своем арсенале "Huge"-указателей. 32-битная Delphi решает эту проблему.

Насколько я в курсе, код VCL позволяет читать более, чем 64k bitmap (для примера), используя (и хорошо это скрывая) системные клуджи (Windows kludges); посмотрите код VCL, и вы поймете, как это можно сделать в Delphi.

Да, но они 16:16 указатели, а не 16:32, которые вы, вероятно, хотели.

Господа, мы тут говорим о разных вещах. Если C DLL компилируются 16-битным компилятором, указатели в Delphi будут АБСОЛЮТНО совместимыми и 16:16-битными far- и huge- указателями в C (или C++). Проблем абсолютно никаких. Просто передавайте их...

С другой стороны, если приложение C (или C++) является Win32-приложением, оно пользуется только 32-битными смещениями. Сегменты (соответственно больше селекторов) невидимы и ведут отсчет от нулевого линейного базового адреса.

Обратите внимание, что речь идет о приложениях. Компоненты нулевого кольца (Ring 0) также используют 32-битные указатели, но в то же время изредка могут пользоваться и 48-битными. VXD - компоненты нулевого кольца.

Для вызова 16-битных приложений, вы просто делаете это. Ничего специально делать не нужно. Для вызова таких приложений из Win32-приложений, необходимо воспользоваться так называемыми "санками" (thunk). В таком случае не обойдешься простой заменой указателей, необходимо также сменить 16-битный стек на 32-битный. И много еще чего. Если ваша проблема только в этом, то поищите в Интернете файл CALL32NT.ZIP, он как раз этим и занимается. [001974]

Быстрое сравнение памяти

Я ищу функцию, которая была бы эквивалентом сишной функции memcmp.

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

function Keys_are_Equal(var OldRec, NewRec; KeyLn : word): boolean; assembler; asm PUSH    DS MOV     AL,01 CLD LES     DI,NewRec LDS     SI,OldRec MOV     CX,KeyLn CLI REPE    CMPSB STI JZ      @1 XOR     AL,AL @1: POP     DS end; function First_Key_is_Less(var NewRec, OldRec; Keyln : word): boolean; assembler; asm PUSH    DS MOV     AL,01 CLD LES     DI,NewRec LDS     SI,OldRec MOV     CX,KeyLn CLI REPE    CMPSB STI JZ      @5 JGE     @6 @5: XOR     AL,AL @6: POP     DS end;

- Dennis Passmore [000860]

Динамическое распределение памяти I

uses WinCRT; procedure TForm1.Button1Click(Sender: TObject); var MyArray: array[0..30] of char; b: ^char; i: integer; begin StrCopy(MyArray, 'Спасибо Ллойду за помощь!!!'); b := @MyArray; for i := StrLen(MyArray) downto 0 do begin write(b^); inc(b, sizeof(char)); end; end;

[000361]

Динамическое распределение памяти II

Как мне уменьшить количество занимаемой мной памяти в сегменте данных? (или как мне распределять память динамически?)

Скажем, ваша структура данных выглядит похожей на эту:

type TMyStructure = record Name: String[40]; Data: array[0..4095] of Integer; end;

Она слишком большая для глобального распределения, так что вместо объявления глобальной переменной,

var MyData: TMyStructure;

объявляете указательный тип,

type PMyStructure = ^TMyStructure;

и переменную этого типа,

var MyDataPtr: PMyStructure;

Такой указатель занимает всего лишь четыре байта сегмента данных.

Прежде, чем вы сможете использовать структуру данных, вы должны распределить ее в куче:

New(MyDataPtr);

и получить к ней доступ через глобальные данные любым удобным для вас способом. Единственное отличие от традиционного способа заключается в необходимости использования символа "^" для обозначения указателя на данные:

MyDataPtr^.Name := 'Советы по Delphi'; MyDataPtr^.Data[0] := 12345;

И, наконец, после использования памяти, освободите ее:

Dispose(MyDataPtr);

[000936]

В Delphi 1, для того, чтобы получить самый большой возможный участок памяти, мы могли использовать функцию MemAvail, существует ли эквивалент этой функции в Delphi 2?

Нет. Но чтобы получить аппроксимированную сумму доступной памяти, можно воспользоваться функцией API GlobalMemoryStatus (через поле dwAvailVirtual возвращаемой структуры TMemoryStatus).

-Steve Schafer [001119]

Как работать с блоками памяти размером более 64K?

Nomadic советует:

Так можно помещать в один блок памяти записи из TList (TCollection):

imlementation { To use the value of AHIncr, use Ofs(AHIncr). } procedure AHIncr; far; external 'KERNEL' index 114; const NEXT_SELECTOR: string[13] = 'NEXT_SELECTOR'; function WriteData: THandle; var DataPtr: PChar; i: Integer; begin Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, {pазмеp большого блока}); if Result = 0 then Exit; DataPtr := GlobalLock(Result); {записываем кол-во эл-тов} Inc(DataPtr, {pазмеp счетчика эл-тов}) for i := 0 to {некий}Count-1 do begin if LongInt(PtrRec(DataPtr).Ofs) + {pазмеp подблока} &gtl= $FFFF then begin Move(NEXT_SELECTOR, DataPtr^, SizeOf(NEXT_SELECTOR)); {некая константа} { коppекция сегмента } PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr); PtrRec(DataPtr).Ofs := $0; end; Inc(DataPtr, {pазмеp нового блока}); end; { for i } GlobalUnlock(Result); end; procedure ReadData(DataHdl: THandle); var DataPtr : PObjectCfgRec; RecsCount: Integer; i: Integer; begin if DataHdl = 0 then Exit; DataPtr := GlobalLock(DataHdl); RecsCount := PInteger(DataPtr)^; Inc(PInteger(DataPtr)); for i := 1 to RecsCount do begin { обpаботать данные } Inc(DataPtr); if PString(DataPtr)^ = NEXT_SELECTOR then begin PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr); PtrRec(DataPtr).Ofs := $0; end; end; { for i } GlobalUnlock(DataHdl); end;

[001222]

Кое-что об объектах и использовании памяти

Объекты определенно распределяются из из глобальной кучи, хотя я до сих пор не нашел ни в одной электронной справке описание данного процесса. (На 99% я уверен, что оно существует, но на данный момент я его не нашел).

Delphi имеет собственный "распределитель" памяти для объектов, ею создаваемых. Для получения дополнительной информации обратитесь к электронной справке к главе "Memory", разделу "Heap Manager". Я предполагаю, что в этом описании в качестве метода для распределения памяти вновь создаваемого экземпляра объекта используется New или GetMem. (У меня нет перед собой исходного кода метода TObject Create, поэтому я не уверен на 100%).

Согласно Генеральной Филосифии Delphi, создаваемые [методом Create] объекты обязательно должны освобождаться [методом Free]. Кидаемые на форму компоненты создаются "на лету", и освобождаются при их удалении с формы. Подумайте над этим, это очень важно. Правда, в коде необычные ситуации могут потребовать неординарных действий. [001975]

Количество памяти, занимаемой глобальными переменными

В опциях компоновщика вы можете выставить флаг "create a map file", перекомпилировать проект, и посмотреть на получившийся файл. Там можно найти размер сегмента для глобальных переменных и данных. [001979]

Предел сегмента данных в 64K

Из раскопок:

В: Может ли Borland Pascal использовать статические переменные с размером более чем 64 килобайта? О: Нет! В: Вы говорите *статические* переменные. Неужели есть что-то еще, с чем можно работать? О: Да, смотри ниже одно из решений проблемы. Можете не тратить время на чтение следующего текста, все равно это не работает, можете смело скроллировать вниз. В: Поможет разделение большого массива на несколько маленьких (все элементы меньше чем 64k, но в сумме больше чем 64k)? О: Нет! В: Поможет объявление нескольких переменных в модуле? О: Нет! В: Поможет объявление чего-либо в секции реализации модуля? О: Нет! В: Поможет использование защищенного режима Borland Pascal 7? A: Нет! В: Вы уверены?? О: Да!! В: Почему?? О: Во-первых, все программы, созданные на Borland Pascal, для любых переменных используют только один сегмент данных, во-вторых, процессоры Intel 80xxx ограничивают размер сегмена 64 килобайтами. В: Это глупо!! О: Скажите это Borland!! (Или Intel, ...или обоим). В: Есть ли выход из тупика? О: Да! Возможны два решения:

1) не используйте *СТАТИЧЕСКИЕ* переменные для хранения данных большого размера. В итоге это позволит разместить более чем 64k данных, но весь массив данных в 64k не поместится, таким образом вы его поделите на несколько частей, что не является решением проблемы. Сделайте переменные динамическими.

2) используйте другой компилятор: есть несколько доступных компиляторов языка Pascal, которые более-менее Borland-совместимые и не имеют таких ограничений (они 32-битные).

В: Почему Borland Pascal не имеет 32-битного компилятора? О: Да, он весьма древний. Сообщите Borland, что вы хотите новую версию. В: Что такое не-статическая память? О: Для примера Куча, XMS, EMS, ... Куча доступна непосредственно, для XMS необходим драйвер (himem.sys), для EMS тоже (HIMEM.SYS + EMM386.EXE) и он обычно доступен не на всех компьютерах, так что лучше использовать XMS вместо EMS. В: Что такое Куча? О: Куча - вся свободная память ниже 640-килобайтной границы в режиме реального времени, в защищенном режиме (доступном только в Borland Pascal 7) - вся свободная память ниже 16-мегабайт (обычно *ВСЯ* свободная память, но мы здесь говорим о Borland Pascal). В: Каким образом можно воспользоваться Кучей? О: Доступ к памяти Кучи возможен только с помощью указателей. Посмотрите на этот пример, вы можете использовать эту технологию в ваших программах:

type arr    = array [1..30000] of longint; { это ваши данные } arrptr = ^arr;                        { это указатель на данные } var data : arrptr;       { это переменная, содержащая указатель } begin if memavail < sizeof(arr) then halt;  { проверяем наличие доступной памяти } new (data);                           { распределяем память } for i := 1 to 30000 do data^[i]:=0;   { используем ее, обратите здесь внимание на символ ^ !! } dispose (data);                       { освобождаем память } end.

Примечание: данные можно описать и таким способом:

var data : array [1..10000] of arrptr;

В: Есть ли недостатки у данного решения? О: Да! Это медленно и немного опасно. В: Опасность заключается в использовании Кучи? О: Да!

Всегда распределяйте память Кучи прежде, чем вы решитесь ее использовать. В противном случае вы можете получить одну из следующих ошибок системы: при использовании программ, разработанных на C - "General Protection Violation" (Общее нарушение защиты), разработанных с использованием других инструментов и языков - "Protected Mode Exception #13" (Исключительная ситуация защищенного режима) или иные. В режиме реального времени программа обычно не вызывает такую ошибку, она просто молча перезапишет другие данные, или то, что попадется под руку - саму себя, другие программы, DOS, все, что может оказаться в памяти.
Это может повлечь за собой все что угодно, вплоть до холодной перезагрузки с выключением PC от сети, но может и не иметь никакого эффекта. В особо крайнем случае возможна перезапись данных на жестком диске. Но это в теории и вряд ли возможно. В: Как я могу использовать XMS память? О: По адресу http://www.brain.uni-freiburg.de/~klaus/pascal/sources/ расположен модуль, который позволяет использовать XMS. В: Как насчет других компиляторов Pascal? О: Проверьте FPK-Pascal и GNU-Pascal. Они оба являются свободно распространяемыми 32-битными компиляторами Pascal для DOS и более-менее Borland-совместимые. Если вам необходим компилятор Pascal для Linux или OS/2, то два вышеупомянутых компилятора доступны также и для этих операционных систем, плюс некоторые другие, смотри http://www.brain.uni-freiburg.de/~klaus/pascal/web-list.html. В: Это звучит так, будто автор не любит Borland Pascal, не правда ли? О: Неправда, я *люблю* их и пользуюсь ими все время, но я *не люблю*, когда Borland не предлагает их новые версии. В: Как насчет Delphi? О: Не доступен для DOS,
Не доступен для Linux,
Не доступен для OS/2.
[000147]

???? Слишком большой сегмент данных ???? I

Я получаю сообщение 'Data segment too large'. Что за проблема и как мне ее решить?

В Windows 3.1 приложениях три специализированных области памяти занимают один (!) сегмент памяти объемом 64K: системная 'локальная куча' и два сегмента, содержащие все глобальные и инициализированные константы. Эта область памяти может быть израсходована очень быстро.

Вот почему W3.1 приложения практически -ничего- не хранят в куче или в глобальных переменных. Предпочтительно сохранение -указателей-. Вот объяснение того, почему в Delphi 'объект как указатель.'

В вашем случае рекомендую все большие глобальные переменные переместить в общий блок данных, который распределяет при запуске сама программа (как объект) и уничтожить их при выходе. Вы можете просмотреть содержимое сегмента данных, установив флажок 'linker map' в 'detailed' и просмотрев сегмент 'DATA'. Все данные, записываемые в данный участок памяти, пытаются расположиться в нижней части этого 64K-сегмента.

[000269]

---

---