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

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


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

БОЛЬШОЙ FAQ ПО DELPHI



Мраморное окно

Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно сделать для того, чтобы ваше окно выглядело так же эффектно, как и показанное на рисунке , это только написать несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:


 procedure TForm1.FormPaint(Sender: TObject);
 var
   i, j: Integer;
 begin
   with Form1.Canvas do
     for j := 0 to Form1.Height do
       for i := 0 to Form1.Width do
         Pixels[i, j] := Trunc(Random($00000095));
 end;
 

С помощью двух циклов мы обошли поверхность окна (канву) и каждому пикселю задали случайный оттенок нужного цвета. (Для тех, кто не знает, ПИКСЕЛЬ - это мельчайшая точка). Цвет задаём 16-ричным кодом, например я указал: $00000095. Получилось весьма неплохо :-)) Вы можете изменить цвет.

Второй способ (более быстрый):


 procedure TForm1.FormPaint(Sender: TObject);
 var
   h, w, i, j: Integer;
   Rect1, Rect2: TRect;
 begin
   h := Form1.Height div 10;
   w := Form1.Width div 10;
   with Form1.Canvas do
   begin
     for j := 0 to h do
       for i := 0 to w do
         Pixels[i,j]:=Trunc(Random($00000095));
 
     Rect1 := Rect(0, 0, w, h);
     for j := 0 to 9 do
     begin
       for i := 0 to 9 do
       begin
         Rect2 := Rect(w*j, h*i, w*(j+1), h*(i+1));
         CopyRect(Rect2, Form1.Canvas, Rect1);
       end;
     end;
   end;
 end;
 




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

- А чем отличается программист от простого смертного?
- Тем, что может дать ответ на вопрос, уже содержащий в себе сам ответ.
- Да, это как?
- Ну, например:
- сколько будет 2 x 2=4?
- TRUE


 unit MathComponent;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, math;
 
 type
   TMathtype = (mtnil, mtoperator, mtlbracket, mtrbracket, mtoperand);
 
 type
   TMathOperatortype = (monone, moadd, mosub, modiv, momul, mopow);
 
 type
   pmathchar = ^Tmathchar;
   TMathChar = record
   case mathtype: Tmathtype of
     mtoperand:(data:extended);
     mtoperator:(op:TMathOperatortype);
   end;
 
 type
   TMathControl = class(TComponent)
   private
     input, output, stack: array of tmathchar;
     fmathstring: string;
     function getresult:extended;
     function calculate(operand1,operand2,operator:Tmathchar):extended;
     function getoperator(c:char):TMathOperatortype;
     function getoperand(mid:integer;var len:integer):extended;
     procedure processstring;
     procedure convertinfixtopostfix;
     function isdigit(c:char):boolean;
     function isoperator(c:char):boolean;
     function getprecedence(mop:TMathOperatortype):integer;
   protected
   published
     property MathExpression:string read fmathstring write fmathstring;
     property MathResult:extended read getresult;
   end;
 
 procedure register;
 
 implementation
 
 function Tmathcontrol.calculate(operand1,operand2,operator:Tmathchar):extended;
 begin
   result:=0;
   case operator.op of
     moadd:
       result:=operand1.data + operand2.data;
     mosub:
       result:=operand1.data - operand2.data;
     momul:
       result:=operand1.data * operand2.data;
     modiv:
       if (operand1.data<>0) and (operand2.data<>0) then
         result:=operand1.data / operand2.data
       else
         result := 0;
     mopow:
       result:=power(operand1.data, operand2.data);
   end;
 end;
 
 function Tmathcontrol.getresult:extended;
 var
   i:integer;
   tmp1,tmp2,tmp3:tmathchar;
 begin
   convertinfixtopostfix;
   setlength(stack,0);
   for i:=0 to length(output)-1 do
   begin
     if output[i].mathtype=mtoperand then
     begin
       setlength(stack,length(stack)+1);
       stack[length(stack)-1]:=output[i];
     end
     else
     if output[i].mathtype=mtoperator then
     begin
       tmp1:=stack[length(stack)-1];
       tmp2:=stack[length(stack)-2];
       setlength(stack,length(stack)-2);
       tmp3.mathtype:=mtoperand;
       tmp3.data:=calculate(tmp2,tmp1,output[i]);
       setlength(stack,length(stack)+1);
       stack[length(stack)-1]:=tmp3;
     end;
   end;
   result:=stack[0].data;
   setlength(stack,0);
   setlength(input,0);
   setlength(output,0);
 end;
 
 function Tmathcontrol.getoperator(c:char):TMathOperatortype;
 begin
   result:=monone;
   if c='+' then
     result:=moadd
   else
   if c='*' then
     result:=momul
   else
   if c='/' then
     result:=modiv
   else
   if c='-' then
     result:=mosub
   else
   if c='^' then
     result:=mopow;
 end;
 
 function Tmathcontrol.getoperand(mid:integer;var len:integer):extended;
 var
   i,j:integer;
   tmpnum:string;
 begin
   j:=1;
   for i:=mid to length(fmathstring)-1 do
   begin
     if isdigit(fmathstring[i]) then
     begin
       if j<=20 then
         tmpnum:=tmpnum+fmathstring[i];
       j:=j+1;
     end
     else
       break;
   end;
   result:=strtofloat(tmpnum);
   len:=length(tmpnum);
 end;
 
 procedure Tmathcontrol.processstring;
 var
   i:integer;
   numlen:integer;
 begin
   i:=0;
   numlen:=0;
   setlength(output,0);
   setlength(input,0);
   setlength(stack,0);
   fmathstring:='('+fmathstring+')';
   setlength(input,length(fmathstring));
   while i<=length(fmathstring)-1 do
   begin
     if fmathstring[i+1]='(' then
     begin
       input[i].mathtype:=mtlbracket;
       i:=i+1;
     end
     else
     if fmathstring[i+1]=')' then
     begin
       input[i].mathtype:=mtrbracket;
       i:=i+1;
     end
     else
     if isoperator(fmathstring[i+1]) then
     begin
       input[i].mathtype:=mtoperator;
       input[i].op:=getoperator(fmathstring[i+1]);
       i:=i+1;
     end
     else
     if isdigit(fmathstring[i+1]) then
     begin
       input[i].mathtype:=mtoperand;
       input[i].data:=getoperand(i+1,numlen);
       i:=i+numlen;
     end;
   end;
 end;
 
 
 function Tmathcontrol.isoperator(c:char):boolean;
 begin
   result:=false;
   if (c='+') or (c='-') or (c='*') or (c='/') or (c='^') then
     result:=true;
 end;
 
 function Tmathcontrol.isdigit(c:char):boolean;
 begin
   result:=false;
   if ((integer(c)> 47) and (integer(c)< 58)) or (c='.') then
     result:=true;
 end;
 
 function Tmathcontrol.getprecedence(mop:TMathOperatortype):integer;
 begin
   result:=-1;
   case mop of
     moadd: result := 1;
     mosub: result := 1;
     momul: result := 2;
     modiv: result := 2;
     mopow: result := 3;
   end;
 end;
 
 procedure Tmathcontrol.convertinfixtopostfix;
 var
   i,j,prec:integer;
 begin
   processstring;
   for i:=0 to length(input)-1 do
   begin
     if input[i].mathtype=mtoperand then
     begin
       setlength(output,length(output)+1);
       output[length(output)-1]:=input[i];
     end
     else
     if input[i].mathtype=mtlbracket then
     begin
       setlength(stack,length(stack)+1);
       stack[length(stack)-1]:=input[i];
     end
     else
     if input[i].mathtype=mtoperator then
     begin
       prec:=getprecedence(input[i].op);
       j:=length(stack)-1;
       if j>=0 then
       begin
         while(getprecedence(stack[j].op)>=prec) and (j>=0) do
         begin
           setlength(output,length(output)+1);
           output[length(output)-1]:=stack[j];
           setlength(stack,length(stack)-1);
           j:=j-1;
         end;
         setlength(stack,length(stack)+1);
         stack[length(stack)-1]:=input[i];
       end;
     end
     else
     if input[i].mathtype=mtrbracket then
     begin
       j:=length(stack)-1;
       if j>=0 then
       begin
         while(stack[j].mathtype<>mtlbracket) and (j>=0) do
         begin
           setlength(output,length(output)+1);
           output[length(output)-1]:=stack[j];
           setlength(stack,length(stack)-1);
           j:=j-1;
         end;
         if j>=0 then
           setlength(stack,length(stack)-1);
       end;
     end;
   end;
 end;
 
 procedure register;
 begin
   RegisterComponents('Samples', [TMathControl]);
 end;
 
 end.
 




Математика времени

Рaспорядок рaбочего дня программиста:
7:00 Открыли глaзки, посмотрели нa чaсы, плюнули (мысленно), решили поспaть еще полчaсикa, зaкрыли глaзки.
7:30 открыли глaзки, посмотрели нa чaсы, решили поспaть еще четверть чaсa, зaкрыли глaзки.
7:52 открыли глaзки, вымaтерились (мысленно), подумaли о смысле жизни, подумaли еще рaзок, искосa посмотрели нa одежду, вымaтерились (мысленно).
7:58 вскочили, побрились, умылись, приготовили зaвтрaк, съели его, почистили ботинки, нaшли рубaшку, оделись, пробежaлись до метро.
8:20 поспaли в метро, почитaли книжку, ничего не поняли, поспaли в метро.
9:20 опоздaли нa рaботу, включили компьютер, пошли покурить.
9:30 попытaлись согнaть с компa игрaющих.
9:40 попытaлись согнaть с компa игрaющих.
9:50 попытaлись согнaть с компa игрaющих.
10:00 попытaлись согнaть с компa игрaющих.
10:10 попытaлись согнaть с компa игрaющих.
10:20 попытaлись согнaть с компa игрaющих.
10:30 попытaлись согнaть с компa игрaющих.
10:40 согнaли игрaющих, от переутомления пошли курить.
10:50 нaорaли нa игрaющих, сели рaботaть.
11:00 вспомнили, в чем зaключaется рaботa.
11:01 проголодaлись, пошли в буфет.
11:32 вернулись из буфетa, дaли по морде игрaющим, сели рaботaть.
11:38 пришлa глaвбухшa, попросилa рaсскaзaть про бухгaлтерскую прогрaмму.
12:30 объяснили глaвбухше, пошли курить.
12:40 стукнули по голове игрaющим, сели рaботaть.
13:20 нaписaли две строки прогрaммы, нaчaли отлaживaть, не получилось, пошли курить.
13:30 продолжили отлaдживaть нaписaнные две строки.
15:03 нaписaли еще 120 строк.
15:22 отлaдили их.
15:23 пошли курить.
15:33 покурили, сели рaботaть.
15:50 зaвис, сволочь, помaтерились (мысленно), рaзобрaли, контроллеры пошевелили, молотком стукнули, зaрaботaл.
16:20 проголодaлись, пошли обедaть.
17:00 убили игрaющих, сели прогрaммки писaть.
17:08 поняли, что головa не вaрит.
17:10 поняли, что головa совсем не вaрит.
17:14 поняли, что головa совершенно aбсолютно не вaрит.
17:15 посмотрели нa чaсы, вздохнули, зaпустили ГолдЕд, создaли видимость усиленной деятельности.
17:59 собрaлись, выключили комп, попрaвили гaлстук, одели пиджaк.
18:00 пошли домой.
18:05 в метро поспaли, место никому не уступили (свиньи мы).
19:00 пришли домой, поужинaли, нa мессaги ответили, ответы перетоссировaли, нa котa нaорaли, успокоились.
22:00 фронду постaвили, пошли нa второй ужин.
23:44 свежaя почтa пришлa, нa дискеты ее покидaли.
0:00 с юзерaми почaтились, побaзaрили.
3:56 нa чaсы глянули, офигели, спaть легли.
7:00 Открыли глaзки, посмотрели нa чaсы, плюнули (мысленно), решили поспaть еще полчaсикa...

Работа с временными величинами в Delphi очень проста, если пользоваться встроенными функциями преобразования. Определите глобальные Hour, Minute, Second и инициализируйте их следующим образом:


 Hour   := EncodeTime(1,0,0,0);
 Minute := EncodeTime(0,1,0,0);
 Second := EncodeTime(0,0,1,0);
 

Или, если вы предпочитаете константы, сделайте так:


 Hour = 3600000/MSecsPerDay;
 Minute = 60000/MSecsPerDay;
 Second = 1000/MSecsPerDay;
 

Теперь для того, чтобы добавить 240 минут к переменной TDateTime, просто сделайте


 T := T + 240*Minute;
 




Описание функций модуля Math

Тригонометрические функции и процедуры

  • ArcCos - Арккосинус
  • ArcCosh - Пиперболический арккосинус
  • ArcSIn - Арксинус
  • ArcSInh - Гиперболический арксинус
  • ArcTahn - Гиперболический арктангенс
  • ArcTan2 - Арктангенс с учетом квадранта (функция ArcTan, не учитывающая квадрант, находится в модуле System)
  • Cosh - Гиперболический косинус
  • Cotan - Котангенс
  • CycleToRad - Преобразование циклов в радианы
  • DegToRad - Преобразование градусов в радианы
  • GradToRad - Преобразование градов в радианы
  • Hypot - Вычисление гипотенузы прямоугольного треугольника по длинам катетов
  • RadToCycle - Преобразование радианов в циклы
  • RadToDeg - Преобразование радианов в градусы
  • RacIToGrad - Преобразование радианов в грады
  • SinCos - Вычисление синуса и косинуса угла. Как и в случае SumAndSquares и MeanAndStdDev, одновременная генерация обеих величин происходит быстрее
  • Sinh - Гиперболический синус
  • Tan - Тангенс
  • Tanh - Гиперболический тангенс

Арифметические функции и процедуры

  • Cell - Округление вверх
  • Floor - Округление вниз
  • Frexp - Вычисление мантиссы и порядка заданной величины
  • IntPower - Возведение числа в целую степень. Если вы не собираетесь пользоваться экспонентами с плавающей точкой, желательно использовать эту функцию из-за ее скорости
  • Ldexp - Умножение Х на 2 в заданной степени
  • LnXPI - Вычисление натурального логарифма Х+1. Рекомендуется для X, близких к нулю
  • LogN - Вычисление логарифма Х по основанию N
  • LogIO - Вычисление десятичного логарифмах
  • Log2 - Вычисление двоичного логарифмах
  • Power - Возведение числа в степень. Работает медленнее IntPower, но для операций с плавающей точкой вполне приемлемо

Финансовые функции и процедуры

  • DoubleDecliningBalance - Вычисление амортизации методом двойного баланса

 function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended;
 

Функция вычисляет амортизационные отчисления на определенном этапе. В качестве параметров используются: начальная стоимость Cost, срок службы Life, конечная стоимость Salvage и амортизационный период Period. Вычисления производятся по следующим формулам:

Период Сумма амортизационных отчислений
1 А1:= Cost*2/Life
2 А2:= (Cost-А1)*2/Life
3 А3:= (Cost-А1-А2)*2/Life
... ...
n Аn:= (Cost-А1-А2 - ... - Аn-1)*2/Life
где n=Period
 

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

Пример:


 var
   A: Extended;
 begin
   A := DoubleDecliningBalance(1000, 100, 5, 1); { A:=400 }
 end;
 

  • FutureValue - Будущее значение вложения

 function FutureValue(Rate: Extended; NPeriods: Integer;
 Payment, PresentValue: Extended; PaymentTime: TPaymentTime ): Extended;
 

Функция вычисляет значение вклада по прошествии определенного периода времени.

  • NPeriods - количество прошедших единиц периода времени. Например, если проценты начисляются раз в год, то данный параметр определяет количество лет.
  • PresentValue - первоначальная сумма вклада.
  • В параметре Payment указывается сумма, которая будет добавляться вкладчиком ко вкладу в течение каждой единицы периода времени. Если вклад осуществляется только один раз, то Payment:=0.
  • Rate - дивиденты, начисляемые за единицу периода.
  • Параметр PaymentTime определяет, как должны начисляться проценты:
PtStartOfPeriod
Проценты начисляются в конце единицы периода времени на всю сумму, находящуюся на момент начисления на счету.
ptEndOfPeriod
Проценты начисляются только на сумму, которая находилась на счету в начале единицы периода времени. Т.е. на сумму, которая была добавлена вкладчиком к вкладу в течение последней единицы времени, проценты будут начислены по прошествии следующего периода.

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

Пример:

Первоначальный вклад составил 100 руб. дивиденды - 10% годовых. Ежегодно вкладчик добавляет к вкладу 50 руб. Проценты начисляются в конце года только на сумму, которая находилась на счету в начале года, т.е. проценты на сумму, которая была добавлена к вкладу в течение года будут начислены только в конце следующего года. Вычисляем сумму вклада через 5 лет.


 var
   Sum: Extended;
 begin
   Sum := FutureValue(0.1, 5, 50, 100, ptEndOfPeriod);
   { Sum:= -466.306 }
 end;
 

  • InterestPayment - Вычисление процентов по ссуде

 function InterestPayment(Rate: Extended; NPeriods: Integer;
 PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
 

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

  • PresentValue - сумма кредита.
  • Rate - фиксированная процентная ставка кредита.
  • NPeriods - число этапов, в течение которых производятся выплаты.
  • Period - номер этапа выплат, для которого производятся вычисления.
  • FutureValue - значение суммы кредита, по истечении выплат.
  • Параметр PaymentTime определяет, происходят выплаты в начале (PtStartOfPeriod) этапа или в конце (ptEndOfPeriod).

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

Пример:


 var
   Pay: Extended;
 begin
   Pay := InterestPayment(0.1, 1, 5, 1000, 0, PtStartOfPeriod);
   { Pay:= -90.9090909090909 }
 end;
 

  • InterestRate - Норма прибыли, необходимая для получения заданной суммы

 function InterestRate(NPeriods: Integer; Payment, PresentValue,
 FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
 

Функция вычисляет процентную ставку инвестиций, необходимую для возврата суммы инвестиций PresentValue с дивидендами.

  • PresentValue - сумма инвестиций.
  • FutureValue - полная сумма, полученная от инвестиций. Включает возврат первоначальной суммы инвестиций и дивиденды.
  • NPeriods - количество этапов выплат.
  • Payment - сумма периодических выплат.
  • Параметр PaymentTime определяет, происходят выплаты в начале (PtStartOfPeriod) этапа или в его конце (ptEndOfPeriod).

Пример:


 var
   IRate: Extended;
 begin
   IRate := InterestRate(1, -100, -1000, 1500, ptEndOfPeriod);
   { IRate:= 0.4 }
 end;
 

  • InternalRateOfReturn - Вычисление внутренней скорости оборота вложения для ряда последовательных выплат

 function InternalRateOfReturn(Guess: Extended;
 const CashFlows: array of Double): Extended;
 

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

Пример:


 var
   IRate: Extended;
   CashFlows: array of Double;
 begin
   SetLength(CashFlow, 2);
   CashFlow[0]:=-1000;
   CashFlow[1]:= 1200;
   IRate:= InternalRateOfReturn(0, CashFlow);
   { IRate:= 0.4 }
 end;
 

  • NetPresentValue - Вычисление чистой текущей стоимости вложения для ряда последовательных выплат с учетом процентной ставки

 function NetPresentValue(Rate: Extended; const CashFlows: array of Double;
 PaymentTime: TPaymentTime): Extended;
 

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

  • Параметр Rate - определяет процентную ставку инвестиций.
  • CashFlows - массив расчетных значений текущих платежей.
  • Параметр PaymentTime указывает, происходят выплаты в начале (PtStartOfPeriod) или в конце (ptEndOfPeriod) платежного этапа.

Пример


 var
   PayValue: Extended;
   CashFlows: array of Double;
 begin
   SetLength(CashFlow, 3);
   CashFlow[0]:=-100;
   CashFlow[1]:= 110;
   CashFlow[2]:= 121;
   PayValue:= NetPresentValue (0.1, CashFlow, PtStartOfPeriod);
   { PayValue:= 100 }
 end;
 

  • NumberOf Periods - Количество периодов, за которое вложение достигнет заданной величины

 function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;
 PaymentTime: TPaymentTime): Extended;
 

Функция определяет количество этапов, необходимых для погашения кредита до значения определенного в параметре FutureValue.

  • PresentValue - первоначальная сумма кредита.
  • Rate - процентная ставка.
  • Payment - величина регулярных выплат.
  • Параметр PaymentTime определяет, происходят выплаты в начале (PtStartOfPeriod) этапа или в его конце (ptEndOfPeriod).

Пример:

Первоначальная сумма кредита составляет 364руб. Процентная ставка 20%. Регулярные ежемесячные выплаты по 100руб производятся в конце месяца. Рассчитаем сколько месяцев необходимо для полной выплаты кредита.


 var
   Np: Extended;
 begin
   Np := NumberOfPeriods (0.2, 100, 364, 0, ptEndOfPeriod);
   { Np:= -3 }
 end;
 

  • Payment - Размер периодической выплаты, необходимой для погашения ссуды, при заданном числе периодов, процентной ставке, а также текущем и будущем значениях ссуды

 function Payment(Rate: Extended; NPeriods: Integer; PresentValue,
 FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
 

Функция вычисляет общую сумму погашения кредита, выплачиваемую на каждом этапе (состоит из текущих выплат и процентов).

  • PresentValue - сумма заимствования.
  • NPeriods - срок выплаты кредита. Данный пармаметр указывается количество этапов выплаты (количество лет, кварталов, месяцев и т.д.).
  • FutureValue - оставшаяся сумма кредита по истечении указанного периода.
  • Rate - величина процентной ставки кредита (ежегодная, ежеквартальная, ежемесячная и т.д. в соответствии с единицей измерения периода времени).
  • Параметр PaymentTime определяет, как происходят платежи: в начале (PtStartOfPeriod) или в конце (ptEndOfPeriod) платежного периода.

Пример:


 var
   PaySum: Extended;
 begin
   PaySum := Payment(0.2, 1, 100, 0, ptEndOfPeriod);
   { PaySum:=-120 }
 end;
 

  • PeriodPayment - Платежи по процентам за заданный период

 function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;
 PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
 

Функция вычисляет сумму выплат основной части кредита (без учета процентов) на определенном этапе.

  • PresentValue - сумма заимствований.
  • NPeriods - срок выплаты кредита (количество этапов).
  • FutureValue - сумма кредита по прошествии указанного срока.
  • Period - номер этапа, для которого производятся вычисления.
  • Rate - процентная ставка кредита.
  • Параметр PaymentTime определяет, как происходят платежи: в начале (PtStartOfPeriod) или в конце (ptEndOfPeriod) платежного периода.

Сумму выплачиваемых процентов кредита можно вычислить с помощью функции InterestPayment.

Пример:


 var
   PaySum: Extended;
 begin
   PaySum := PeriodPayment(0.1, 2, 5, 1000, 0, ptEndOfPeriod);
   { PaySum:= -180.17722887422 }
 end;
 

  • PresentValue - Текущее значение вложения

 function PresentValue(Rate: Extended; NPeriods: Integer; Payment, FutureValue: Extended;
 PaymentTime: TPaymentTime): Extended;
 

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

  • Payment - первоначальная сумма вклада.
  • NPeriods - срок вклада.
  • Rate - процентная ставка.
  • FutureValue - значение, которого могут достигнуть инвестиции в определенный период.
  • Параметр PaymentTime указывает, как происходят платежи: в начале (PtStartOfPeriod) или в конце (ptEndOfPeriod) платежного периода.

Пример:


 var
   Value: Extended;
 begin
   Value := PresentValue(0.1, 1, -100, 0, ptEndOfPeriod);
   { Value:= 90,9090909090909 }
 end;
 

  • SLNDepreclatlon - Вычисление амортизации методом постоянной нормы

 function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;
 

Функция вычисляет сумму амортизационных отчислений за единицу периода времени по методу линейной (равномерной) амортизации.

  • Cost - первоначальную стоимость оборудования.
  • Salvage - конечная стоимость оборудования.
  • Life - срок эксплуатации.

Для вычисления амортизации по ускоренному методу используйте функцию SYDDepreciation.

Пример:


 var
   Amort: Extended;
 begin
   Amort := SLNDepreciation(1000, 200, 5);
   { Amort:= 160 }
 end;
 

  • SYDepreclatlon - Вычисление амортизации методом весовых коэффициентов

 function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended;
 

Функция вычисляет сумму амортизационных отчислений на заданном этапе по методу ускоренной амортизации.

  • Cost - первоначальная стоимость оборудования.
  • Salvage - конечная стоимость.
  • Life - срок эксплуатации.
  • Period - номер этапа, для которого определяется сумма амортизационных отчислений.

Для вычислений по методу равномерной амортизации используйте функцию SLNDepreciation.

Пример:


 var
   Amort: Extended;
 begin
   Amort := SYDDepreciation(1000, 100, 5, 1);
   {Amort:=300}
 end;
 

Статистические функции и процедуры

  • MaxIntValue - Максимальное значение в наборе целых чисел. Функция появилась в Delphi 3. ее не существует в Delphi 2
  • MaxValue - Максимальное значение в наборе чисел. В Delphi 2 функция возвращает минималъное значение
  • Mean - Среднее арифметическое для набора чисел
  • MeanAndStdDev - Одновременное вычисление среднего арифметического и стандартного отклонения для набора чисел. Вычисляется быстрее, чем обе величины по отдельности
  • MinIntValLie - Минимальное значение в наборе целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
  • MInValue - Минимальное значение в наборе чисел. В Delphi 2 функция возвращает максимальное значение
  • MoiiientSkewKurtosIs - Статистические моменты порядков с первого по четвертый, а также асимметрия (skew) и эксцесс (kurtosis) для набора чисел
  • Norm - Норма для набора данных (квадратный корень из суммы квадратов)
  • PopnStdDev - Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях используется выборочное значение дисперсии, PopnVarl апсе (см. ниже)
  • PopnVarlance - Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n
  • RandG - Генерация нормально распределенных случайных чисел с заданным средним значением и среднеквадратическим отклонением
  • StdDev - Среднеквадратическое отклонение для набора чисел
  • Sum - Сумма набора чисел
  • SLimsAndSquares - Одновременное вычисление суммы и суммы квадратов для набора чисел. Как и в других функциях модуля Math, обе величины вычисляются быстрее, чем по отдельности
  • Sumint - Сумма набора целых чисел. Функция появилась в Delphi 3, ее не существует в Delphi 2
  • SLimOfSquares - Сумма квадратов набора чисел
  • Total Variance - "Полная дисперсия" для набора чисел. Это сумма квадратов расстояний всех величин от их среднего арифметического
  • Variance - Выборочная дисперсия для набора чисел. Функция использует "несмещенную" формулу TotalVanапсе/(п -1)



Как развернуть форму на весь экран, как в играх


 interface
 
 uses
  Windows, Messages, SysUtils, Classes, Controls,
 Forms,
  StdCtrls;
 
 type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
 procedure WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo);
 message WM_GETMINMAXINFO;
 
  public
    { Public declarations }
  end;
 
 var
  Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 procedure TForm1.WMGetMinMaxInfo(var msg:
 TWMGetMinMaxInfo);
 begin
  inherited;
  with msg.MinMaxInfo^.ptMaxTrackSize do begin
    X := GetDeviceCaps( Canvas.handle, HORZRES ) +
 (Width - ClientWidth);
    Y := GetDeviceCaps( Canvas.handle, VERTRES ) +
 (Height - ClientHeight );
  end;
 
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
 Rect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
 FullScreen: Boolean = False;
 // Разворачиваем на весь экран
 begin
 FullScreen := not FullScreen;
 if FullScreen then begin
 Rect := BoundsRect;
 SetBounds( Left - ClientOrigin.X,
 Top - ClientOrigin.Y, GetDeviceCaps( Canvas.handle,
 HORZRES )
 + (Width - ClientWidth), GetDeviceCaps( Canvas.handle,
 VERTRES )
 + (Height - ClientHeight ));
                   end
 else BoundsRect := Rect;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
 Close;
 end;
 
 end.
 




Как качественно увеличить изображение при помощи билинейной интерполяции



- Как повысить pождаемость на планете?
- Заставить Microsoft выпускать пpезеpвативы!

Этот алгоритм увеличивает изображение в произвольное количество раз при помощи билинейной интерполяции. При создании нового изображения каждой его точке с целыми координатами (x,y) сопоставляется точка исходного изображения с дробными координатами (xo, yo), xo=x/dx, yo=y/dy (dx и dy – коэффициенты увеличения). Далее нужно провести поверхность через точки, лежащие вокруг (xo, yo). Цвет здесь рассматривается как третье измерение. На поверхности ищется точка с координатами (xo, yo) и ее цвет понимается за цвет точки (x,y) получаемого изображения.

Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения. Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит.


 procedure Interpolate(var bm: TBitMap; dx, dy: single);
 var
   bm1: TBitMap;
   z1, z2: single;
   k, k1, k2: single;
   x1, y1: integer;
   c: array [0..1, 0..1, 0..2] of byte;
   res: array [0..2] of byte;
   x, y: integer;
   xp, yp: integer;
   xo, yo: integer;
   col: integer;
   pix: TColor;
 begin
   bm1 := TBitMap.Create;
   bm1.Width := round(bm.Width * dx);
   bm1.Height := round(bm.Height * dy);
   for y := 0 to bm1.Height - 1 do
   begin
     for x := 0 to bm1.Width - 1 do
     begin
       xo := trunc(x / dx);
       yo := trunc(y / dy);
       x1 := round(xo * dx);
       y1 := round(yo * dy);
 
       for yp := 0 to 1 do
         for xp := 0 to 1 do
         begin
           pix := bm.Canvas.Pixels[xo + xp, yo + yp];
           c[xp, yp, 0] := GetRValue(pix);
           c[xp, yp, 1] := GetGValue(pix);
           c[xp, yp, 2] := GetBValue(pix);
         end;
 
       for col := 0 to 2 do
       begin
         k1 := (c[1,0,col] - c[0,0,col]) / dx;
         z1 := x * k1 + c[0,0,col] - x1 * k1;
         k2 := (c[1,1,col] - c[0,1,col]) / dx;
         z2 := x * k2 + c[0,1,col] - x1 * k2;
         k := (z2 - z1) / dy;
         res[col] := round(y * k + z1 - y1 * k);
       end;
       bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);
     end;
     Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%';
     Application.ProcessMessages;
     if Application.Terminated then
       Exit;
   end;
   bm := bm1;
 end;
 
 const
   dx = 5.5;
   dy = 5.5;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   w = 50;
   h = 50;
 var
   bm: TBitMap;
   can: TCanvas;
 begin
   bm := TBitMap.Create;
   can := TCanvas.Create;
   can.Handle := GetDC(0);
   bm.Width := w;
   bm.Height := h;
   bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h));
   ReleaseDC(0, can.Handle);
   Interpolate(bm, dx, dy);
   Form1.Canvas.Draw(0, 0, bm);
   Form1.Caption := 'x: ' + FloatToStr(dx) +
   ' y: ' + FloatToStr(dy) +
   ' width: ' + IntToStr(w) +
   ' height: ' + IntToStr(h);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   bm: TBitMap;
 begin
   if OpenDialog1.Execute then
     bm.LoadFromFile(OpenDialog1.FileName);
   Interpolate(bm, dx, dy);
   Form1.Canvas.Draw(0, 0, bm);
   Form1.Caption := 'x: ' + FloatToStr(dx) +
   ' y: ' + FloatToStr(dy) +
   ' width: ' + IntToStr(bm.Width) +
   ' height: ' + IntToStr(bm.Height);
 end;
 




Обработка запроса на максимальное раскрытие окна

Мне необходимо иметь в приложении форму, раскрывающуюся при нажатии на кнопку "Открыть на весь экран" только в половину экрана, а не на полный экран.

Вам необходимо обработать из вашей формы сообщение WM_GETMINMAXINFO.

Например, добавьте следующее объявление в защищенную (protected) секцию вашей формы (interface):


 procedure _WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO );
   message wm_GetMinMaxInfo;
 

и создайте обработчик этого сообщения следующим образом (TForm1, естественно, имя вашей формы):


 procedure TForm1._WM_GETMINMAXINFO(var mmInfo: TWMGETMINMAXINFO);
 begin
   // устанавливаем позицию и размер вашей формы
   // при ее максимальном раскрытии:
   with mmInfo.minmaxinfo^ do
   begin
     ptmaxposition.x := Screen.Width div 4;
     ptmaxposition.y := Screen.Height div 4;
 
     ptmaxsize.x := Screen.Width div 2;
     ptmaxsize.y := Screen.Height div 2;
   end;
 end;
 




Разработка MDI приложений в Delphi

Что такое MDI?

MDI расшифровывается как multiple document interface (многодокументный интерфейс). В приложениях с MDI, в основном (родительском) окне можно окрыть более одного дочернего окна. Данная возможность обычно используется в электронных таблицах или текстовых редакторах.

Каждое MDI приложение имеет три основные составляющие:

  • Одну (и только одну) родительскую форму MDI,
  • Одну и более (обычно больше) дочерних форм MDI,
  • и основное меню MDI.

MDI "мать"

Как уже упоминалось, в проекте MDI приложения может присутствовать только один MDI контейнер (родительская форма) и он должен быть стартовой формой.

Для создания основного окна MDI приложения проделайте следующие шаги:

Запустите Delphi и выберите File | New Application... Delphi создаст новый проект с одной формой под названием form1 (по умолчанию). В свойстве Name присвойте форме имя frMain. Установите свойство FormStyle в fsMDIform. Сохраните этот проект (имя проекта на Ваше усмотрение, например prMDIExample), вместе с uMain.pas в только что созданной директории. Как Вы успели заметить, для создания основной формы MDI, мы установили свойство FormStyle в fsMDIform. В каждом приложении только одна форма может иметь свойство fsMDIform.

MDI "дети"

Каждое родительское окно MDI нуждается по крайней мере в одной дочерней форме. Дочерние формы MDI - это простые формы, за исключением того, что их видимая часть ограничена размерами родительского окна. Так же при минимизации такого окна, оно помещается не в панель задач, а остаётся внутри родительского окна ( на панель задач попадёт только родительское окно).

Теперь давайте создадим дополнительные формы, а точнее дочерние. Просто выберите File | New Form. Будет создан новый объект формы с именем form1 (по умолчанию). При помощи Object Inspector измените свойство Name в форме form1 на frChild, а свойство FormStyle на fsMDIChild. Сохраните эту форму с соответствующим ей файлом как uchild.pas. Обратите внимание, что при помощи данного свойства мы можем превратить любую существующую форму в дочернюю форму MDI.

Ваше приложение может включать множество дочерних MDI форм такого же или другого типа.

Так же хочется обратить Ваше внимание, что MDI приложение может включать в себя и самые обычные формы, но в отличие от дочерних, они будут отображаться как обычные модальные диалоговые окна (такие как about box, или файловый диалог).

Естевственно, что как на родительском так и на дочернем окнах можно располагать любые элементы управления, однако уже давно сложилась традиция, что на родительской форме располагается панель статуса (status bar) и панель инструментов (toolbar), в то время как на дочерних формах располагаются все остальные контролы, такие как гриды, картинки, поля вводи и т. д.

Автосоздание -> Доступные

Теперь давайте произведём некоторые настройки нашего проекта. Выберите Project | Options, откроется диалог опций проекта (Project Options). В левой панели выберите frChild (Авто-создание форм ("Auto-create forms")), и переместите её в правую панель (Доступные формы (Available forms)). Список правой панели содержит те формы, которые используются Вашим приложением, но которые не созданы автоматически. В MDI приложении, по умолчанию, все дочерние формы создаются автоматически и отображаются в родительской форме.

Создание и отображение

Как упомянуто выше, настройка не позволяет автоматически создавать дочерние окна, поэтому нам необходимо добавить некоторый код, который будет производить создание объекта формы frChild. Следующую функцию CreateChildForm необходимо поместить внутри основной формы (MDI родитель) (наряду с заголовком в interface's private):


 uses uchild;
 ...
 procedure TfrMain.CreateChildForm(const childName : string);
 var
   Child: TfrChild;
 begin
   Child := TfrChild.Create(Application);
   Child.Caption := childName;
 end;
 

Данный код создаёт одну дочернюю форму с заголовком childName. Не забудьте, что этот код находится разделе "uses uchild".

На закрытие не минимизировать!

Закрытие дочернего окна в MDI приложении всего навсего минимизирует его в клиентской области родительского окна. Поэтому мы должны обеспечить процедуру OnClose, и установить параметр Action в caFree:


 procedure TfrChild.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   Action := caFree;
 end;
 

Обратите внимание, что если форма является дочерней формой MDI, и её свойство BorderIcons установлено в biMinimize (по умолчанию), то опять же по умолчанию параметр Action установлен в caMinimize. Если же в дочерней форме MDI нет этих установок, то по умолчанию Action установлен как caNone, означающий, что при закрытии формы ничего не случится.

MDI родительское меню

Каждое MDI приложение должно иметь основное меню с (если больше ничего нет), опцией выравнивания окон. Поскольку мы предварительно переместили дочернюю форму из Авто-создаваемых (Auto-create) в Доступные (Available) формы, то нам нужен будет код, который (пункт меню) будет создавать дочерние формы.

Итак, переместите компонент TMainMenu на frMain (MDI родитель) и приведите его к следующему виду:

Для создания дочерних окон в нашем приложении будет использоваться пункт меню "New child". Второе меню (Window) будет использоваться для выравнивания дочерних окошек внутри родительского окна-формы.

Создать и отобразить

В заключении нам необходимо сделать обработчик для пункта меню "New child". При нажатии на пунк меню File | New Child нашего приложения, будет вызываться процедура NewChild1Click которая в свою очередь будет вызывать процедуру CreateChildForm (приведённую выше), для создания (следующего) экземпляра формы frChild.


 procedure TfrMain.NewChild1Click(Sender: TObject);
 begin
   CreateChildForm('Child '+IntToStr(MDIChildCount+1));
 end;
 

Только что созданная дочерняя форма будет иметь заголовок в виде "Child x", где x представляет количество дочерних форм внутри MDI формы, как описано ниже.

Закрыть всё

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


 procedure TfrMain.CloseAll1Click(Sender: TObject);
 var
   i: integer;
 begin
   for i:= 0 to MdiChildCount - 1 do
     MDIChildren[i].Close;
 end;
 

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

Свойства MdiChildCount и MDIChildren

MdiChildCount свойство read only, содержащее в себе количество созданных дочерних окошек. Если не создано ни одно дочернее окно, то это свойство установлено в 0. Нам прийдётся частенько использовать MdiChildCount наряду с массивом MDIChildren. Массив MDIChildren содержит ссылки на объекты TForm всех дочерних окошек.

Обратите внимание, что MDIChildCount первого созданного дочернего окна равен 1.

Меню Window

Delphi обеспечивает большинство команд, которые можно поместить внутри пункта меню Window. Далее приведён пример вызова трёх основных методов для команд, которые мы поместили в наше приложение:


 procedure TfrMain.Cascade1Click(Sender: TObject);
 begin
   Cascade;
 end;
 
 procedure TfrMain.Tile1Click(Sender: TObject);
 begin
   Tile;
 end;
 
 procedure TfrMain.ArrangeAll1Click(Sender: TObject);
 begin
   ArrangeIcons;
 end;
 




Фон MDI-окон

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

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)

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


 unit UMain;
 
 interface
 
 uses
   Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
   Dialogs, ExtCtrls, Menus;
 
 type
   TfrmMain = class(TForm)
     mnuMain: TMainMenu;
     mnuFile: TMenuItem;
     mnuExit: TMenuItem;
     imgTile: TImage;
     mnuOptions: TMenuItem;
     mnuBitmap: TMenuItem;
     mnuGradient: TMenuItem;
     procedure mnuExitClick(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure mnuBitmapClick(Sender: TObject);
     procedure mnuGradientClick(Sender: TObject);
     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
     procedure FormResize(Sender: TObject);
     procedure FormPaint(Sender: TObject);
   private
     { Private declarations }
     MDIDefProc: pointer;
     MDIInstance: TFarProc;
     procedure MDIWndProc(var prmMsg: TMessage);
     procedure CreateWnd; override;
     procedure ShowBitmap(prmDC: hDC);
     procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
   public
     { Public declarations }
   end;
 
 var
 
   frmMain: TfrmMain;
   glbImgWidth: integer;
   glbImgHeight: integer;
 
 implementation
 
 {$R *.DFM}
 
 procedure TfrmMain.FormCreate(Sender: TObject);
 begin
 
   glbImgHeight := imgTile.Picture.Height;
   glbImgWidth := imgTile.Picture.Width;
 end;
 
 procedure TfrmMain.FormResize(Sender: TObject);
 begin
 
   FormPaint(Sender);
 end;
 
 procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);
 begin
 
   with prmMsg do
   begin
     if Msg = WM_ERASEBKGND then
     begin
       if mnuBitmap.Checked then
         ShowBitmap(wParam)
       else
         ShowGradient(wParam, 255, 0, 0);
       Result := 1;
     end
     else
       Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
   end;
 end;
 
 procedure TfrmMain.CreateWnd;
 begin
 
   inherited CreateWnd;
   MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }
   MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
     longint(MDIInstance)));
 end;
 
 procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
   Boolean);
 begin
 
   { восстанавоиваем proc окна по умолчанию }
   SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));
   { избавляемся от ObjectInstance }
   FreeObjectInstance(MDIInstance);
 end;
 
 procedure TfrmMain.mnuExitClick(Sender: TObject);
 begin
 
   close;
 end;
 
 procedure TfrmMain.mnuBitmapClick(Sender: TObject);
 
 var
   wrkDC: hDC;
 begin
 
   wrkDC := GetDC(ClientHandle);
   ShowBitmap(wrkDC);
   ReleaseDC(ClientHandle, wrkDC);
   mnuBitmap.Checked := true;
   mnuGradient.Checked := false;
 end;
 
 procedure TfrmMain.mnuGradientClick(Sender: TObject);
 var
   wrkDC: hDC;
 begin
   wrkDC := GetDC(ClientHandle);
   ShowGradient(wrkDC, 0, 0, 255);
   ReleaseDC(ClientHandle, wrkDC);
   mnuGradient.Checked := true;
   mnuBitMap.Checked := false;
 end;
 
 procedure TfrmMain.ShowBitmap(prmDC: hDC);
 var
   wrkSource: TRect;
   wrkTarget: TRect;
   wrkX: integer;
   wrkY: integer;
 begin
   { заполняем (tile) окно изображением }
   if FormStyle = fsNormal then
   begin
     wrkY := 0;
     while wrkY < ClientHeight do { заполняем сверху вниз.. }
     begin
       wrkX := 0;
       while wrkX < ClientWidth do { ..и слева направо. }
       begin
         Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);
         Inc(wrkX, glbImgWidth);
       end;
       Inc(wrkY, glbImgHeight);
     end;
   end
   else if FormStyle = fsMDIForm then
   begin
     Windows.GetClientRect(ClientHandle, wrkTarget);
     wrkY := 0;
     while wrkY < wrkTarget.Bottom do
     begin
       wrkX := 0;
       while wrkX < wrkTarget.Right do
       begin
         BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,
           imgTile.Canvas.Handle, 0, 0, SRCCOPY);
         Inc(wrkX, glbImgWidth);
       end;
       Inc(wrkY, glbImgHeight);
     end;
   end;
 end;
 
 procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
 var
   wrkBrushNew: hBrush;
   wrkBrushOld: hBrush;
   wrkColor: TColor;
   wrkCount: integer;
   wrkDelta: integer;
   wrkRect: TRect;
   wrkSize: integer;
   wrkY: integer;
 begin
   { процедура заполнения градиентной заливкой }
   wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }
   if wrkDelta = 0 then
     wrkDelta := 1; { да, обычно 1 }
   wrkSize := ClientHeight div 240; { размер смешанных баров }
   if wrkSize = 0 then
     wrkSize := 1;
   for wrkY := 0 to 1 + (ClientHeight div wrkSize) do
   begin
     wrkColor := RGB(prmRed, prmGreen, prmBlue);
     wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);
     if FormStyle = fsNormal then
     begin
       Canvas.Brush.Color := wrkColor;
       Canvas.FillRect(wrkRect);
     end
     else if FormStyle = fsMDIForm then
     begin
       wrkBrushNew := CreateSolidBrush(wrkColor);
       wrkBrushOld := SelectObject(prmDC, wrkBrushNew);
       FillRect(prmDC, wrkRect, wrkBrushNew);
       SelectObject(prmDC, wrkBrushOld);
       DeleteObject(wrkBrushNew);
     end;
     if prmRed > wrkDelta then
       Dec(prmRed, wrkDelta);
     if prmGreen > wrkDelta then
       Dec(prmGreen, wrkDelta);
     if prmBlue > wrkDelta then
       Dec(prmBlue, wrkDelta);
   end;
 end;
 
 procedure TfrmMain.FormPaint(Sender: TObject);
 begin
   if FormStyle = fsNormal then
     if mnuBitMap.Checked then
       mnuBitMapClick(Sender)
     else
       mnuGradientClick(Sender);
 end;
 
 end.
 




Проблема всплывающих подсказок в дочерних MDI-формах

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

Объявите следующую процедуру в классе вашей главной формы:


 private
 {============================================================}
 { Процедура, вызываемая приложением всякий раз, когда        }
 { приложение хотело бы показать всплывающую подсказку.       }
 { Добавляет хинт на панель статуса.                          }
 {============================================================}
 procedure ShowHint(Sender : TObject);
 

затем в процедуре главной формы .create добавьте следующую строку:


 { Отображает хинт на статусной панели}
 Application.OnHint := ShowHint;
 

Теперь приведем код функции ShowHint, принадлежащей главной форме:


 {================================================================}
 { Обновляем pnlStatusText.Caption с текстом всплывающей подсказки}
 { элемента управления, над которым находится курсор мыши.        }
 {================================================================}
 procedure
 TMainFrame.ShowHint
 (
 
 Sender : TObject  {Объект, вызывающий данную процедуру}
 );
 begin
 
 pnlStatusText.Caption := Application.Hint;
 end; { TMainFrame.ShowHint }
 

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




Меню дочерних MDI-форм

Так как MDI-приложения всегда объединяют меню дочерних окон с главным меню родительского окна, вы можете установить определенное значение для указания позиции элементов меню в новой, объединенной строке меню. Это называется индексом группы. Но работает оно только для видимых пунктов меню.

Так, например, если ваше MDI-меню имеет:
[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за невольный каламбур), они используются только лишь для сортировки),

а меню дочерней MDI-формы имеет:
[Файл] [Редактирование] (и им присвоены значения 1 и 3),

то при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы. Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.

Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.

К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а в случае отсутствия дочерних окон - [Открыть] и [Новое].

Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].

Вы все еще можете использовать код родительской формы в дочерней.

Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после его открытия.




Позиция дочерних MDI-окон

Автор: Richard Cox

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

У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы WindowState устанавливалось на wsMinimized.

Вот мое решение: добавьте этот небольшой метод к вашей главной форме:


 interface
 
 procedure CMShowingChanged(var Message: TMessage);
 message CM_SHOWINGCHANGED;
 
 implementation
 
 procedure TMainForm.CMShowingChanged(var Message: TMessage);
 var
   theRect: TRect;
 begin
   inherited;
   theRect := GetClientRect;
   AlignControls(nil, theRect);
 end;
 

Это работает, поскольку вызов AlignControls (в TForm) делает две вещи:

  1. выравнивает элементы управления (включая ваш проблемный StatusBar) и
  2. вновь позиционирует окно клиента относительно главной формы (оно ссылается на ClientHandle) после того, как элементы управления будут выравнены... что, впрочем, мы и хотели.



Почему MDI Child форма при закрывании просто минимизируется

Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть.




Сколько открыто дочерних окон


 with Form1 do
   for I := 0 to MDIChildCount-1 do
     MDIChildren[I].Close;
 




Открытие MDI-окон определенного размера


 var
   ProjectWindow: TWndProject;
 begin
   If ProjectActive=false then
   begin
     LockWindowUpdate(ClientHandle);
     ProjectWindow:=TWndProject.Create(self);
     ProjectWindow.Left:=10;
     ProjectWindow.Top:=10;
     ProjectWindow.Width:=373;
     ProjecTwindow.Height:=222;
     ProjectWindow.Show;
     LockWindowUpdate(0);
   end;
 end;
 

Используйте LockWindowUpdate перед созданием окна и после того, как создание будет завершено.




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


  • Сначала установите свойство формы FormStyle в fsMDIForm.
  • Затем разместите Image на форме и загрузите в него картинку.
  • Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:

 FClientInstance: TFarProc;
 FPrevClientProc: TFarProc;
 procedure ClientWndProc(var message: TMessage);
 

  • Добавьте следующие строки в разделе implementation:

 procedure TMainForm.ClientWndProc(var message: TMessage);
 var
   Dc: hDC;
   Row: Integer;
   Col: Integer;
 begin
   with message do
     case Msg of
       WM_ERASEBKGND:
       begin
         Dc := TWMEraseBkGnd(message).Dc;
         for Row := 0 to ClientHeight div Image1.Picture.Height do
           for Col := 0 to ClientWidth div Image1.Picture.Width do
             BitBlt(Dc, Col * Image1.Picture.Width, Row *
             Image1.Picture.Height, Image1.Picture.Width,
             Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle,
             0, 0, SRCCOPY);
         Result := 1;
       end;
       else
         Result := CallWindowProc(FPrevClientProc,
         ClientHandle, Msg, wParam, lParam);
     end;
 end;
 

  • По созданию окна [событие OnCreate()] напишите такой код:

 FClientInstance := MakeObjectInstance(ClientWndProc);
 FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
 SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));
 

  • Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild



Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов

Ваpиант 1. CoolBar.


 procedure TMainForm.SetBands(AControls: array of TWinControl;
 ABreaks: array of boolean);
 var
   i: integer;
 begin
   with CoolBar do
   begin
     for i:=0 to High(AControls) do
     begin
       if Bands.Count=succ(i) then
         TCoolBand.Create(Bands);
       with Bands[succ(i)] do
       begin
         if Assigned(Control) then
           Control.Hide;
         MinHeight:=AControls[i].Height;
         Break:=ABreaks[i];
         Control:=AControls[i];
         Control.Show;
         Visible:=true;
       end
     end;
     for i:=High(AControls)+2 to pred(Bands.Count) do
       Bands[i].Free
   end
 end;
 

и


 procedure TMsgForm.FormActivate(Sender: TObject);
 begin
   MainForm.SetBands([ToolBar],[false])
 end;
 

Пpимечание:

Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:


 AutoSize := false;
 try
   ...
 finally
 AutoSize := true;
 

Ваpиант 2.


 TMainForm
   ...
   object SpeedBar: TPanel
   ...
   Align = alTop
   BevelOuter = bvNone
   object ToolBar: TPanel
   ...
   Align = alLeft
   BevelOuter = bvNone
   end
   object RxSplitter1: TRxSplitter
   ...
   ControlFirst = ToolBar
   ControlSecond = ChildBar
   Align = alLeft
   BevelOuter = bvLowered
   end
   object ChildBar: TPanel
   ...
   Align = alClient
   BevelOuter = bvNone
   end
 end
 
 TMdiChild {пpородитель всех остальных}
   ...
   object pnToolBar: TPanel
   ...
   Align = alTop
   BevelOuter = bvNone
   Visible = False
 end
 
 procedure TMDIForm.FormActivate(Sender: TObject);
 begin
   pnToolBar.Parent := MainForm.ChildBar;
   pnToolBar.Visible := True;
 end;
 
 procedure TMDIForm.FormDeactivate(Sender: TObject);
 begin
   pnToolBar.Visible := false;
   pnToolBar.Parent := self
 end;
 




Открытие выбранного файла в работающем приложении

Автор: Пангин Дмитрий Викторович

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


 // В файле проекта:
 var
 
   i: integer;
   hMainForm: hwnd;
   copyDataStruct: TCopyDataStruct;
   ParamString: string;
   WParam, LParam: integer;
 begin
   // ищем главное окно приложения, вместо Caption - nil,
   // поскольку к заголовку главного окна может добавиться заголовок MDIChild
   // (нужно позаботиться об уникальности имени класса главной формы)
 
   hMainForm := FindWindow('TMainForm', nil);
   if hMainForm = 0 then
   begin
     Application.Initialize;
     Application.CreateForm(TFrmMain, frmMain);
     for i := 1 to ParamCount do
       TMainForm(Application.MainForm).OpenFile(ParamStr(i));
     Application.Run;
   end
   else
   begin
     ParamString := '';
     for i := 1 to ParamCount do
     begin
       // запихиваем все параметры в одну строку с разделителями ?13
 
       ParamString := ParamString + ParamStr(i) + #13;
     end;
     // создаем запись типа TCopyDataStruct
 
     CopyDataStruct.lpData := PChar(ParamString);
     CopyDataStruct.cbData := Length(ParamString);
     CopyDataStruct.dwData := 0;
     WParam := Application.Handle;
     LParam := Integer(@CopyDataStruct);
     // отсылаем сообщение WM_COPYDATA главному окну открытого приложения
 
     SendMessage(hMainForm, WM_CopyData, WParam, LParam);
     Application.Terminate;
   end;
 end.
 
 // Обработчик сообщения WM_COPYDATA
 
 procedure TMainForm.CopyData(var Msg: TWMCopyData);
 var
 
   ParamStr: string;
   CopyDataStructure: TCopyDataStruct;
   i: integer;
   len: integer;
 begin
 
   CopyDataStructure := Msg.CopyDataStruct^;
   ParamStr := '';
   len := CopyDataStructure.cbData;
   for i := 0 to len - 1 do
   begin
     ParamStr := ParamStr + (PChar(CopyDataStructure.lpData) + i)^;
   end;
 
   i := 0;
   while not (Length(ParamStr) = 0) do
   begin
     if isDelimiter(#13, ParamStr, i) then
     begin
       OpenFile(Copy(ParamStr, 0, i - 1));
       ParamStr := Copy(ParamStr, i + 1, Length(ParamStr) - i - 1);
     end;
     inc(i);
   end;
   inherited;
 end;
 
 // проверено, работает.
 




Выбор дочерних MDI-окон с помощью набора закладок TabSet

По всей видимости, дочерние MDI-окна не отвечают на те же сообщения Windows, которые обрабатываются другими окнами. Ниже приведен способ выбора определенного дочернего MDI-окна таким образом, чтобы оно стало активным. Я читаю значение из компонента TINIFile и активизирую определенное дочернее MDI-окно:


 {
 Делаем активным дочернее MDI-окно. Мы должны
 послать сообщение Windows API, поскольку
 дочернее MDI-окно может реагировать только
 на "аварийный" набор системных сообщений.
 }
 i := ReadInteger( 'Main', 'ActiveMDIChild', -1 )
 IF (i>=0) AND (i<MDIChildCount) THEN
   POSTMESSAGE( Self.Handle, WM_MDIACTIVATE,
     MDIChildren[i].Handle, 0 )
 

MDI-формы обрабатываются другим обработчиком по-умолчанию (defMDIProc). Способов сделать это (см. заголовок) существует несколько. Дочерние Mdi-формы являются частью массива с именем (как ни странно) MDIChildren. Вы можете сделать так.....


 For i := 0 To Form1.MDIChildCount - 1 Do
 begin
   If Form1.MDIChildren[i].Caption = 'Это первый!' Then
     {Здесь можно активизировать дочернюю MDI-форму
     или выполнить какие-либо действия}
 end;
 

MDIChildren[x] - указатель на экземпляр дочерней MDI-формы. Использование операторов IS и AS позволит вам иметь доступ к любым свойствам и методам любой дочерней формы.

  1. При открытии файла в набор Tabset добавляется новая закладка Tab, а ее заголовок ("caption") устанавливается равным имени открытого файла. Затем форма с помощью команды Tabset.AddObject добавляется как объект к tabset.

  2. При щелчке на tabset, чтобы иметь доступ к верному файлу, я использую следующий код:

 TForm(TabsSet.Items.Objects[TabSet.TabIndex]).Show;
 




Пример отображаемых в памяти файлов


 var file_, map : dword;
     buf: pointer;
 begin
   file_ := CreateFile('c:\file1.txt', GENERIC_READ, FILE_SHARE_READ,
   nil, OPEN_EXISTING, 0, 0);
   if file_ <> INVALID_HANDLE_VALUE then
     try
       map := CreateFileMapping(file_, nil, PAGE_READWRITE, 0, 0, nil);
       if map <> 0 then
         try
           buf := MapViewOfFile(map, FILE_MAP_ALL_ACCESS, 0, 0, 0);
           if buf <> nil then
             try
 
               // now here you have your file1.txt in memory
               // beginning at pointer "buf"
 
             finally UnmapViewOfFile(buf) end;
         finally CloseHandle(map) end;
     finally CloseHandle(file_) end;
 end;
 
 {
 This logic maps your complete file into memory. It's not COPIED into memory,
 only MAPPED. In the moment where you access the single bytes of the file in
 memory, Windows internally reads the file for you in the fastest possible way.
 }
 




Помещение Memo-файла с ASCII-разделителем в Memo-поле таблицы

Вам нужно использовать процедуру getTextBuf. Вот пример из электронной справки:

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Buffer: PChar;
   Size: Byte;
 begin
   Size := Edit1.GetTextLen;       {Получаем длину строки в Edit1}
   Inc(Size);                      {Добавляем место для терминирующего нуля}
   GetMem(Buffer, Size);           {Создаем динамическую переменную Buffer}
   Edit1.GetTextBuf(Buffer,Size);  {Помещаем Edit1.Text в Buffer}
   Edit2.Text := StrPas(Buffer);   {Преобразуем Buffer в строку паскалевского типа}
   FreeMem(Buffer, Size);          {Освобождаем память, распрелеленную для Buffer}
 end;
 




Как в Memo переносить не слово целиком, а только не помещающуюся часть

Сначала нужно объявить две глобальных переменные:


 OriginalWordBreakProc: pointer;
 NewWordBreakProc: pointer;
 

Затем описываем в разделе implementation следующую процедуру:


 function MyWordBreakProc(LPTSTR: pchar; ichCurrent: integer;
 cch: integer; code: integer): integer
 {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
 begin
   result := 0;
 end;
 

По созданию окна пишем такой код:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   OriginalWordBreakProc := Pointer(SendMessage(Memo1.Handle,
   EM_GETWORDBREAKPROC, 0, 0));
   {$IFDEF WIN32}
   NewWordBreakProc := @MyWordBreakProc;
   {$ELSE}
   NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance);
   {$ENDIF}
   SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0,
   longint(NewWordBreakProc));
 end;
 

а по уничтожению:


 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0,
   longint(@OriginalWordBreakProc));
   {$IFNDEF WIN32}
   FreeProcInstance(NewWordBreakProc);
   {$ENDIF}
 end;
 




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

Автор: Ed Jordan

Как завести дома программиста. (Пособие по разведению и уходу).
Дорогие женщины! Вы наверняка сталкивались с такой проблемой - купили новую мебель, красивый палас, занавески, а в квартире все равно что-то не так. Это означает, что в интерьере не хватает завершающего штриха, а именно - мужа. Мы рекомендуем в этом случае завести дома программиста. Он достаточно неприхотлив, не будет вам мешать и не займет много места. В то же время программист является одной из самых модных и элитарных поpод мужей. Внимательно прочтите описание программиста и подумайте, возможно, это тот, о ком вы мечтали всю жизнь.
Экстерьер.
Программист может быть как маленького, так и большого роста. Он, как правило, имеет длинный волосяной покров с характерной проплешиной на затылке. У многих растут борода и усы (и то, и другое вам придется время от времени подравнивать, чтобы программист не терял товарного вида). Взгляд у программиста слегка блуждающий, а спина красиво изогнута вперед. Короче говоря, программист - вполне достойный внимания и зависти подруг экземпляр.
Первоначальные затраты.
Разведение программистов, к сожалению, связано с большими первоначальными затратами.
Вам понадобятся:
- Персональный компьютер с процессором не ниже Pentium II;
- стол и стул;
- пепельница;
- большое количество сарделек и пиво для прикармливания;
- кофейная чашечка вместимостью 0,5 л.
Места обитания.
Программист обитает в самых различных местах, но проще всего наткнуться на него на больших компьютерных выставках вроде <Комтека>. Если вы начнете охоту не в сезон, когда больших выставок не будет, пройдитесь по компьютерным магазинам. Вы увидите в них три-четыре особи, соответствующие вышеприведенному описанию. Особи будут листать компьютерные журналы либо вести друг с другом пространные беседы с обилием непонятных слов.
Образ жизни.
Программист ведет исключительно ночной образ жизни, поэтому ему необходима отдельная комната. Желательно провести туда и отдельную телефонную линию, иначе вы уже никогда не сможете беседовать со своими подругами. Зато программисту не требуется отдельное спальное место - он будет дремать на вашем диване в те часы, когда вы будете на работе.
Приманивание.
Для приманивания программиста необходима любая деталь, которую вы сможете открутить от заранее купленного компьютера. Hебрежно помахивая ею, приближайтесь к намеченной особи, бормоча какие-либо компьютерные термины. После этого попросите починить ваш якобы случайно сломавшийся компьютер. Программист пойдет за вами, как бы впав в состояние транса. Дома угостите его сардельками и пивом. Скорее всего, программист уже никуда не уйдет.
Способ демонстрации программиста.
Перед тем, как завести программиста, подумайте о том, как вы будете его демонстрировать знакомым. Hе устанавливаете монитор тылом к стене - это серьезная ошибка! Программист, как правило, не отворачивается от монитора, даже если очень громко кричать у него над ухом, и вы сможете показывать подругам только его спину. Поэтому лучше устроить рабочее место так, чтобы программиста можно было обозревать со всех сторон. Hе забудьте также заранее установить в комнате кондиционер, включающийся из коридора, - иначе программиста не будет видно из-за сигаретного дыма.
Дрессировка.
К сожалению, программист практически не поддается дрессировке. Hо небольшие действия вроде походов за хлебом или включения телевизора программист иногда выполняет, особенно, если подкреплять их с помощью условных рефлексов (давать пиво и сардельки). Если программиста удается оттащить от компьютера (кстати, в эти моменты он бывает опасен), можно взять его в магазин и приучить носить авоську. Hеобходимо также учесть, что отдельные простые команды, пригодные для других видов мужей, например "Закрой окно!", программистом понимаются неверно. Следуйте нашим простым рекомендациям - и ваш любимец всегда будет бодр, весел и не перестанет радовать вас и украшать квартиру своим присутствием!

Как мне импортировать файл в элемент управления 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;
 




Как сделать отступ в Memo


 var
   Rect: TRect;
 begin
   SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
   Rect.Left:= 20;
   SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
   Memo1.Refresh;
 end;
 




Показ Memo-поля в DBGrid

Пенти - ум, а Интер - нет!

...я все же лелею надежду, что когда-нибудь увижу TMemoField.DataSize, имеющим значение, отличное от нуля. Может быть значение DataSize является размером части Memo, которая сохранилась в .db-файле? Вместо этого я теперь пользуюсь объектом TBlobStream, который вполне хорошо справляется с этой работой. Все это у меня происходит примерно так:


 var
   pBuffer: PChar;
   Blob: TBlobStream;
 begin
   {FDataField - это TMemoField}
   Blob := TBlobStream.Create(FDataField, bmRead);
   try
     if Blob.Size > 0 then
     try
       GetMem(pBuffer, Blob.Size);
       Blob.Read(pBuffer^, Blob.Size);
       { что-то тут делаем    }
       FreeMem(pBuffer, Blob.Size);
     except
       ShowMessage('Нехватка памяти');
     end;
   finally
     Blob.Free
   end;
 end;
 




Показ Memo-поля в DBGrid 2

Модем с бодуна трубку снимает:
Гав - тьфу б/\я, Мяу - б/\я, Ш-ш-ш, Ой - пи-и-и...

Используйте следующий код для обработки события OnDrawDataCell у TDBGrid. (Перед запуском программы создайте объект TMemoField для memo поля в Fields Editor).


  procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
  TRect;
    Field: TField; State: TGridDrawState);
  var
    P: array [0..1023] of Char; { MemoField buffer }
    BS: TBlobStream;
    S: string;
  begin
    if Field is TMemoField then
    with (Sender as TDBGrid).Canvas do
    begin
  { Table1Notes is the TMemoField }
      BS := TBlobStream.Create(Table1Notes, bmRead);
      FillChar(P, SizeOf(P), #0);
      BS.Read(P, SizeOf(P));
      BS.Free;
      S := StrPas(P);
  { remove carriage returns &  line feeds }
      while Pos(#13, S) >  0 do S[Pos(#13, S)] := ' ';
      while Pos(#10, S) >  0 do S[Pos(#10, S)] := ' ';
  { clear the cell }
      FillRect(Rect);
  { fill cell with memo data }
      TextOut(Rect.Left, Rect.Top, S);
    end;
  end;
 




Событие 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.
 




Ограничение длины и количества строк компонента 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.
 




Как запихать в Мемо больше текста, чем оно может вместить по умолчанию

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

Можно посчитать кол-во строчек нужных для кэша, скажем 500 и подгружать из большого файла куски. Или посчитать, сколько строчек Мемо влезет в один лист и сделать, как в ворде разбиение по листам. Алгоритм подгрузки из файла строк с позиции A по B, очень прост и я думаю нет труда егор расписывать. Достаточно лишь точно знать A и B , где B:=A+(кол-во строк в одном куске " кэша" мемо). Считываем построчно текст из файла, предварительно очистив Мемо, а потом добавляем строку, считанную из файла методом Тмемо.lines.add(stringfromfile). Метод прост, изящен, достаточно быстр и экономичен в плане памяти(хотя последнее можно оспорить). Наиболее яркий пример такого использования Тмемо - программа "Yboo"




Постраничная прокрутка Memo, когда фокус находится на Edit


 procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 begin
   if Key = VK_F8 then
     SendMessage(Memo1.Handle, { HWND для Memo }
       WM_VSCROLL, { сообщение Windows }
       SB_PAGEDOWN, {на страницу вниз }
       0) { не используется }
   else if Key = VK_F7 then
     SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEUP, 0);
 end;
 




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

Автор: Xavier Pacheco

Создайте потомок 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;
 




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

Автор: Bob Sherman

У меня имеется компонент 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).




Поиск и замена текста в 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;
 




Сортировка строк в MEMO


 procedure TForm1.Button3Click(Sender: TObject);
 var
   t: TStringList;
 begin
   // создаем
   t:=TStringList.Create;
   // присваиваем переменной t строки из Memo
   t.AddStrings(memo1.lines);
   // сортируем
   t.Sort;
   memo1.Clear;
   // присваиваем memo уже отсортированные строки
   memo1.Lines.AddStrings(t);
 end;
 




Как настроить табуляцию в компоненте TMemo

Иду по Москве, глазею по сторонам. Стендов всяких море вокруг. На одном из них реклама чего-то и одна надпись подчеркнута. Мгновенно мысль - ссылка на сайт этого, чего написано. Через пять секунд приходит осознание сползания крыши. Отсюда мораль: Не все, что подчеркнуто, является ссылкой. И следствие: Не всякая ссылка подчеркнута.

Пошлите в Memo сообщение EM_SETTABSTOPS. Например установим первую позицию табуляции на 20-й пиксел. Пример:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   DialogUnitsX: LongInt;
   PixelsX: LongInt;
   i: integer;
   TabArray: array[0..4] of integer;
 begin
   Memo1.WantTabs := true;
   DialogUnitsX := LoWord(GetDialogBaseUnits);
   PixelsX := 20;
   for i := 1 to 5 do
   begin
     TabArray[i - 1] := ((PixelsX * i) * 4) div DialogUnitsX;
   end;
   SendMessage(Memo1.Handle, EM_SETTABSTOPS, 5, LongInt(@TabArray));
   Memo1.Refresh;
 end;
 




При обращении к memo-полю из BDE возникает ошибка Memo too large

Автор: Nomadic

- В чем заключается многозадачность Windows?
- Она может выполнять несколько ошибок одновременно.

В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально.

Эффект имеет место только с IB, вроде.




Как узнать количество видимых строчек в TMemo

Вот пример подсчёта видимых строк:


 function LinesVisible(Memo: TMemo): integer;
 var
   OldFont : HFont;
   Hand : THandle;
   TM : TTextMetric;
   Rect : TRect;
   tempint : integer;
 begin
   Hand := GetDC(Memo.Handle);
   try
     OldFont := SelectObject(Hand, Memo.Font.Handle);
     try
       GetTextMetrics(Hand, TM);
       Memo.Perform(EM_GETRECT, 0, longint(@Rect));
       tempint := (Rect.Bottom - Rect.Top) div
       (TM.tmHeight + TM.tmExternalLeading);
     finally
       SelectObject(Hand, OldFont);
     end;
   finally
     ReleaseDC(Memo.Handle, Hand);
   end;
   Result := tempint;
 end;
 




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

Автор: Dr. Bob

Программисты Майкрософт ворвались в Apple и ставят на все компютеры Винды. Посреди этого всего стоит Билли в чёрной рясе с капюшоном и здоровенным крестом с логотипом W95. И подбегают к нему программисты и спрашивают:
- Отче, как отличить поганый Мак от честного писюка?
Мрачно усмехнулся Билли и сказал:
- Ставьте на всех!!! Виндоуз узнает своих!!!

Кто-нибудь знает как использовать различные шрифты и стили в 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.
 




Memo со свойствами 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.
 




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

Автор: Nomadic

Попал программист в братву. Бригадный ему дает задание: сходить за данью в один из киосков. Приходит он на место, забирает деньги, а продавщица ему и говорит:
- Что-то компьютер у нас последнее время очень плохо работает.
Программист-браток посмотрел ящик:
- Конечно плохо, памяти добавить нужно.
Затем достает мобилу и звонит бригадному:
- Шеф, у нас тут в киоске с памятью проблемы.. Нужны DIMMы.
Бригадный:
- На ф#га тебе Димы. Позови Артурчика и они сразу все вспомнят!!!

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


 implementation
 { 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 подблока} > l = $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;
 




Беседа о распределении памяти

Память y меня коpоткая - 30 pin.

Вот Вы уже почти погрузились в интереснеший мир Reverse Engineering, но к сожалению, пока Вы не в состоянии что-либо сделать самостоятельно. Ничего старшного, сейчас мы вместе продолжим делать небольшие, но очень важные и нужные шаги на этом пути, постепенно углубляя знания и приобретая необходимые навыки.

Вот мы и дошли до того места, когда нам необходимо поговорить о распределении памяти в ОС Windows 95. В данной статье мы дадим Вам лишь самые простые и необходимые сведения.

Используемая в ОС Windows 95 модель (способ) распределения памяти называется непрерывной. В такой модели не существует строгого деления на сектора и сегменты (что было присуще DOS и Windows 3.x), т.е. программа может свободно обращаться к любому адресу всего адресного пространства (4 Гб, ограничение накладывается 32-разрядной адресной шиной компьютера). ОС считается многозадачной, если работающие параллельно программы не могут воздействовать друг на друга. Для этого Windows использует следующий механизм: каждой задаче предоставляется свое личное адресное пространство размером около 2-х Гб. За границы своего адресного пространства задача выйти не может, также как никакая другая задача не может работать с данным пространством - этим и определяется автономность программы.

Предоставлением адресного пространства и загрузкой в него программы занимается менеджер памяти Windows. У каждой программы существует два важных параметра:

  1. Адрес загрузки. Это адрес, начиная с которого программа будет располагаться в памяти. Запомните, программы в Windows всегда загружаются по одному и тому-же адресу - адресу загрузки, это сильно облегчит нам работу в будущем. Как было сказано выше каждой программе предоставляется свое адресное пространство размером около 2-х Гб, начиная с адреса 40000000h (символ h означает, что число записано в шестнадцатеричной системе счисления). Именно поэтому большинство программ имеют адрес загрузки 40000000h.
  2. Точка входа в программу. Это адрес, с которого начинается выполнение программы. Он может находится в любой части программы, а не обязательно в ее начале; даже наоборот в большинстве случаев он расположен практически в самом ее конце.

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

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




Как определить сколько памяти выделено в Delphi для программы

Источник: http://www.proext.com

В гарантийном отделе одной из компьютерных фирм к окошку подходит молодой человек и говорит:
- Здравствуйте! Я вчера отдал вам память...
- А кому именно Вы ее отдавали?
- Не помню...

Для этого можно воспользоваться функцией GetHeapStatus:


 lwMem.Items.Clear;
 s := LastStatsList[cbCompare.ItemIndex];
 LastStatsList[0] := GetHeapStatus;
 LastStats := LastStatsList[PointId];
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'TotalAddrSpace';
 ListItem.SubItems.Add(Numb2USA(Format( strFormat,[s.TotalAddrSpace])));
 tmp := s.TotalAddrSpace - LastStats.TotalAddrSpace;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'TotalUncommitted';
 ListItem.SubItems.Add(Numb2USA(Format( strFormat,[s.TotalUncommitted])));
 tmp := s.TotalUncommitted - LastStats.TotalUncommitted;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'TotalCommitted';
 ListItem.SubItems.Add(Numb2USA(Format( strFormat,[s.TotalCommitted])));
 tmp := s.TotalCommitted - LastStats.TotalCommitted;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'TotalAllocated';
 ListItem.SubItems.Add(Numb2USA(Format( strFormat,[s.TotalAllocated])));
 tmp := s.TotalAllocated - LastStats.TotalAllocated;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'TotalFree';
 ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalFree])));
 tmp := s.TotalFree - LastStats.TotalFree;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'FreeSmall';
 ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeSmall])));
 tmp := s.FreeSmall - LastStats.FreeSmall;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'FreeBig';
 ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeBig])));
 tmp := s.FreeBig - LastStats.FreeBig;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'Unused';
 ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Unused])));
 tmp := s.Unused - LastStats.Unused;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'Overhead';
 ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Overhead])));
 tmp := s.Overhead - LastStats.Overhead;
 ListItem.SubItems.Add(DeltaToStr(tmp));
 
 ListItem := lwMem.Items.Add;
 ListItem.Caption := 'HeapErrorCode';
 ListItem.SubItems.Add(Numb2USA(Format( strFormat,[s.HeapErrorCode])));
 




Как узнать состояние памяти


 var
   Status: TMemoryStatus;
 begin
   Status.dwLength := sizeof(TMemoryStatus);
   GlobalMemoryStatus(Status);
   ...
 end;
 

После этого TMemoryStatus будет содержать следующие паоля:

  • Status.dwMemoryLoad: Количество используемой памяти в процентах (%).
  • Status.dwTotalPhys: Общее количество физической памяти в байтах.
  • Status.dwAvailPhys: Количество оставшейся физической памяти в байтах.
  • Status.dwTotalPageFile: Объём страничного файла в байтах.
  • Status.dwAvailPageFile: Свободного места в страничном файле.
  • Status.dwTotalVirtual: Общий объём виртуальной памяти в байтах.
  • Status.dwAvailVirtual: Количество свободной виртуальной памяти в байтах.

Предваритель, желательно преобразовать эти значения в гига-, мега- или килобайты, например так:


 label14.Caption := 'Total Ram: ' + IntToStr(Status.dwTotalPhys div 1024417) + 'meg';
 




Как программно заставить выпасть меню


Автор: InSAn

В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   //Allow button to finish painting in response to the click
   Application.ProcessMessages;
   {Alt Key Down}
   keybd_Event(VK_MENU, 0, 0, 0);
   {F Key Down - Drops the menu down}
   keybd_Event(ord('F'), 0, 0, 0);
   {F Key Up}
   keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
   {Alt Key Up}
   keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
   {F Key Down}
   keybd_Event(ord('S'), 0, 0, 0);
   {F Key Up}
   keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
 end;
 




Меню в WEB-браузере


- Будьте добры позавите пожалуйста Ваню.
- Вани нет, он покинул этот мир.
- Он, что умер?
- Нет, к интернету подключился.

В конференции я часто натыкался на вопросы типа – "Как добавить свой пункт меню в контекстное меню IE, как это делает ReGet", "Как запретить появление контекстного меню в TwebBrowser” или "Как показать свое меню вместо стандартного". А вот ответов в большинстве случаев не было, или они советовали попробовать другие компоненты. Но когда мне самому понадобилось в рамках одного проекта сразу, и запретить появление меню, и вставить свой пункт в стандартное меню IE, я решил покопать в этом направлении. И, конечно, MSDN выручила меня в этих поисках. Так что не бойтесь, меню и TwebBrowser – очень даже дружны между собой и то, что с легкостью делают ребята с ReGet Software, не такая уже и неприступная магия…

Запрещение появления меню в TwebBrowser

Хотя в инспекторе и есть такое свойство для этого компонента – PopurMenu, но его использование очень ограничено. Давайте для примера создадим PopurMenu с двумя произвольными пунктами и присвоим свойству PopurMenu TwebBrowser значение PopurMenu1. Запускаем приложение. Щелчок правой кнопкой мыши – ура, меню наше исправно отображаеться. Но радоваться рано. Загружаем любую страницу в браузер, снова щелкае мышкой – вместо нашего меню появляеться стандартное контекстное меню IE. Почему же так?

Компонент TwebBrowser всего лишь оболочка для COM объектов IE, а пока никакая страница не загружена – все сообщения передаются непосредственно вашей программе и, обрабатывая их, программа воспринимает TwebBrowser как обычный VCL-компонент. Поэтому наше меню и появлялось. Когда же вызван метод Navigate, управление идет уже через СОМ интерфейсы, поэтому сообщения обрабатываються не оконным компонентом, а кодом "под оболочкой".

Вообще запретить появление меню можно. Вот некоторые способы:


 ...
 private
 ...
 procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;
 end;
 ...
 

Ставим обработчик для сообщения WM_MOUSEACTIVATE на уровне головной формы приложения.

Потом пишем процедуру:


 procedure TMainForm.WMMouseActivate(var Msg: TMessage);
 begin
   try
     inherited;
     //Анализируем, какая кнопка мыши нажата
     if Msg.LParamHi = 516 then // если правая
       // показываем свое меню
       PopupMenu1.Popup(Mouse.CursorPos.x, Mouse.CursorPos.y);
     Msg.Result := 0;
   except
   end;
 end;
 

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

Что бы просто запретить появление меню можно преобразовать процедуру так:


 procedure TForm1.WMMouseActivate(var Msg: TMessage);
 begin
   try
     inherited;
     if Msg.LParamHi = 516 then
       Msg.Result:= MA_NOACTIVATEANDEAT;
   except
   end;
 end;
 

Значение Msg.LparamHi показывает, какая кнопка нажата. 513 - нажата левая, 516 – нажата правая.

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

И еще один недостаток/особенность – полностью, со 100% надежностью перекрыть меню IE своим таким способом почему-то не удается, а вот просто запретить появление – да.

А можно ли управлять отображением меню на уровне самого WebBrowser? Да, отвечает MSDN.

Для этого нужно сперва получить доступ к интерфейсу IDocHostUIHandler и вызвать один из его методов – ShowContextMenu.

Учтите, версия IE – не ниже 4.0. (В С/С++ он описан в файлах Mshtmhst.h; Mshtmhst.idl )

Получить этот интерфейс можно вызывая QueryInterface с параметром IID_IDocHostUIHandler. Он предназначен для управления панелями, меню и контекстными меню WebBrowser-a.

Нас интересует пока только метод ShowContextMenu. Вот его обьявление:


 function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const
   pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;
 

dwID
идентификатор меню, которое будет отображаться
ppt
указатель на структуру, которая указывает на координаты, где нужно отобразить меню.
pcmdTarget
ссылка на IOleCommandTarget интерфейс, который используется для запроса статуса и команд, которые должны выполняться меню.
рdispObject
ссылка на IDispatch интерфейс объекта, для того, что бы вызывать различные меню для различных объектов.

Метод возвращает:

S_OK
Отображается стандартное меню.
S_FALSE
Отображается другое, определенное программой меню.
DOCHOST_E_UNKNOWN
Идентификатор меню неизвестен.

В Internet Explorer 4.0 параметр pdispObject не используется, но в IЕ 5 и позже параметр содержит адрес IDispatch интерфейса. Таким способом можно выборочно запрещать появление контекстных меню.

Некоторые другие интересные методы IDocHostUIHandler:


 function HideUI: HRESULT; stdcall;
 

Вызываеться, когда удаляеться пункт меню или панели инструментов.


 function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
   const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame; const
   pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
 

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

Добавление пункта в стандартное меню

Иногда, если вы пишете какое-то приложение, которое взаимодействует с браузером, вам необходимо вызвать его непосредственно из IE. Но как добавить свой пункт в меню?

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


 HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\MenuExt
 

В этом разделе создайте подраздел, который будет иметь название такое же, как и пункт меню. Значение по умолчанию содержит URL, по которому находиться скрипт. Для подчеркивания вставьте в название перед нужной буквой символ &.

Скрипт будет загружен и выполнен в скрытом окне. В его свойстве external.menuArguments будет содержаться объект window того окна, где был выполнен скрипт меню.

Пример. Вставляет пункт с названием "Демо" в стандартное меню. При нажатии выполняется скрипт, который содержится в файле "С:\demo_script.htm".


 HKEY_CURRENT_USER
 Software
 Microsoft
 Internet Explorer
 MenuExt
 Open in new window = "file://c:\demo_script.htm"
 

В файл впишите следующее


 <SCRIPT LANGUAGE="JavaScript" defer>
 open(external.menuArguments.location.href);
 </SCRIPT>
 

Действие скрипта заключаеться в следующем:

Он открывает новое окно браузера, и загружает в него документ, который определен в external.menuArguments.location.href – окне, в котором было вызвано меню.

Дополнительные ключи.

Под ключом, где содержится URL скрипта, есть еще несколько величин. Одна из них определяет, в каком из доступных контекстных меню появиться этот новый пункт. Вторая определяет, что сценарий должен выполняться как dialog box.

Ключ "Contexts" имеет тип DWORD, и задает контексты, в которых будет появляться ваше меню. Определяется как применение операции логического ИЛИ над следующими константами:


 (0x1 << CONTEXT_MENU_DEFAULT) (evaluates to 0x1)
 (0x1 << CONTEXT_MENU_IMAGE) (evaluates to 0x2)
 (0x1 << CONTEXT_MENU_CONTROL) (evaluates to 0x4)
 (0x1 << CONTEXT_MENU_TABLE) (evaluates to 0x8)
 (0x1 << CONTEXT_MENU_TEXTSELECT) (evaluates to 0x10)
 (0x1 << CONTEXT_MENU_ANCHOR) (evaluates to 0x20)
 (0x1 << CONTEXT_MENU_UNKNOWN) (evaluates to 0x40)
 

Так, к примеру, вам нужно, что бы ваше меню появлялось только когда есть выделенный текст. Тогда запишите значение 0x10 (CONTEXT_MENU_TEXTSELECT)

Второй ключ - flag с типом DWORD. Если первый бит установлен в 0x1, то сценарий выполняется так, если бы он был вызван методом showModalDialog. Окно, в котором выполняеться скрипт не скрываеться, и не закрываеться после выполнения сценария.

Как реализовать все это в Дельфи?

  1. Поскольку метод вставки пунктов меню позволяет вставить только ссылку на файл со скриптом, то нужно писать скрипт который будет вызывать вашу программу и передавать ей нужные значения. Для этого нужно еще знать VBScript или JavaScript.
  2. Большая проблема состоит в том, что описания интерфейса IDocHostUIHandler нет в файлах.

Но его описание есть в иходниках компонента EmbeddedWB, который можно взять на http://www.euromind.com/iedelphi/

Немножко поразбиравшись, я пришел к таким результатам:

Интерфейс не поддерживаеться стандартным TWebBrowser. Попытка перенести описание интерфейса с EmbeddedWB ник чему не приводит. Я понял с исходников, что при вызове IUnknown(WebBrowser1) as IDocHostUIHandler происходит обращение к DefaultInterface, а он у TWebBrowser IWebBrowser2. А он не знает о нужном нам интерфейсе.

Может, эта статья и не ответила на все вопросы, а только создала новые – не знаю. Это всегда так – как только с чем-то начинаешь разбираться, сразу к старым вопросам прибавляются новые…




Перехват клавиши SHIFT во время выбора пункта меню

Пришел програмист в гости к пианисту. Очень долго ходил вокруг рояля и озвучивает свои наблюдения:
- Клавиатура не стандартная - 64 клавиши вместо 101, половина из них функциональные, но вот shift ногой нажимать-оригинально!


 procedure TForm1.Menu11Click(Sender: TObject);
 begin
   {Проверяем нажатость клавиши Shift}
   if HiWord(GetKeyState(VK_SHIFT)) <> 0 then
     Label1.Caption := 'Shift'
   else
     {Проверяем нажатость клавиши Ctrl} if HiWord(GetKeyState(VK_CONTROL)) <> 0
       then
       Label1.Caption := 'Control'
     else
       {Проверяем нажатость клавиши Alt} if HiWord(GetKeyState(VK_MENU)) <> 0
         then
         Label1.Caption := 'Alt'
       else
         Label1.Caption := 'Никакая из управляющих клавиш не нажата';
 end;
 




Как сделать пункты меню с картинками

Следующий код показывает, как добавить картинку в виде объекта TImage в объект TMenuItem:


 var
    hHandle: THandle;
    x: integer;
    // visual controls:
    hMenu: TMenuItem;
    Image1: TImage;
 ...
 x:= 10; // десятый пункт меню
 hHandle := GetMenuItemID(hMenu.handle, x);
 ModifyMenu(hMenu.handle, hHandle, MF_BYCOMMAND or MF_BITMAP,
 hHandle, PChar(Image1.picture.bitmap.handle));
 




Как главное меню приложения вставить в TToolBar (как в Delphi)

  1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
  2. Разместите TToolBar (закладка Win32) внутри TControlBar.
  3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
  4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton)
  5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между главными пунктами меню (если меню уже показано).
  6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu формы).
  7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
  8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.



Несколько иконок в Delphi exe

Кто-нибудь знает как с помощью Delphi присвоить выполнимому файлу сразу несколько иконок? Т.е. так, что если вы ассоциируете тип файла и просматриваете ваше скомпилированное приложение, вы видите несколько возможных иконок, но, к сожалению, опция Project|Options|Application|Icon позволяет установить только одну иконку.

Просто создайте файл ресурса (.res), для примера, в Image Editor, и сохраните в нем ваши иконки. Затем подлинкуйте ресурс директивой компилятора $R и ваше приложение будет иметь столько иконок, сколько вы их создадите.




Текст на кнопках MessageDlg

Автор: Steve Schafer

Как можно сменить текст на кнопках диалогового окна MessageDlg? Английский язык для текста кнопок пользователь хочет заменить на родной.

Текст кнопок извлекается из списка строк, расположенных в файле ...\DELPHI\SOURCE\VCL\CONSTS.PAS. Отредактируйте его, после чего пересоберите VCL.

VS дополняет:

Но можно ничего не менять. Вместо MessageDlg использовать MessageBox - функция WINDOWS. И, если ваш WINDOWS русифицирован, то надписи на кнопках в диалоговых окнах будут на русском языке.




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



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



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


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