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

ВИДЕОКУРС ВЗЛОМ
выпущен 10 декабря!


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

БОЛЬШОЙ FAQ ПО DELPHI



Как заставить появляться хинт, когда я захочy

Автор: Nomadic


 {Появление}
 IF h<>nil H.ReleaseHandle; {если чей-то хинт yже был, то его погасить}
 H:=THintWindow.Create(Окно-владелец хинта);
 H.ActivateHint(H.CalcHintRect(...),'hint hint nint');
 ....
 {UnПоявление :) - это возможно пpидется повесить на таймеp, котоpый бyдет
 обнyляться пpи каждом новом появлении хинта}
 IF h<>nil H.ReleaseHandle;
 
 

По-дpyгомy задача тоже pешаема, но очень плохо. (см исходник объекта TApplication, он как pаз сабжами заведyет.




Вывод даты в нужном формате


 function CheckDateFormat(SDate:  string):  string;
 var
   IDateChar: string;
   x, y: integer;
 begin
   IDateChar := '.,\/';
   for y := 1 to length(IDateChar) do
   begin
     x := pos(IDateChar[y], SDate);
     while x > 0 do
     begin
       Delete(SDate, x, 1);
       Insert('-', SDate, x);
       x := pos(IDateChar[y], SDate);
     end;
   end;
   CheckDateFormat := SDate;
 end;
 
 
 function DateEncode(SDate:string):longint;
 var
   year, month, day: longint;
   wy, wm, wd: longint;
   Dummy: TDateTime;
   Check: integer;
 begin
   DateEncode := -1;
   SDate := CheckDateFormat(SDate);
   Val(Copy(SDate, 1, pos('-', SDate) - 1), day, check);
   Delete(Sdate, 1, pos('-', SDate));
   Val(Copy(SDate, 1, pos('-', SDate) - 1), month, check);
   Delete(SDate, 1, pos('-', SDate));
   Val(SDate, year, check);
   wy := year;
   wm := month;
   wd := day;
   try
     Dummy := EncodeDate(wy, wm, wd);
   except
     year := 0;
     month := 0;
     day := 0;
   end;
   DateEncode := (year * 10000) + (month * 100) + day;
 end;
 




Форматирование диска в Win32


Начинается демонстрация нового компьютера, управляемого голосом. Изобретатель просит зал соблюдать тишину. Только он открывает рот - из зала крик:
- FORMAT C:!!! ENTER!!!


 const SHFMT_DRV_A = 0;
 const SHFMT_DRV_B = 1;
 const SHFMT_ID_DEFAULT = $FFFF;
 const SHFMT_OPT_QUICKFORMAT = 0;
 const SHFMT_OPT_FULLFORMAT = 1;
 const SHFMT_OPT_SYSONLY = 2;
 const SHFMT_ERROR = -1;
 const SHFMT_CANCEL = -2;
 const SHFMT_NOFORMAT = -3;
 function SHFormatDrive(hWnd : HWND;
   Drive : Word;
   fmtID : Word;
   Options : Word) : Longint
   stdcall; external 'Shell32.dll' name 'SHFormatDrive';
 
 ...
 implementation
 ...
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   FmtRes: longint;
 begin
   try
     FmtRes:= ShFormatDrive(Handle,
       SHFMT_DRV_A,
       SHFMT_ID_DEFAULT,
       SHFMT_OPT_QUICKFORMAT);
     case FmtRes of
       SHFMT_ERROR :
         ShowMessage('Error formatting the drive');
       SHFMT_CANCEL :
         ShowMessage('User canceled formatting the drive');
       SHFMT_NOFORMAT :
         ShowMessage('No Format')
     else
       ShowMessage('Disk has been formatted');
     end;
   except
   end;
 end;
 




Градиентная заливка формы


Говорят, в Windows 95 дружественный интерфейс. Hо почему учебник на 1000 страниц?!

Процедура GradientRect делает градиентную заливку (сверху в низ). Параметры: цвета [от и до] и объект Canvas, поверхность которого и будет закрашена


 procedure TForm1.GradientRect (FromRGB, ToRGB: TColor; Canvas: TCanvas);
 var
   RGBFrom : array[0..2] of Byte; { from RGB values }
   RGBDiff : array[0..2] of integer; { difference of from/to RGB values }
   ColorBand : TRect; { color band rectangular coordinates }
   I : Integer; { color band index }
   R : Byte; { a color band's R value }
   G : Byte; { a color band's G value }
   B : Byte; { a color band's B value }
 begin
   { extract from RGB values}
   RGBFrom[0] := GetRValue (ColorToRGB (FromRGB));
   RGBFrom[1] := GetGValue (ColorToRGB (FromRGB));
   RGBFrom[2] := GetBValue (ColorToRGB (FromRGB));
   { calculate difference of from and to RGB values}
   RGBDiff[0] := GetRValue (ColorToRGB (ToRGB)) - RGBFrom[0];
   RGBDiff[1] := GetGValue (ColorToRGB (ToRGB)) - RGBFrom[1];
   RGBDiff[2] := GetBValue (ColorToRGB (ToRGB)) - RGBFrom[2];
 
   { set pen sytle and mode}
   Canvas.Pen.Style := psSolid;
   Canvas.Pen.Mode := pmCopy;
 
   { set color band's left and right coordinates}
   ColorBand.Left := 0;
   ColorBand.Right:= canvas.ClipRect.Right-Canvas.ClipRect.Left;
 
   for I := 0 to $ff do
   begin
     { calculate color band's top and bottom coordinates}
     ColorBand.Top := MulDiv (I , canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
     ColorBand.Bottom := MulDiv (I + 1,canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
     { calculate color band color}
     R := RGBFrom[0] + MulDiv (I, RGBDiff[0], $ff);
     G := RGBFrom[1] + MulDiv (I, RGBDiff[1], $ff);
     B := RGBFrom[2] + MulDiv (I, RGBDiff[2], $ff);
     { select brush and paint color band}
     Canvas.Brush.Color := RGB (R, G, B);
     Canvas.FillRect (ColorBand);
   end;
 end;
 

Эту процедуру объявляем в публичных объявлениях:


 public
   { Public declarations }
   procedure GradientRect(FromRGB, ToRGB: TColor; Canvas: TCanvas);
 

Для закраски формы в обработчик формы OnPaint нужно вставить:


 GradientRect (clBlue, clBlack, Canvas);
 

По событию OnResize для формы напишем:


 Paint;
 




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

Плакат: изображена BMW и надпись - наше железо работает хорошо безо всяких Windows...

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

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


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

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


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

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


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


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




Формулы передачи данных для начинающих

Юзер - супорту:
- A чего это я постоянно слетаю с ваших модемов?!
- Летаешь - значит растешь!

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

Каково различие между KBps и Kbps? В чём заключается отличие битов, байтов и бодов? Как определить скорость передачи данных? Как выяснить, насколько долго будет загружаться файл с определённой скоростью? Как посчитать время, оставшее до окончания загрузки?

Для начала хотельсы навести порядок с некоторой неразберихой по поводу KBps и Kbps (буква b в нижнем регистре). KBps это обозначение для килобайт в секунду, в то время как Kbps обозначает килобиты в секунду. 1 килобайт (KB) = 8 килобитам (Kb).

Когда речь идёт о скорости передачи, то применяется Kbps. Таким образом модем со скорость передачи 33.6K (33600 bps) передаёт данные со скоростью 4.2 KBps (4.2 килобайта в секунду). Как мы видим, разница между KB и Kb довольно ощутима. В этом кроется причина того, что некоторые пользователи модемов по своему незнанию не могут понять, почему данные передаются так медленно. На самом деле данные объёмом 33.6K передаются не за 1 секунду, а за 8, соответственно за одну секунду будет передано 33.6 Kb / 8 = 4.2.

Так же хотелось бы дать некоторые разъяснения по поводу слова "бод" (baud). Обычно для модема "боды" расшифровываются как бит в секунду. На самом деле это не так. Бод (Baud) означает частоту звука в телефонной линии. Т. е. в зависимости от модема, который Вы используете, количество бит, которые могут быть переданы зависит от частоты звука, необходимой для обеспечения нужной скорости передачи.

Обратите внимание: Приведённый ниже пример, использует компонент NetMasters TNMHTTP. Однако, если Вы "прикипели" к какому-то другому компоненту TCP/IP, то переделать пример под этот компонент не составит большого труда.

Используемые обозначения:

bps
байт, переданных за 1 секунду
KBps (KB/Sec)
bps / 1024
Kbps (Kb/Sec)
KBps x 8

Краткий алгоритм приведённого ниже примера:

  1. Сохраняем в переменной время начала загрузки: nStartTime := GetTickCount;
  2. Сохраняем в переменной размер файла (KB): nFileSize := "File Size";
  3. Начало передачи данных.
  4. Обновляем количество переданных байт: Inc(nBytesTransferred, nNewBytes);
  5. Получаем оставшееся время: nTimeElapsed := (GetTickCount - nStartTime) / 1000;
  6. Вычисляем bps: nBps := BytesTransferred / nTimeElapsed;
  7. Вычисляем KBps: nKBps := nBps / 1024;

Используемые данные:


 Общее время скачивания (секунд) := nFileSize / nKBps;
 bps := FloatToStr(nBps);
 KB/Sec (KBps) := FloatToStr(nKBps);
 Осталось секунд := FloatToStr(((nFileSize - BytesTransferred) / 1024) / KBps);
 

Рабочий пример:


 unit Main;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Gauges, Psock, NMHttp;
 
 type
   TfMain = class(TForm)
     Label1: TLabel;
     eURL: TEdit;
     bGet: TButton;
     lbMessages: TListBox;
     gbDetails: TGroupBox;
     lEstimate: TLabel;
     lKBps: TLabel;
     lReceived: TLabel;
     lRemaining: TLabel;
     gProgress: TGauge;
     NMHTTP1: TNMHTTP;
     lbps: TLabel;
     bCancel: TButton;
     procedure NMHTTP1PacketRecvd(Sender: TObject);
     procedure bGetClick(Sender: TObject);
     procedure bCancelClick(Sender: TObject);
     procedure NMHTTP1Connect(Sender: TObject);
     procedure NMHTTP1ConnectionFailed(Sender: TObject);
     procedure NMHTTP1Disconnect(Sender: TObject);
     procedure NMHTTP1Failure(Cmd: CmdType);
     procedure NMHTTP1HostResolved(Sender: TComponent);
     procedure NMHTTP1InvalidHost(var Handled: Boolean);
     procedure NMHTTP1Status(Sender: TComponent; Status: string);
     procedure NMHTTP1Success(Cmd: CmdType);
   private
     { Private declarations }
     function ss2nn(Seconds: Integer): string;
   public
     { Public declarations }
 end;
 
 var
   fMain: TfMain;
   nFileSize: Double;
   nStartTime: DWord;
 
 implementation
 
 {$R *.DFM}
 
 {Цель этой функции состоит в том, чтобы определить,
 сколько минут и секунд там находятся в данном количестве секунд}
 function TfMain.ss2nn(Seconds: Integer): string;
 var
   nMin, nSec: Integer;
 begin
   {Проверяем, меньше чем 1/Min}
   if Seconds < 60 then
     Result := '0 minutes ' + IntToStr(Seconds) + ' seconds'
   else
   begin
     {Определяем минуты}
     nMin := Seconds div 60;
     {Определяем секунды}
     nSec := Seconds - (nMin * 60);
     {Возвращаем результат}
     Result := IntToStr(nMin) + ' minutes ' + IntToStr(nSec) + ' seconds';
   end;
 end;
 
 procedure TfMain.NMHTTP1PacketRecvd(Sender: TObject);
 var
   nBytesReceived, nTimeElapsed, nBps, nKBps: Double;
 begin
   {Следующий код выполняется только однажды, при приёме первого пакета}
   if nFileSize <> NMHTTP1.BytesTotal then
   begin
     {Получаем размер файла}
     nFileSize := NMHTTP1.BytesTotal;
     {Вычисляем время передачи, исходя из скорости соединения 33.6 Kbps}
     lEstimate.Caption := 'Estimated download time at 33.6 Kbps: ' + ss2nn(Round(
     (nFileSize / 1024) / 4.2));
     {Получаем время начала}
     nStartTime := GetTickCount;
   end;
 
   {Обновляем nBytesReceived}
   nBytesReceived := NMHTTP1.BytesRecvd;
 
   {Вычисляем количество секунд прошедших с момента начала передачи}
   nTimeElapsed := (GetTickCount - nStartTime) / 1000;
   {Проверяем на 0/Sec, если так, то устанавливаем 1,
   чтобы предотвратить деления на ноль}
   if nTimeElapsed = 0 then
     nTimeElapsed := 1;
 
   {Вычисляем байт в секунду}
   nBps := nBytesReceived / nTimeElapsed;
   {Вычисляем килобайт в секунду}
   nKBps := nBps / 1024;
 
   {Обновляем контролы}
   gProgress.Progress := Round((nBytesReceived * 100) / nFileSize);
   lbps.Caption := IntToStr(Round(nBps * 8)) + ' bits per second';
   lKBps.Caption := IntToStr(Round(nKBps)) + ' KB/Sec (KBps)';
   lReceived.Caption := FloatToStr(nBytesReceived) + ' of ' + FloatToStr(
   nFileSize) + ' bytes received';
   lRemaining.Caption := ss2nn(Round(((nFileSize - nBytesReceived) / 1024) /
   nKBps)) + ' remaining';
 end;
 
 procedure TfMain.bGetClick(Sender: TObject);
 begin
   {Сбрасываем переменные}
   nFileSize := 0;
 
   {Обнуляем контролы}
   lbMessages.Clear;
   gProgress.Progress := 0;
   lEstimate.Caption := 'Estimated download time at 33.6 Kbps: 0 minutes 0 ' +
   'seconds';
   lbps.Caption := '0 bits per second';
   lKBps.Caption := '0 KB/Sec (KBps)';
   lReceived.Caption := '0 of 0 bytes received';
   lRemaining.Caption := '0 minutes 0 seconds remaining';
 
   {Получаем файл}
   NMHTTP1.Get(eURL.Text);
 end;
 
 procedure TfMain.bCancelClick(Sender: TObject);
 begin
   {Разрываем соединение с сервером}
   NMHTTP1.Disconnect;
 
   {Обновляем lbMessages}
   lbMessages.Items.Append('Get Canceled');
   lbMessages.Items.Append('Disconnected');
 end;
 
 procedure TfMain.NMHTTP1Connect(Sender: TObject);
 begin
   {Запрещаем/Разрешаем контролы}
   bGet.Enabled := False;
   bCancel.Enabled := True;
 
   {Работаем с lbMessages}
   with lbMessages.Items do
   begin
     Append('Connected');
     Append('Local Address: ' + NMHTTP1.LocalIP);
     Append('Remote Address: ' + NMHTTP1.RemoteIP);
   end;
 end;
 
 procedure TfMain.NMHTTP1ConnectionFailed(Sender: TObject);
 begin
   ShowMessage('Connection Failed.');
 end;
 
 procedure TfMain.NMHTTP1Disconnect(Sender: TObject);
 begin
   {Запрещаем/Разрешаем контролы}
   bCancel.Enabled := False;
   bGet.Enabled := True;
 
   {Обновляем lbMessages}
   if NMHTTP1.Connected then
     lbMessages.Items.Append('Disconnected');
 end;
 
 procedure TfMain.NMHTTP1Failure(Cmd: CmdType);
 begin
   case Cmd of
     CmdGET     : lbMessages.Items.Append('Get Failed');
     CmdOPTIONS : lbMessages.Items.Append('Options Failed');
     CmdHEAD    : lbMessages.Items.Append('Head Failed');
     CmdPOST    : lbMessages.Items.Append('Post Failed');
     CmdPUT     : lbMessages.Items.Append('Put Failed');
     CmdPATCH   : lbMessages.Items.Append('Patch Failed');
     CmdCOPY    : lbMessages.Items.Append('Copy Failed');
     CmdMOVE    : lbMessages.Items.Append('Move Failed');
     CmdDELETE  : lbMessages.Items.Append('Delete Failed');
     CmdLINK    : lbMessages.Items.Append('Link Failed');
     CmdUNLINK  : lbMessages.Items.Append('UnLink Failed');
     CmdTRACE   : lbMessages.Items.Append('Trace Failed');
     CmdWRAPPED : lbMessages.Items.Append('Wrapped Failed');
   end;
 end;
 
 procedure TfMain.NMHTTP1HostResolved(Sender: TComponent);
 begin
   lbMessages.Items.Append('Host Resolved');
 end;
 
 procedure TfMain.NMHTTP1InvalidHost(var Handled: Boolean);
 begin
   ShowMessage('Invalid Host. Please specify a new URL.');
 end;
 
 procedure TfMain.NMHTTP1Status(Sender: TComponent; Status: string);
 begin
   if NMHTTP1.ReplyNumber = 404 then
     ShowMessage('Object Not Found.');
 end;
 
 procedure TfMain.NMHTTP1Success(Cmd: CmdType);
 begin
   case Cmd of
     {Удостоверяемся, что процедура получения не была прервана}
     CmdGET:
       if NMHTTP1.Connected then
         lbMessages.Items.Append('Get Succeeded');
 
     CmdOPTIONS : lbMessages.Items.Append('Options Succeeded');
     CmdHEAD    : lbMessages.Items.Append('Head Succeeded');
     CmdPOST    : lbMessages.Items.Append('Post Succeeded');
     CmdPUT     : lbMessages.Items.Append('Put Succeeded');
     CmdPATCH   : lbMessages.Items.Append('Patch Succeeded');
     CmdCOPY    : lbMessages.Items.Append('Copy Succeeded');
     CmdMOVE    : lbMessages.Items.Append('Move Succeeded');
     CmdDELETE  : lbMessages.Items.Append('Delete Succeeded');
     CmdLINK    : lbMessages.Items.Append('Link Succeeded');
     CmdUNLINK  : lbMessages.Items.Append('UnLink Succeeded');
     CmdTRACE   : lbMessages.Items.Append('Trace Succeeded');
     CmdWRAPPED : lbMessages.Items.Append('Wrapped Succeeded');
   end;
 end;
 
 end.
 




Посчитать строку с формулой

Программер живет на 12 этаже. После работы входит к себе в подъезд, заходит в лифт, нажимает 1, потом 2, а потом судорожно ищет клавишу "Enter"...

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

Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются" символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно, всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до сложения с вычитанием.

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

Вот модуль с этими методами:


 unit Recognition;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, Math;
 
 type
   TVar = set of char;
 
   procedure Preparation(var s: string; variables: TVar);
   function ChangeVar(s: string; c: char; value: extended): string;
   function Recogn(st: string; var Num: extended): boolean;
 
 implementation
 
 
 procedure Preparation(var s: string; variables: TVar);
 const
   operators: set of char = ['+','-','*', '/', '^'];
 var
   i: integer;
   figures: set of char;
 begin
   figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;
 
   // " "
   repeat
     i := pos(' ', s);
     if i <= 0 then
       break;
     delete(s, i, 1);
   until
     1 = 0;
 
   s := LowerCase(s);
 
   // ".", ","
   if DecimalSeparator = '.' then
   begin
     i := pos(',', s);
     while i > 0 do
     begin
       s[i] := '.';
       i := pos(',', s);
     end;
   end
   else
   begin
     i := pos('.', s);
     while i > 0 do begin
       s[i] := ',';
       i := pos('.', s);
     end;
   end;
 
   // Pi
   repeat
     i := pos('pi', s);
     if i <= 0 then
       break;
     delete(s, i, 2);
     insert(FloatToStr(Pi), s, i);
   until
     1 = 0;
 
   // ":"
   repeat
     i := pos(':', s);
     if i <= 0 then
       break;
     s[i] := '/';
   until
     1 = 0;
 
   // |...|
   repeat
     i := pos('|', s);
     if i <= 0 then
       break;
     s[i] := 'a';
     insert('bs(', s, i + 1);
     i := i + 3;
     repeat
       i := i + 1
     until
       (i > Length(s)) or (s[i] = '|');
     if s[i] = '|' then
       s[i] := ')';
   until
     1 = 0;
 
   // #...#
   i := 1;
   repeat
     if s[i] in figures then
     begin
       insert('#', s, i);
       i := i + 2;
       while (s[i] in figures) do
         i := i + 1;
       insert('#', s, i);
       i := i + 1;
     end;
     i := i + 1;
   until
     i > Length(s);
 end;
 
 function ChangeVar(s: string; c: char; value: extended): string;
 var
   p: integer;
 begin
   result := s;
   repeat
     p := pos(c, result);
     if p <= 0 then
       break;
     delete(result, p, 1);
     insert(FloatToStr(value), result, p);
   until
     1 = 0;
 end;
 
 function Recogn(st: string; var Num: extended): boolean;
 const
   pogr = 1E-5;
 var
   p, p1: integer;
   i, j: integer;
   v1, v2: extended;
   func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos,
     fArctg, fArcctg, fAbs, fLn, fLg, fExp);
   Sign: integer;
   s: string;
   s1: string;
 
 function FindLeftValue(p: integer; var Margin: integer;
   var Value: extended): boolean;
 var
   i: integer;
 begin
   i := p - 1;
   repeat
     i := i - 1
   until
     (i <= 0) or (s[i] = '#');
   Margin := i;
   try
     Value := StrToFloat(copy(s, i + 1, p - i - 2));
     result := true;
   except
     result := false
   end;
   delete(s, i, p - i);
 end;
 
 function FindRightValue(p: integer; var Value: extended): boolean;
 var
   i: integer;
 begin
   i := p + 1;
   repeat
     i := i + 1
   until
     (i > Length(s)) or (s[i] = '#');
   i := i - 1;
   s1 := copy(s, p + 2, i - p - 1);
   result := TextToFloat(PChar(s1), value, fvExtended);
   delete(s, p + 1, i - p + 1);
 end;
 
 procedure PutValue(p: integer; NewValue: extended);
 begin
   insert('#' + FloatToStr(v1) + '#', s, p);
 end;
 
 begin
   Result := false;
   s := st;
 
   // ()
   p := pos('(', s);
   while p > 0 do
   begin
     i := p;
     j := 1;
     repeat
       i := i + 1;
       if s[i] = '(' then
         j := j + 1;
       if s[i] = ')' then
         j := j - 1;
     until
       (i > Length(s)) or (j <= 0);
     if i > Length(s) then
       s := s + ')';
     if Recogn(copy(s, p + 1, i - p - 1), v1) = false then
       Exit;
     delete(s, p, i - p + 1);
     PutValue(p, v1);
 
     p := pos('(', s);
   end;
 
   // sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
   repeat
     func := fNone;
     p1 := pos('sin', s);
     if p1 > 0 then
     begin
       func := fSin;
       p := p1;
     end;
     p1 := pos('cos', s);
     if p1 > 0 then
     begin
       func := fCos;
       p := p1;
     end;
     p1 := pos('tg', s);
     if p1 > 0 then
     begin
       func := fTg;
       p := p1;
     end;
     p1 := pos('ctg', s);
     if p1 > 0 then
     begin
       func := fCtg;
       p := p1;
     end;
     p1 := pos('arcsin', s);
     if p1 > 0 then
     begin
       func := fArcsin;
       p := p1;
     end;
     p1 := pos('arccos', s);
     if p1 > 0 then
     begin
       func := fArccos;
       p := p1;
     end;
     p1 := pos('arctg', s);
     if p1 > 0 then
     begin
       func := fArctg;
       p := p1;
     end;
     p1 := pos('arcctg', s);
     if p1 > 0 then
     begin
       func := fArcctg;
       p := p1;
     end;
     p1 := pos('abs', s);
     if p1 > 0 then
     begin
       func := fAbs;
       p := p1;
     end;
     p1 := pos('ln', s);
     if p1 > 0 then
     begin
       func := fLn;
       p := p1;
     end;
     p1 := pos('lg', s);
     if p1 > 0 then
     begin
       func := fLg;
       p := p1;
     end;
     p1 := pos('exp', s);
     if p1 > 0 then
     begin
       func := fExp;
       p := p1;
     end;
     if func = fNone then
       break;
 
     case func of
       fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
       fArctg: i := p + 4;
       fArcsin, fArccos, fArcctg: i := p + 5;
       else
         i := p + 1;
     end;
 
     if FindRightValue(i, v1) = false then
       Exit;
     delete(s, p, i - p + 1);
     case func of
       fSin: v1 := sin(v1);
       fCos: v1 := cos(v1);
       fTg:
       begin
         if abs(cos(v1)) < pogr then
           Exit;
         v1 := sin(v1) / cos(v1);
       end;
       fCtg:
       begin
         if abs(sin(v1)) < pogr then
           Exit;
         v1 := cos(v1) / sin(v1);
       end;
       fArcsin:
       begin
         if Abs(v1) > 1 then
           Exit;
         v1 := arcsin(v1);
       end;
       fArccos:
       begin
         if abs(v1) > 1 then
           Exit;
         v1 := arccos(v1);
       end;
       fArctg: v1 := arctan(v1);
       // fArcctg: v1 := arcctan(v1);
       fAbs: v1 := abs(v1);
       fLn:
       begin
         if v1 < pogr then
           Exit;
         v1 := Ln(v1);
       end;
       fLg:
       begin
         if v1 < 0 then
           Exit;
         v1 := Log10(v1);
       end;
       fExp: v1 := exp(v1);
     end;
     PutValue(p, v1);
   until
     func = fNone;
 
   // power
   p := pos('^', s);
   while p > 0 do
   begin
     if FindRightValue(p, v2) = false then
       Exit;
     if FindLeftValue(p, i, v1) = false then
       Exit;
     if (v1 < 0) and (abs(Frac(v2)) > pogr) then
       Exit;
     if (abs(v1) < pogr) and (v2 < 0) then
       Exit;
     delete(s, i, 1);
     v1 := Power(v1, v2);
     PutValue(i, v1);
     p := pos('^', s);
   end;
 
   // *, /
   p := pos('*', s);
   p1 := pos('/', s);
   if (p1 > 0) and ((p1 < p) or (p <= 0)) then
     p := p1;
   while p > 0 do
   begin
     if FindRightValue(p, v2) = false then
       Exit;
     if FindLeftValue(p, i, v1) = false then
       Exit;
     if s[i] = '*' then
       v1 := v1 * v2
     else
     begin
       if abs(v2) < pogr then
         Exit;
       v1 := v1 / v2;
     end;
     delete(s, i, 1);
     PutValue(i, v1);
 
     p := pos('*', s);
     p1 := pos('/', s);
     if (p1 > 0) and ((p1 < p) or (p <= 0)) then
       p := p1;
   end;
 
   // +, -
   Num := 0;
   repeat
     Sign := 1;
     while (Length(s) > 0) and (s[1] <> '#') do
     begin
       if s[1] = '-' then
         Sign := -Sign
       else
       if s[1] <> '+' then
         Exit;
       delete(s, 1, 1);
     end;
     if FindRightValue(0, v1) = false then
       Exit;
     if Sign < 0 then
       Num := Num - v1
     else
       Num := Num + v1;
   until
     Length(s) <= 0;
 
   Result := true;
 end;
 
 end.
 

А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края графика, а YScale – масштаб по Y.


 uses Recognition;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   left = -10;
   right = 10;
   YScale = 50;
 var
   i: integer;
   Num: extended;
   s: string;
   XScale: single;
   col: TColor;
 begin
   s := Edit1.Text;
   preparation(s, ['x']);
   XScale := PaintBox1.Width / (right - left);
   randomize;
   col := RGB(random(100), random(100), random(100));
   for i := round(left * XScale) to round(right * XScale) do
     if recogn(ChangeVar(s, 'x', i / XScale), Num) then
       PaintBox1.Canvas.Pixels[round(i - left * XScale),
   round(PaintBox1.Height / 2 - Num * YScale)] := col;
 end;
 




Изменить параметры создания формы - добавить прозрачность


 unit TranspaF;
 
 interface
 
 uses
   SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs;
 
 type
   TForm1 = class(TForm)
   private
     { Private declarations }
   public
     procedure CreateParams (var Params: TCreateParams); override;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.CreateParams (var Params: TCreateParams);
 begin
   inherited CreateParams (Params);
   Params.ExStyle := Params.ExStyle or
     WS_EX_TRANSPARENT;
 end;
 
 end.




Событие при потере и установке фокуса для формы


 Type TMain = class(TForm)
   ....
   protected Procedure LastFocus(var Mess : TMessage);
     message  WM_ACTIVATE;
 End;
 
 Procedure TMain.LastFocus(var Mess : TMessage);
 Begin
   IF  Mess.wParam = WA_INACTIVE Then
     PanelCaption.Color:=clInactiveCaption
   Else
     PanelCaption.Color:=clActiveCaption;
 
   Inherited;
 End;
 
 




Форма как графический объект


 uses clipbrd;
 
 procedure TShowVRML.Kopieren1Click(Sender: TObject);
 var
   bitmap: tbitmap;
 begin
   bitmap := tbitmap.create;
   bitmap.width := clientwidth;
   bitmap.height := clientheight;
   try
     with bitmap.Canvas do
       CopyRect(clientrect, canvas, clientrect);
     clipboard.assign(bitmap);
   finally
     bitmap.free;
   end;
 end;
 




Замена Form на FormIni

Автор: Nick Hodges (Monterey, CA)


 unit Formini;
 
 {$IFDEF Production}
 {$S-,R-,D-,L-,W-}
 {$ENDIF}
 
 {
 TFormINI новая замена TForm, умеющая автоматически сохранять и восстанавливать
 значения свойств Top, Left, Height, Width и WindowState
 из программного INI-файла без какого-то либо программирования.
 
 Код берет имя выполняемого файла из Application.EXEName и меняет
 расширение на .INI.
 
 В качестве имени секции при хранении величин в INI-файле,
 TFormINI использует заголовок формы.
 
 Просто замените все существующие объявления класса TForm на TFormINI,
 и TFormINI позаботится обо всем остальном (в пределах функциональности).
 
 Теперь ваши формы будут такие же, как и при их закрытии.
 
 TMyForm = class(TForm) -> TMyForm = class(TFormINI)
 }
 
 interface
 
 uses InIFiles, Forms, Controls, SysUtils, WinTypes, Classes;
 
 type
   TFormINI = class(TForm)
   private
     PrgINI: TIniFile;
     FSection: string;
   protected
     procedure WriteInteger(Section, Ident: string; value: longint);
     function ReadInteger(Section, Ident: string; Default: longint): longint;
   public
     constructor Create(AOwner: TComponent); override;
     procedure CreateParams(var Params: TCreateParams); override;
 
     procedure DoShow; override;
     destructor Destroy; override;
   end;
 
 implementation
 
 constructor TFormINI.Create(AOwner: TComponent);
 var
   INIFile: string;
 begin
   INIFile := ExtractFileName(Application.EXEName);
   INIFile := ChangeFileExt(INIFile, '.INI');
   PrgINI := TIniFile.Create(INIFile);
   inherited Create(AOwner);
 end;
 
 procedure TFormINI.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   with Params do
   begin
     FSection := StrPas(Caption);
     Y := ReadInteger('', 'Top', 0);
     X := ReadInteger('', 'Left', 0);
     Width := ReadInteger('', 'Width', Width);
     Height := ReadInteger('', 'Height', Height);
   end;
 end;
 
 procedure TFormINI.DoShow;
 var
   aWindowState: integer;
 begin
   aWindowState := ReadInteger('', 'WindowState', 0);
   case aWindowState of
     0: WindowState := wsNormal;
     1: WindowState := wsMinimized;
     2: WindowState := wsMaximized;
   end;
   inherited DoShow;
 end;
 
 procedure TFormINI.WriteInteger(Section, Ident: string; value: longint);
 begin
   if Section = '' then
     PrgINI.WriteInteger(FSection, Ident, value)
   else
   begin
     PrgINI.WriteInteger(Section, Ident, value);
     FSection := Section;
   end;
 end;
 
 destructor TFormINI.Destroy;
 begin
   if WindowState = wsNormal then
   begin
     WriteInteger('', 'Top', Top);
     WriteInteger('', 'Left', Left);
   end;
   WriteInteger('', 'Width', Width);
   WriteInteger('', 'Height', Height);
   case WindowState of
     wsNormal: WriteInteger('', 'WindowState', 0);
     wsMinimized: WriteInteger('', 'WindowState', 1);
     wsMaximized: WriteInteger('', 'WindowState', 2);
   end;
   PrgINI.Free;
   inherited Destroy;
 end;
 
 function TFormINI.ReadInteger(Section, Ident: string; Default: longint):
   longint;
 begin
   if Section = '' then
     Result := PrgINI.ReadInteger(FSection, Ident, Default)
   else
   begin
     Result := PrgINI.ReadInteger(Section, Ident, Default);
     FSection := Section;
   end;
 end;
 
 end.
 




Помещение формы в DLL

Автор: Neil J. Rubenking

Вы можете помещать простые формы в DLL на этапе разработки. Это можно сделать с формами, полностью готовыми к работе и не требующими доработки. Вот пример DLL, которая создает, отображает и освобождает форму. В примере была взята экстра-простая форма для того, чтобы показать, что она может быть использована любым языком, не только в Delphi. Как я и обещал, я преподнес вам идею. Гвоздь программы в том, что пока вы проектируете свое приложение, форма из вашей DLL в Delphi *не* загружается. Только не забудьте в конце разработки ее скомпилить :-)) .

Имейте в виду, что все функции в DLL-примере 32-битные. Т.е. после получения с помощью CreateTheForm указателя на форму, необходимые функции получат в свои руки полное 32-битное управление формой. Вероятно вам это и не понадобится, но это пример того, КАК нужно делать...


 library Formdll;
 
 uses
 
   SysUtils,
   Forms,
   Formdllu in 'FORMDLLU.PAS' {Form1};
 
 function CreateTheForm: Pointer; export;
 begin
 
   Result := TForm1.Create(nil);
 end;
 
 procedure LoadTheForm(P: Pointer; S1, S2, S3: PChar); export;
 begin
 
   with TForm1(P) do
   begin
     Edit1.Text := StrPas(S1);
     Edit2.Text := StrPas(S2);
     Edit3.Text := StrPas(S3);
   end;
 end;
 
 function ShowTheForm(P: Pointer): Boolean; export;
 const
   mrOK = 1;
 begin
 
   Result := TForm1(P).ShowModal = mrOK;
 end;
 
 procedure ReadTheForm(P: Pointer; S1, S2, S3: PChar); export;
 begin
 
   with TForm1(P) do
   begin
     StrPCopy(S1, Edit1.Text);
     StrPCopy(S2, Edit2.Text);
     StrPCopy(S3, Edit3.Text);
   end;
 end;
 
 procedure DestroyTheForm(P: Pointer); export;
 begin
 
   TForm1(P).Free;
 end;
 
 exports
 
   CreateTheForm INDEX 1,
   LoadTheForm INDEX 2,
   ReadTheForm INDEX 3,
   ShowTheForm INDEX 4,
   DestroyTheForm INDEX 5;
 
 begin
 end.
 




Форма Delphi на панели задач

Автор: Neil Rubenking

Вот что вы можете сделать, чтобы заставить форму Delphi иметь кнопку на панели задач:


 type
   TForm2 = class(TForm)
   private
     { Private declarations }
     procedure CreateParams(var Params: TCreateParams); override;
   end;
 ...
 
 procedure TForm2.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   with Params do
     ExStyle := ExStyle or WS_EX_APPWINDOW;
 end;
 




Как работать с формой, куда динамически передаются страницы

Автор: Nomadic

Кидаю проект-болванку, сделанную перед началом работы над основным


 unit Unit1; //базовая форма хранителя страницы
 interface
 uses...
 type
 
   TBPgFrm = class(TForm)
     Panel1: TPanel;
     PageControl1: TPageControl;
     TabSheet1: TTabSheet;
     Label1: TLabel;
   public
     function PgInit: boolean; virtual;
     function PgValid: boolean; virtual;
   end;
 
 implementation
 
 {$R *.DFM}
 
 function TBPgFrm.PgInit: boolean;
 begin
 
   result := MessageDlg(Label1.Caption + ': PgInit',
     mtConfirmation, mbOkCancel, 0) = mrOK;
 end;
 
 function TBPgFrm.PgValid: boolean;
 begin
 
   result := MessageDlg(Label1.Caption + ': PgValid',
     mtConfirmation, mbOkCancel, 0) = mrOK;
 end;
 
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 unit Unit2; //главная форма проекта; содержит первую страницу
 interface //и кнопки Cancel, Prev & Next/Finish.
 uses...
 
 type
   TPagesDlg = class(TForm)
     Panel1: TPanel;
     Panel2: TPanel;
     PageControl1: TPageControl;
     TabSheet1: TTabSheet;
     Prev: TButton;
     CancelBtn: TButton;
     Next: TButton;
     Label1: TLabel;
     procedure CancelBtnClick(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure NextClick(Sender: TObject);
     procedure PrevClick(Sender: TObject);
   private
     Frms: TList;
     procedure AddForms;
   end;
 
 var
   PagesDlg: TPagesDlg;
 
 implementation
 
 uses Unit1, Unit3, Unit4, Unit5;
 
 {$R *.DFM}
 
 procedure TPagesDlg.AddForms; //размещение динамических страниц
 var
   i: word;
 begin
 
   Frms := TList.Create;
   Frms.Add(TBPgFrm1.Create(Self));
   Frms.Add(TBPgFrm2.Create(Self));
   for i := 0 to 1 do
     TBPgFrm(Frms[i]).TabSheet1.PageControl := PageControl1
 end;
 
 procedure TPagesDlg.CancelBtnClick(Sender: TObject);
 begin
   Close;
 end;
 
 procedure TPagesDlg.FormDestroy(Sender: TObject);
 var
   i: word;
 begin
 
   for i := Frms.Count - 1 downto 0 do
     TBPgFrm(Frms[i]).Free;
   Frms.Free;
 end;
 
 procedure TPagesDlg.NextClick(Sender: TObject);
 var
 
   i: word;
   vi: Boolean;
 begin
 
   Next.Enabled := false;
   if PageControl1.PageCount = 1 then
     AddForms;
   i := PageControl1.ActivePage.PageIndex;
   if i = 0 then
     vi := true
   else
     vi := TBPgFrm(Frms[i - 1]).PgValid;
   if vi then
     with PageControl1 do
       if i = PageCount - 1 then
       begin
         CancelBtnClick(Sender);
         exit;
       end
       else
       begin
         ActivePage := FindNextPage(ActivePage, True, false);
         if ActivePage.PageIndex = PageCount - 1 then
           Next.Caption := 'Finish';
         Prev.Enabled := true;
         if TBPgFrm(Frms[i]).PgInit then
           Next.Enabled := true
         else
           PrevClick(Sender);
       end
     else
       Next.Enabled := true;
 end;
 
 procedure TPagesDlg.PrevClick(Sender: TObject);
 begin
 
   Prev.Enabled := false;
   with PageControl1 do
   begin
     ActivePage := FindNextPage(ActivePage, false, false);
     Prev.Enabled := ActivePage.PageIndex > 0;
   end;
   Next.Caption := 'Next';
   Next.Enabled := true;
 end;
 
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 unit Unit3; //наследник с RadioGroup.
 interface
 uses...
 type
 
   TBPgFrm3 = class(TBPgFrm)
     RadioValid: TRadioGroup;
   public
     function PgValid: boolean; override;
   end;
 
 implementation
 
 {$R *.DFM}
 
 function TBPgFrm3.PgValid: boolean;
 begin
 
   result := RadioValid.ItemIndex = 0;
 end;
 
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 unit Unit4; // наследник с CheckBox.
 interface
 uses...
 type
 
   TBPgFrm2 = class(TBPgFrm)
     CheckValid: TCheckBox;
   public
     function PgValid: boolean; override;
   end;
 
 implementation
 
 {$R *.DFM}
 
 function TBPgFrm2.PgValid: boolean;
 begin
 
   result := CheckValid.Checked;
 end;
 
 end.
 
 

В Delphi 4 появились новые возможности, в частности, возможность докинга визуальных компонент, в частности, форм, на различные DockSite, в том числе и на TPageControl. Это более удобно. Кроме того, Вы имеете возможность использования TFormLoader из библиотеки VG Library.




Режимы разрешения для формы

Автор: Steve

Я сделал довольно полный набор тестов, результаты которого показаны ниже:

                                режим показа формы
  режим создания формы      -------------------------
  --------------------      640S      1024S     1024L
         640S,s              OK        OK        B
         640S,u              OK        OK        C
         1024S,s             OK        OK        B
         1024S,u             OK        OK        C
         1024L,s             A         A         OK
         1024L,u             OK        OK        OK
 
 расшифровка:
 
  640  -> 640x480x256
  1024 -> 1024x768x256
  S/L  -> маленькие/большие шрифты
  s/u  -> Scaled := True/False
 
  OK: вид выводимой формы такой же, как и во время ее
      разработки
  A:  форма увеличивается относительно управляющих координат
  B:  форма сокращается относительно управляющих координат
  C:  форма и элементы управления слишком малы для текста
 
 

Вывод после проведенных экспериментов: для того, чтобы вероятность появления формы в том же виде, что она была при проектировании была высока, разработка ее дизайна должна производиться в системе с установленными большими шрифтами и со свойством формы Scaled := False.




Как сохранить всю форму в файл (как Delphi в .dfm)


 constructor TForm1.Create(AOwner: TComponent); // override;
 var
   fname: string;
 begin
   { Для динамически создаваемых контролов, может требоваться
   RegisterClasses(..); }
   fname := FormFilename;
   if FileExists( fname ) then
   begin
     CreateNew(AOwner);
     ReadComponentResFile(fname, Self);
   end
   else
     inherited Create( AOwner );
 end;
 
 procedure TForm1.FormCloseQuery( Sender: TObject;
   var CanClose: Boolean);
 begin
   WriteComponentResFile(FormFileName, Self);
 end;
 




Форма поверх всех других приложений

Мне необходимо поместить Delphi-форму ДЕЙСТВИТЕЛЬНО поверх других приложений, не просто поверх всех форм приложения (что просто), а постоянно, даже если я использую, к примеру, EXCEL.

Попробуй использовать Windows API функцию SetWindowPos(). Примерно так...


 with MyForm do
   SetWindowPos(Handle,
     HWND_TOPMOST,
     Left,
     Top,
     Width,
     Height,
     SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
 

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




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

Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.


 ... = class(TForm)
   ...
   protected
     procedure CreateParams(var params: TCreateParams); override;
   ...
 
 procedure TForm2.Createparams(var params: TCreateParams);
 var
   aHWnd: HWND;
 begin
   inherited;
   {как-нибудь получаем существующий дескриптор}
   ahWnd := GetForegroundWindow;
   {а теперь:}
   params.WndParent := ahWnd;
 end;
 




Сохранение TForm и ее свойств в BLOB-поле


 procedure SaveToField(FField: TBlobField; Form: TComponent);
 var
   Stream: TBlobStream;
   FormName: string;
 begin
   FormName := Copy(Form.ClassName, 2, 99);
   Stream := TBlobStream.Create(FField, bmWrite);
   try
     Stream.WriteComponentRes(FormName, Form);
   finally
     Stream.Free;
   end;
 end;
 
 procedure LoadFromField(FField: TBlobField; Form: TComponent);
 var
   Stream: TBlobStream;
   I: integer;
 begin
   try
     Stream := TBlobStream.Create(FField, bmRead);
     try
       {удаляем все компоненты}
       for I := Form.ComponentCount - 1 downto 0 do
         Form.Components[I].Free;
       Stream.ReadComponentRes(Form);
     finally
       Stream.Free;
     end;
   except
     on EFOpenError do
       {ничего};
   end;
 end;
 




Помещение формы в поток

Delphi имеет в своем распоряжении классную функцию, позволяющую сделать это:


 procedure WriteComponentResFile(const FileName: string;
   Instance: TComponent);
 

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


 function ReadComponentResFile(const FileName: string;
   Instance: TComponent): TComponent;
 




Как заставить форму находиться позади всех окон в системе

Програмиирование на C++: чтобы купить туалетную бумагу, Вы должны показать унитаз и попу.
Программирование на Visual Basic: Когда Вы покупаете туалетную бумагу, в Вашу корзину положат еще унитаз и попу.

Для этого достаточно висеть на WM_ACTIVATE и при активации окна помещать последнее вниз Z-order'а:


 SetWindowPos(
 Handle, // здесь указать хэндл окна формы
 HWND_BOTTOM,
 0, 0, 0, 0,
 SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOREDRAW
 




Прерывание цикла FOR

Автор: Александр Пронин

Hа pаботе пpопал пpогpаммеp. День нету, два. Hа звонки не отвечает. Hу pешили пpовеpить что да как. Пpишли к нему домой, а там в холодной ванне сидит лысый пpогpамист с полупустой бутылкой шампуня в pуке. Отняли у него бутылку и читают инстpукцию:
1. Hанести на влажные волосы
2. Hамылить
3. Подождать
4. Смыть
5._Повтоpить_


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     Label1: TLabel;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     k: integer;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: longint;
 begin
   i := 0;
   k := 0;
   for i := 0 to 500000 do
   begin
     Application.ProcessMessages; //"Волшебное слово" из-за чего все
     //работат как надо :)
     if k > 0 then
       exit;
     label1.caption := inttostr(i);
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   k := 1;
 end;
 
 end.
 




Циклический опрос компонентов

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


 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: integer;
 begin
   for I:= 0 to ComponentCount -1 do
     if (Components[I] IS TEdit) then
       (Components[I] AS TEdit).{Вашпараметр} := {ваше значение};
 end;
 

Если вам необходимо идентифицировать конкретный набор edit-компонентов, поместите их на панели и сделайте примерно так:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: integer;
 begin
   with MyPanel do
     for I:= 0 to ControlCount -1 do
       if (Controls[I] IS TEdit) then
         (Controls[I] AS TEdit).{Вашпараметр} := {Ваше значение};
 end;
 

В контексте примера, Edit1, Edit2 и т.д. есть то же самое, что и Edit[1], Edit[2]. Если вы хотите иметь доступ к серии элементов управления как к элементам массива, поместите их в TList.


 MyArr := TList.Create;
 MyArr.Add(Edit1);
 MyArr.Add(Edit2);
 
 ...
 
 For i := 0 To MyArr.count - 1 Do
   (MyArr.items[i] As TEdit).Enabled := False;
 
 MyArr.Free;
 
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: Integer;
 begin
   for I := 0 to ComponentCount -1 do
     if Components[I] is TEdit then
       TEdit(Components[I]).Whatever := 10;
 end;
 

Для получения доступа используйте:


 TButton(mylist.items[i]).property := sumpin;
 

или


 TButton(mylist.items[i]).method;
 

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


 Procedure TMyForm.MyButtonHandler(Sender: TObject);
 Begin
   Case (Sender As TComponent).Tag Of
     1: { что-то делаем }
     2: { делаем что-то еще }
     .
     .
   End;
 End;
 

Просто укажите в событии OnClick на MyButtonHandler для тех кнопок, в которых вы хотите использовать общий обработчик события.




Четвёртая кнопка на заголовочной полосе окна



 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ComCtrls, ExtCtrls, StdCtrls;
 
 const
   wm_BtnClk = wm_User + 111;{Определяем своё сообщение}
 
 type
   TForm1 = class(TForm)
     procedure FormDestroy(Sender: TObject);
   private
     { Private declarations }
     R: TRect;{Переменная для обозначения прямоугольной области кнопки}
     Press: Boolean;
     procedure WmNcPaint(var Msg: TWmNcPaint); message wm_NcPaint;
     procedure WMNcActivate(var msg: TwmncActivate); message wm_NcActivate;
     procedure WmNcLButtonDown( var Msg: TWMNCLBUTTONDOWN); message Wm_NCLbuttonDown;
     procedure wmnchittest(var Msg: TWMncHITTEST); message wm_NcHittest;
     procedure wmSize(var Msg: TMessage); message wm_Size;
     procedure wmncLButtonUp(var msg: TWMncLBUTTONUP); message wm_NclButtonUp;
     procedure wmLbuttonUp(var Msg: TMessage); message wm_LbuttonUp;
     procedure wmBtnClk(var msg: TMessage); message wm_BtnClk;
   public
     { Public declarations }
     procedure DrawBtn;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 { TForm1 }
 
 procedure TForm1.WmNcPaint(var Msg: TWmNcPaint);
 begin
   inherited;
   Drawbtn;{При перерисовке окна прорисовываем кнопку}
 end;
 
 procedure TForm1.DrawBtn;{Код прорисовки кнопки}
 var
   WDc: HDc;
   Cx, Cy: Integer;
   XFrame, Yframe: Integer;
 begin
   {Получаем контекст нашего окна, снимаем мерки с оконных размеров,
   вычисляем положение нашей кнопки и прорисовываем её в зависимости
   от того нажата ли кнопка мыши над ней}
   WDc := GetWindowDc(Handle);
   Cx := GetSystemMetrics(SM_CXSize);
   Cy := GetSystemMetrics(SM_CYSize);
   xFrame := GetSystemMetrics(SM_CXFrame);
   yFrame := GetSystemMetrics(SM_CYFrame);
   R := Bounds(Width - xFrame - 4*Cx + 2, yFrame + 2, Cx - 2, Cy - 4);
   if Press then
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH or DFCS_PUSHED)
   else
     DrawFrameControl(WDc,R,DFC_BUTTON,DFCS_ButtonPUSH);
   ReleaseDc(Handle,WDC);
 end;
 
 procedure TForm1.WMNcActivate(var msg: TwmncActivate);
 begin
   inherited;
   DrawBtn;
 end;
 
 procedure TForm1.WmNcLButtonDown(var Msg: TWMNCLBUTTONDOWN);
 var
   pt: TPoint;
 begin
   inherited;
   drawbtn;
   pt := Point(msg.XCursor - Left,msg.YCursor - top);
   if PtInRect(R,pt) then
   begin
     Press := True;
     drawbtn;
   end;
 end;
 
 
 procedure TForm1.wmnchittest(var Msg: TWMncHITTEST);
 var
   pt: tpoint;
 begin
   inherited;
   pt :=Point(msg.XPos - Left, msg.YPos - Top);
   if PtinRect(r,pt) then
     msg.Result := htBorder;
 end;
 
 procedure TForm1.wmSize(var Msg: TMessage);
 begin
   inherited;
   RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
 end;
 
 procedure TForm1.wmncLButtonUp(var msg: TWMncLBUTTONUP);
 var
   pt: TPoint;
 begin
   inherited;
   pt := Point(msg.XCursor - Left,msg.YCursor - top);
   if PtInRect(R,pt) then
   begin
     Press := False;
     drawbtn;
     PostMessage(Handle,wm_btnClk,0,0);
   end;
 end;
 
 procedure TForm1.wmLbuttonUp(var Msg: TMessage);
 begin
   inherited;
   if Press then
   begin
     Press := False;
     DrawBtn;
   end;
 end;
 
 procedure TForm1.wmBtnClk(var msg: TMessage);
 begin
   {Объявили константу своего сообщения,
   посылаем его своему окну при отпускании кнопки мыши над новой кнопкой,
   а здесь обрабатываем своё сообщение}
   ShowMessage('О, круто, наша кнопка нажимается! Спасибо проекту Delphi World!');
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   RedrawWindow(Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT
     or RDW_INVALIDATE);
 end;
 
 end.
 




Рисование фрактальных графов

Автор: Михаил Марковский

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.


 uses graph, crt;
 
 const
   GrafType = 1; {1..3}
 
 type
   PointPtr = ^Point;
   Point = record
     X, Y: Word;
     Angle: Real;
     Next: PointPtr
   end;
   GrfLine = array[0..5000] of
     Byte;
   ChangeType = array[1..30] of
     record
     Mean: Char;
     NewString: string
   end;
 
 var
   K, T, Dx, Dy, StepLength, GrafLength: Word;
   grDriver, Xt: Integer;
   grMode: Integer;
   ErrCode: Integer;
   CurPosition: Point;
   Descript: GrfLine;
   StartLine: string absolute Descript;
   ChangeNumber, Generation: Byte;
   Changes: ChangeType;
   AngleStep: Real;
   Mem: Pointer;
 
 procedure Replace(var Stroka: GrfLine;
   OldChar: Char;
   Repl: string);
 var
   I, J: Word;
 begin
   if (GrafLength = 0) or (Length(Repl) = 0) then
     Exit;
   I := 1;
   while I <= GrafLength do
   begin
     if Chr(Stroka[I]) = OldChar then
     begin
       for J := GrafLength downto I + 1 do
         Stroka[J + Length(Repl) - 1] := Stroka[J];
       for J := 1 to Length(Repl) do
         Stroka[I + J - 1] := Ord(Repl[J]);
       I := I + J;
       GrafLength := GrafLength + Length(Repl) - 1;
       continue
     end;
     I := I + 1
   end
 end;
 
 procedure PushCoord(var Ptr: PointPtr;
 
   C: Point);
 var
 
   P: PointPtr;
 begin
 
   New(P);
   P^.X := C.X;
   P^.Y := C.Y;
   P^.Angle := C.Angle;
   P^.Next := Ptr;
   Ptr := P
 end;
 
 procedure PopCoord(var Ptr: PointPtr;
 
   var Res: Point);
 begin
 
   if Ptr <> nil then
   begin
     Res.X := Ptr^.X;
     Res.Y := Ptr^.Y;
     Res.Angle := Ptr^.Angle;
     Ptr := Ptr^.Next
   end
 end;
 
 procedure FindGrafCoord(var Dx, Dy: Word;
 
   Angle: Real;
   StepLength: Word);
 begin
 
   Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
   Dy := Round(-Cos(Angle) * StepLength);
 end;
 
 procedure NewAngle(Way: ShortInt;
 
   var Angle: Real;
   AngleStep: Real);
 begin
 
   if Way >= 0 then
     Angle := Angle + AngleStep
   else
     Angle := Angle - AngleStep;
   if Angle >= 4 * Pi then
     Angle := Angle - 4 * Pi;
   if Angle < 0 then
     Angle := 4 * Pi + Angle
 end;
 
 procedure Rost(var Descr: GrfLine;
 
   Cn: Byte;
   Ch: ChangeType);
 var
   I: Byte;
 begin
 
   for I := 1 to Cn do
     Replace(Descr, Ch[I].Mean, Ch[I].NewString);
 end;
 
 procedure Init1;
 begin
 
   AngleStep := Pi / 8;
   StepLength := 7;
   Generation := 4;
   ChangeNumber := 1;
   CurPosition.Next := nil;
   StartLine := 'F';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'F';
     NewString := 'FF+[+F-F-F]-[-F+F+F]'
   end;
 end;
 
 procedure Init2;
 begin
 
   AngleStep := Pi / 4;
   StepLength := 3;
   Generation := 5;
   ChangeNumber := 2;
   CurPosition.Next := nil;
   StartLine := 'G';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'G';
     NewString := 'GFX[+G][-G]'
   end;
   with Changes[2] do
   begin
     Mean := 'X';
     NewString := 'X[-FFF][+FFF]FX'
   end;
 end;
 
 procedure Init3;
 begin
 
   AngleStep := Pi / 10;
   StepLength := 9;
   Generation := 5;
   ChangeNumber := 5;
   CurPosition.Next := nil;
   StartLine := 'SLFF';
   GrafLength := Length(StartLine);
   with Changes[1] do
   begin
     Mean := 'S';
     NewString := '[+++G][---G]TS'
   end;
   with Changes[2] do
   begin
     Mean := 'G';
     NewString := '+H[-G]L'
   end;
   with Changes[3] do
   begin
     Mean := 'H';
     NewString := '-G[+H]L'
   end;
   with Changes[4] do
   begin
     Mean := 'T';
     NewString := 'TL'
   end;
   with Changes[5] do
   begin
     Mean := 'L';
     NewString := '[-FFF][+FFF]F'
   end;
 end;
 
 begin
 
   case GrafType of
     1: Init1;
     2: Init2;
     3: Init3;
   else
   end;
   grDriver := detect;
   InitGraph(grDriver, grMode, '');
   ErrCode := GraphResult;
   if ErrCode <> grOk then
   begin
     WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
     Halt(1)
   end;
   with CurPosition do
   begin
     X := GetMaxX div 2;
     Y := GetMaxY;
     Angle := 0;
     MoveTo(X, Y)
   end;
   SetColor(white);
   for K := 1 to Generation do
   begin
     Rost(Descript, ChangeNumber, Changes);
     Mark(Mem);
     for T := 1 to GrafLength do
     begin
       case Chr(Descript[T]) of
         'F':
           begin
             FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
             with CurPosition do
             begin
               Xt := X + Dx;
               if Xt < 0 then
                 X := 0
               else
                 X := Xt;
               if X > GetMaxX then
                 X := GetMaxX;
               Xt := Y + Dy;
               if Xt < 0 then
                 Y := 0
               else
                 Y := Xt;
               if Y > GetMaxY then
                 Y := GetMaxY;
               LineTo(X, Y)
             end
           end;
         'f':
           begin
             FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
             with CurPosition do
             begin
               Xt := X + Dx;
               if Xt < 0 then
                 X := 0
               else
                 X := Xt;
               if X > GetMaxX then
                 X := GetMaxX;
               Xt := Y + Dy;
               if Xt < 0 then
                 Y := 0
               else
                 Y := Xt;
               if Y > GetMaxY then
                 Y := GetMaxY;
               MoveTo(X, Y)
             end
           end;
         '+': NewAngle(1, CurPosition.Angle, AngleStep);
         '-': NewAngle(-1, CurPosition.Angle, AngleStep);
         'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
         '[': PushCoord(CurPosition.Next, CurPosition);
         ']':
           begin
             PopCoord(CurPosition.Next, CurPosition);
             with CurPosition do
               MoveTo(X, Y)
           end
       end
     end;
     Dispose(Mem);
     Delay(1000)
   end;
   repeat
   until KeyPressed;
   CloseGraph
 end.
 




Управление игрой FreeCell

Гарри Каспаров наконец-то выиграл у компьютера, и с двумя очками и тремя жизнями перешёл на следующий уровень.

Если вы решили перепробовать ВСЕ номера игры FreeCell, вас можно квалифицировать как законченного маньяка. В этом случае вас, возможно, заинтересует эта маленькая программка. При ее запуске она загружает FreeCell и начинает игру, следующую за той, которую вы не смогли завершить в прошлый раз. А еще она отвечает на глупые вопросы типа "Do you really want to resign the game?". После выигрыша программа изменяет счетчик таким образом, чтобы при очередном запуске номер игры изменялся на следующий автоматически.

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


 ...
 private
   { Private declarations }
   InstHandle: Word;
   WndHandle: hWnd;
   NextGame: Word;
 
   function EnumFunc(H: HWnd): Word;
   procedure WMQUERYOPEN(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
 ...
 
 interface
 USES
   ShellApi, IniFiles;
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   H, SubH: hMenu;
   NewGameID: Word;
   FreeCellPath: string;
 begin
   with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
   try
     FreeCellPath := ReadString('FreeCell', 'Path',
       'C:\WIN32APP\FREECELL\FREECELL.EXE') + #0;
     NextGame := ReadInteger('FreeCell', 'NextGame', 1);
   finally
     Free;
   end;
   InstHandle := ShellExecute(Handle, nil, @FreeCellPath[1],
     nil, nil, SW_SHOW);
   WndHandle := 0;
   if InstHandle >= 32 then
     EnumWindows(@TForm1.EnumFunc, LongInt(Self));
   if WndHandle <> 0 then
   begin
     {Вычисляем ID пункта меню "Select Game"}
     H := GetMenu(WndHandle);
     SubH := GetSubMenu(H, 0);
     NewGameID := GetMenuItemID(SubH, 1);
     Winprocs.SetFocus(WndHandle);
     {вызываем "Select Game"}
     PostMessage(WndHandle, WM_COMMAND, NewGameID, 0);
     Timer1.Enabled := True;
   end
   else
     Close;
 end;
 
 procedure TForm1.WMQUERYOPEN(var Msg: TWMQueryOpen);
 begin
   Msg.Result := 0;
 end;
 
 function TForm1.EnumFunc(H: HWnd): Word;
 begin
 
   if GetWindowWord(H, GWW_HINSTANCE) = InstHandle then
   begin
     WndHandle := H;
     Result := 0;
   end
   else
     Result := 1;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   Buffer: array[0..10] of Char;
 
   DlgHandle: Word;
 begin
 
   {Если пользователь закрыл FreeCell, выходим!}
   if GetModuleUsage(InstHandle) = 0 then
   begin
     Close;
     Exit;
   end;
   {При необходимости укажите номер игры}
   DlgHandle := FindWindow('#32770', 'Game Number');
   if DlgHandle <> 0 then
   begin
     Str(NextGame, Buffer);
     SendDlgItemMessage(DlgHandle, $CB, WM_SETTEXT,
       0, LongInt(@Buffer));
     PostMessage(DlgHandle, WM_COMMAND, 1,
       MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED));
   end;
   {Если игра окончена, увеличиваем счетчик}
   DlgHandle := FindWindow('#32770', 'Game Over');
   if DlgHandle <> 0 then
   begin
     Inc(NextGame);
     with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
     try
       WriteInteger('FreeCell', 'NextGame', NextGame);
     finally Free;
     end;
     PostMessage(DlgHandle, WM_COMMAND, 6,
       MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED));
   end;
   {Если игра спрашивает, хотите ли вы выйти, отвечем соответственно yes или OK}
   DlgHandle := FindWindow('#32770', 'FreeCell');
   if DlgHandle <> 0 then
   begin
     if (not (GetDlgItemText(DlgHandle, 6, Buffer, 10) in [0, 10]))
       and (StrComp(Buffer, '&Yes') = 0) then
       PostMessage(DlgHandle, WM_COMMAND, 6,
         MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED))
     else if (not (GetDlgItemText(DlgHandle, 2, Buffer, 10) in [0, 10]))
       and (StrComp(Buffer, 'Cancel') = 0) then
       PostMessage(DlgHandle, WM_COMMAND, 1,
         MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED))
   end;
 end;
 




Разрушение модальной формы при деактивации


 procedure TForm1.AppDeactivate(Sender: TObject);
 var
   hw: HWnd;
   CurTask: THandle;
   WndStyle: Longint;
 begin
   CurTask := GetWindowTask(handle);
   hw := GetWindow(GetDesktopWindow, GW_CHILD);
   while GetWindowTask(hw) <> CurTask do
     hw := GetWindow(hw, GW_HWNDNEXT);
   while (hw <> handle) and (GetWindowTask(hw) = CurTask) do
   begin
     PostMessage(hw, WM_Close, 0, 0);
     hw := GetWindow(hw, GW_HWNDNEXT);
   end;
 end;
 




Как получить список доступных носителей

Автор: Олегом Кулабухов

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ld: DWORD;
   i: integer;
 begin
   ld := GetLogicalDrives;
   for i := 0 to 25 do
   begin
     if (ld and (1 shl i)) <> 0 then
       Memo1.Lines.Add(Char(Ord('A') + i) + ':\');
   end;
 end;
 




Освобождение экземпляров формы

Автор: Jeff Fisher

В нашем примере для решения задачи мы передаем конструктору переменную формы. Затем, при закрытии формы, мы сбрасываем эту переменную.

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


 TMyForm = class(TForm)
 ...
 
 private
   FormVar: ^TMyForm;
 public
   constructor Create(AOwner: TComponent; var AFormVar: TMyForm);
   destructor Destroy; override;
 end;
 
 constructor TMyForm.Create(AOwner: TComponent; var AFormVar: TMyForm);
 begin
   FormVar := @AFormVar;
   inherited Create;
   .....
 end;
 
 destructor TMyForm.Destroy;
 begin
   FormVar^ := nil;
   inherited Destroy;
 end;
 
 MyForm := TMyForm.Create(Self, MyForm);
 MyOtherForm := TMyForm.Create(Self, MyOtherForm);
 

Этот код при разрушении окна автоматически сбрасывает все, что вы передаете в AFormVar, в nil.

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




Как узнать доступные сетевые pесуpсы

Автор: Nomadic

Любовь в интернете: С тобой мечтаю поболтать до боли в пальцах...


 type
   PNetResourceArray = ^TNetResourceArray;
   TNetResourceArray =
   array [0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
 
 procedure EnumResources(LpNR:PNetResource);
 var
   NetHandle: THandle;
   BufSize: Integer;
   Size: Integer;
   NetResources: PNetResourceArray;
   Count: Integer;
   NetResult: Integer;
   I: Integer;
   NewItem: TListItem;
 begin
   if WNetOpenEnum(
   RESOURCE_GLOBALNET,
   RESOURCETYPE_ANY,
   // RESOURCETYPE_ANY - все ресурсы
   // RESOURCETYPE_DISK - диски
   // RESOURCETYPE_PRINT - принтеры
   0, LpNR, NetHandle) <> NO_ERROR then
     Exit;
   try
     BufSize := 50 * SizeOf(TNetResource);
     GetMem(NetResources, BufSize);
     try
       while True do
       begin
         Count := -1;
         Size := BufSize;
         NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
         if NetResult = ERROR_MORE_DATA then
         begin
           BufSize := Size;
           ReallocMem(NetResources, BufSize);
           Continue;
         end;
         if NetResult <> NO_ERROR then
           Exit;
         for I := 0 to Count-1 do
         begin
           with NetResources^[I] do
           begin
             if RESOURCEUSAGE_CONTAINER = (DwUsage and RESOURCEUSAGE_CONTAINER) then
               EnumResources(@NetResources^[I]);
 
             if dwDisplayType = RESOURCEDISPLAYTYPE_SHARE then
             // ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
             // RESOURCEDISPLAYTYPE_SERVER - компьютер
             // RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
             // RESOURCEDISPLAYTYPE_GENERIC - сеть
             begin
               NewItem:= Form1.ListView1.Items.Add;
               NewItem.Caption:=LpRemoteName;
             end;
           end;
         end
       end;
     finally
       FreeMem(NetResources, BufSize);
     end;
   finally
     WNetCloseEnum(NetHandle);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   OldCursor: TCursor;
 begin
   OldCursor:= Screen.Cursor;
   Screen.Cursor:= crHourGlass;
   with ListView1.Items do
   begin
     BeginUpdate;
     Clear;
     EnumResource(nil);
     EndUpdate;
   end;
   Screen.Cursor:= OldCursor;
 end;
 

Автор: Михаил Немцов

обнаружил и исправил некоторые ошибки. Его код публикуется ниже:


 type
 PNetResourceArray = ^TNetResourceArray;
 TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
 
 
 Procedure EnumResources(LpNR:PNetResource);
 Var
 NetHandle: DWORD;
 BufSize: DWORD;
 Size:DWORD;
 NetResources: PNetResourceArray;
 Count: DWORD;
 NetResult:Integer;
 I: Integer;
 NewItem:TListItem;
 Begin
 
 If WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,0,LpNR,NetHandle) <> NO_ERROR
 then Exit;
 Try
 BufSize := 50 * SizeOf(TNetResource);
 GetMem(NetResources, BufSize);
 Try
 while True do
 begin
 Count := 1;
 Size := BufSize;
 NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
 If NetResult = ERROR_MORE_DATA then
 begin
 BufSize := Size;
 ReallocMem(NetResources, BufSize);
 Continue;
 end;
 if NetResult <> NO_ERROR then Exit;
 For I := 0 to Count-1 do
 Begin
 With NetResources^[I] do
 Begin
 If RESOURCEUSAGE_CONTAINER =(DwUsage and RESOURCEUSAGE_CONTAINER) then
 EnumResources(@NetResources^[I]);
 If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
 // ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
 // RESOURCEDISPLAYTYPE_SERVER - компьютер
 // RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
 // RESOURCEDISPLAYTYPE_GENERIC - сеть
 Begin
 NewItem:= Form1.ListView1.Items.Add;
 NewItem.Caption:=LpRemoteName;
 End;
 End;
 End;
 End;
 finally
 FreeMem(NetResources, BufSize);
 end;
 finally
 WNetCloseEnum(NetHandle);
 end;
 End;
 
 procedure TForm1.Button1Click(Sender: TObject);
 Var
 
 OldCursor: TCursor;
 begin
 
 OldCursor:= Screen.Cursor;
 Screen.Cursor:= crHourGlass;
 With ListView1.Items do
 Begin
 BeginUpdate;
 Clear;
 EnumResources(nil);
 EndUpdate;
 End;
 Screen.Cursor:= OldCursor;
 end;
 
 end.
 




Освобождение записей

Для начала необходимо привести объект к нужному типу, например, так:


 var
 i: integer;
 begin
 ...
 for i := 0 to MyList.Count - 1 do
 dispose(PMyRecord(MyList[i]));
 MyList.Free;
 end;
 
 

или


 begin
 
 for i := 0 to MyList.Count - 1 do
 dispose(PMyRecord(MyList.items[i]));
 MyList.Free;
 
 end;
 

Items - свойство по умолчанию, поэтому вам нет необходимости определять это, хотя обратное не помешает.

Теперь можно заняться созданием работоспособной и полезной функцией. В форме:


 var
 p : ^mystruct;
 begin
 new(p);
 ...
 dispose(p);
 end;
 

операторы new() и dispose() в точности соответствуют процедурам getmem() и freemem(), за исключением того, что компилитор распределяет количество байт под размер структуры, на которую ссылается переменная-указатель. По этой причине указатель должен быть типизированным указателем, и следущий код неверен:


 var
 p : pointer;
 begin
 new(p);
 end;
 

, поскольку невозможно установить размер памяти, на которую должен ссылаться указатель. С другой стороны, если вы используете getmem() и freemem(), вы можете распределять байты для нетепизированного указателя, например:


 var
 p : pointer;
 begin
 getmem( p, 32767 );
 ...
 freemem( p, 32767 );
 end;
 




Как можно проверить, запущена программа с локального диска или с сетевого окружения, то есть с сети

Издевательство над сис.админом: "Заходи, гостем будешь..."


 var
   DriveType: TDriveType;
   DriveChar: string;
 begin
   DriveChar:=ExtractFileDrive(ParamStr(0));
   DriveType:=TDriveType(GetDriveType(PChar(DriveChar + '\')));
   case driveType of
     dtFixed: ShowMessage('Fixed ' + DriveChar + '\');
     dtNetWork: ShowMessage('NetWork ' + DriveChar + '\');
   end;
 end;
 




Узнать откуда была установлена Windows


Лежат в корзине OS/2 три программы и разговаривают.
Первая второй:
- Тебя за что в корзину отправили?
- За то, что я не под Windows. А тебя?
- За то, что я под Windows.
Обе третьей:
- А тебя?
- За то, что я и есть Windows.


 uses Registry;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   reg: TRegistry;
 begin
   reg := TRegistry.Create;
   with reg do
   begin
     RootKey := HKEY_LOCAL_MACHINE;
     OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP', false);
     ShowMessage(reg.ReadString('SourcePath'));
     CloseKey;
     free;
   end;
 end;
 




Присоединиться к FTP серверу и загрузить с него файл

Сидят две бабульке на скамейке, около дома и интенсивно что-то обсуждают. Идет программист... ”Какой трафик!!!” - подумал программер.


 {
   The following function shows how to connect to a ftp server
   and download a file.
   It uses the functions from wininet.dll.
 
   You need a ProgressBar to show the progress and a Label to show progress informations.
 }
 
 uses
   WinInet, ComCtrls;
 
 function FtpDownloadFile(strHost, strUser, strPwd: string;
   Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;
 
   function FmtFileSize(Size: Integer): string;
   begin
     if Size >= $F4240 then
       Result := Format('%.2f', [Size / $F4240]) + ' Mb'
     else
     if Size < 1000 then
       Result := IntToStr(Size) + ' bytes'
     else
       Result := Format('%.2f', [Size / 1000]) + ' Kb';
   end;
 
 const
   READ_BUFFERSIZE = 4096;  // or 256, 512, ... 
 var
   hNet, hFTP, hFile: HINTERNET;
   buffer: array[0..READ_BUFFERSIZE - 1] of Char;
   bufsize, dwBytesRead, fileSize: DWORD;
   sRec: TWin32FindData;
   strStatus: string;
   LocalFile: file;
   bSuccess: Boolean;
 begin
   Result := False;
 
   { Open an internet session }
   hNet := InternetOpen('Program_Name', // Agent 
                         INTERNET_OPEN_TYPE_PRECONFIG, // AccessType 
                         nil,  // ProxyName 
                         nil, // ProxyBypass 
                         0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE 
 
   {
     Agent contains the name of the application or
     entity calling the Internet functions
   }
 
 
   { See if connection handle is valid }
   if hNet = nil then
   begin
     ShowMessage('Unable to get access to WinInet.Dll');
     Exit;
   end;
 
   { Connect to the FTP Server }
   hFTP := InternetConnect(hNet, // Handle from InternetOpen 
                           PChar(strHost), // FTP server 
                           port, // (INTERNET_DEFAULT_FTP_PORT), 
                           PChar(StrUser), // username 
                           PChar(strPwd),  // password 
                           INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher? 
                           0, // flag: 0 or INTERNET_FLAG_PASSIVE 
                           0);// User defined number for callback 
 
   if hFTP = nil then
   begin
     InternetCloseHandle(hNet);
     ShowMessage(Format('Host "%s" is not available',[strHost]));
     Exit;
   end;
 
   { Change directory }
   bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));
 
   if not bSuccess then
   begin
     InternetCloseHandle(hFTP);
     InternetCloseHandle(hNet);
     ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));
     Exit;
   end;
 
   { Read size of file }
   if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
   begin
     fileSize := sRec.nFileSizeLow;
     // fileLastWritetime := sRec.lastWriteTime 
   end else
   begin
     InternetCloseHandle(hFTP);
     InternetCloseHandle(hNet);
     ShowMessage(Format('Cannot find file ',[ftpFile]));
     Exit;
   end;
 
   { Open the file }
   hFile := FtpOpenFile(hFTP, // Handle to the ftp session 
                        PChar(ftpFile), // filename 
                        GENERIC_READ, // dwAccess 
                        FTP_TRANSFER_TYPE_BINARY, // dwFlags 
                        0); // This is the context used for callbacks. 
 
   if hFile = nil then
   begin
     InternetCloseHandle(hFTP);
     InternetCloseHandle(hNet);
     Exit;
   end;
 
   { Create a new local file }
   AssignFile(LocalFile, TargetFile);
   {$i-}
   Rewrite(LocalFile, 1);
   {$i+}
 
   if IOResult <> 0 then
   begin
     InternetCloseHandle(hFile);
     InternetCloseHandle(hFTP);
     InternetCloseHandle(hNet);
     Exit;
   end;
 
   dwBytesRead := 0;
   bufsize := READ_BUFFERSIZE;
 
   while (bufsize > 0) do
   begin
     Application.ProcessMessages;
 
     if not InternetReadFile(hFile,
                             @buffer, // address of a buffer that receives the data 
                             READ_BUFFERSIZE, // number of bytes to read from the file 
                             bufsize) then Break; // receives the actual number of bytes read 
 
     if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
       BlockWrite(LocalFile, buffer, bufsize);
     dwBytesRead := dwBytesRead + bufsize;
 
     { Show Progress }
     ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
     Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);
   end;
 
   CloseFile(LocalFile);
 
   InternetCloseHandle(hFile);
   InternetCloseHandle(hFTP);
   InternetCloseHandle(hNet);
   Result := True;
 end;
 




Форма во весь экран


 {
   Make your application like a game. Full Screen.
   Disable all of the system keys.
 }
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   HTaskbar: HWND;
   OldVal: LongInt;
 begin
   try
     // Find handle of TASKBAR 
     HTaskBar := FindWindow('Shell_TrayWnd', nil);
     // Turn SYSTEM KEYS off, Only Win 95/98/ME 
     SystemParametersInfo(97, Word(True), @OldVal, 0);
     // Disable the taskbar 
     EnableWindow(HTaskBar, False);
     // Hide the taskbar 
     ShowWindow(HTaskbar, SW_HIDE);
   finally
     with Form1 do
     begin
       BorderStyle := bsNone;
       FormStyle   := fsStayOnTop;
       Left        := 0;
       Top         := 0;
       Height      := Screen.Height;
       Width       := Screen.Width;
     end;
   end
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 var
   HTaskbar: HWND;
   OldVal: LongInt;
 begin
   //Find handle of TASKBAR 
   HTaskBar := FindWindow('Shell_TrayWnd', nil);
   //Turn SYSTEM KEYS Back ON, Only Win 95/98/ME 
   SystemParametersInfo(97, Word(False), @OldVal, 0);
   //Enable the taskbar 
   EnableWindow(HTaskBar, True);
   //Show the taskbar 
   ShowWindow(HTaskbar, SW_SHOW);
 end;
 




Форма во весь экран 2


 procedure TForm1.FormShow(Sender: TObject);
 var
   r : TRect;
 begin
   SystemParametersInfo(SPI_GETWORKAREA, 0, @r,0);
   Form1.SetBounds(r.left, r.top, r.Right - r.left, r.bottom - r.top);
 end;
 




Как запустить приложение в полноэкранном режиме

Запуск приложения в полноэкранном режиме означает, что окно приложения полностью занимает рабочий стол. Это бывает необходимо для обеспечения поддержки функции акселератора видеокарты, которая может ускорить работу только полной области экрана, но не только, к примеру, если вам необходимо сделать только вашу программу видимой для пользователя. Кстати: Полноэкранный запуск в общих чертах имеет отношение не только к OpenGL, DirectX и 3D. Строго говоря полноэкранный режим требует только установки флага состояния окна wsMaximize, и все.

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

Так что полностью вопрос читается так: как запустить полноэкранное приложение в специфичном разрешении экрана и глубине цвета (без перезагрузки)? Ключевым пунктом является функция ChangeDisplaySettings. В зависимости от видеодрайвера, вы можете динамически установить один из множества режимов, не перегружая компьютер:


 function SetFullscreenMode(ModeIndex: Integer): Boolean;
 // изменение видеорежима, задаваемого 'ModeIndex'
 var
   DeviceMode: TDevMode;
 begin
   with DeviceMode do
   begin
     dmSize := SizeOf(DeviceMode);
     dmBitsPerPel := VideoModes[ModeIndex].ColorDepth;
     dmPelsWidth := VideoModes[ModeIndex].Width;
     dmPelsHeight := VideoModes[ModeIndex].Height;
     dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
     // при неудачной смене режима переходим в режим текущего разрешения
     Result := ChangeDisplaySettings(DeviceMode, CDS_FULLSCREEN) =
       DISP_CHANGE_SUCCESSFUL;
     if Result then
       ScreenModeChanged := True;
     if ModeIndex = 0 then
       ScreenModeChanged := False;
   end;
 end;
 

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


 const MaxVideoModes = 200; // это не очень актуально
 type TVideoMode = record
 Width,
 Height,
 ColorDepth  : Word;
 Description : String[20];
 end;
 var VideoModes    : array[0..MaxVideoModes] of TVideoMode;
 NumberVideomodes  : Integer = 1; // 1, поскольку есть режим по умолчанию
 

Как вы видите, это делает наш пример более функциональным для использования. При необходимомости, вы можете заменить в вышеуказанной функции VideoModes на фиксированные значения (скажем, на 640, 480, 16). Перечисление всех видеорежимов осуществляется при помощи EnumDisplaySettings:


 procedure ReadVideoModes;
 var
   I, ModeNumber: Integer;
 
   done: Boolean;
   DeviceMode: TDevMode;
   DeskDC: HDC;
 
 begin
 
   // создание режима "по умолчанию"
   with VideoModes[0] do
   try
     DeskDC := GetDC(0);
     ColorDepth := GetDeviceCaps(DeskDC, BITSPIXEL);
     Width := Screen.Width;
     Height := Screen.Height;
     Description := 'default';
   finally
     ReleaseDC(0, DeskDC);
   end;
 
   // перечисляем все доступные видеорежимы
   ModeNumber := 0;
   done := False;
   repeat
     done := not EnumDisplaySettings(nil, ModeNumber, DeviceMode);
     TryToAddToList(DeviceMode);
     Inc(ModeNumber);
   until (done or (NumberVideomodes >= MaxVideoModes));
 
   // режимы низкого разрешения не всегда перечислимы, о них запрашивают явно
   with DeviceMode do
   begin
     dmBitsPerPel := 8;
     dmPelsWidth := 42;
     dmPelsHeight := 37;
     dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
     // тест видеодрайвера: убедимся, что он справится со всеми видеорежимами
     if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <>
       DISP_CHANGE_SUCCESSFUL then
     begin
       I := 0;
       while (I < NumberLowResModes - 1) and (NumberVideoModes < MaxVideoModes)
         do
       begin
         dmSize := Sizeof(DeviceMode);
         dmBitsPerPel := LowResModes[I].ColorDepth;
         dmPelsWidth := LowResModes[I].Width;
         dmPelsHeight := LowResModes[I].Height;
         dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
         TryToAddToList(DeviceMode);
         Inc(I);
       end;
     end;
   end;
 end;
 

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


 type TLowResMode = record
 
 Width,
 Height,
 ColorDepth  : Word;
 end;
 
 const NumberLowResModes = 60;
 
 LowResModes       : array[0..NumberLowResModes-1] of TLowResMode =
 ((Width:320;Height:200;ColorDepth: 8),(Width:320;Height:200;ColorDepth:15),
 (Width:320;Height:200;ColorDepth:16),(Width:320;Height:200;ColorDepth:24),
 (Width:320;Height:200;ColorDepth:32),(Width:320;Height:240;ColorDepth: 8),
 (Width:320;Height:240;ColorDepth:15),(Width:320;Height:240;ColorDepth:16),
 (Width:320;Height:240;ColorDepth:24),(Width:320;Height:240;ColorDepth:32),
 (Width:320;Height:350;ColorDepth: 8),(Width:320;Height:350;ColorDepth:15),
 (Width:320;Height:350;ColorDepth:16),(Width:320;Height:350;ColorDepth:24),
 (Width:320;Height:350;ColorDepth:32),(Width:320;Height:400;ColorDepth: 8),
 (Width:320;Height:400;ColorDepth:15),(Width:320;Height:400;ColorDepth:16),
 (Width:320;Height:400;ColorDepth:24),(Width:320;Height:400;ColorDepth:32),
 (Width:320;Height:480;ColorDepth: 8),(Width:320;Height:480;ColorDepth:15),
 (Width:320;Height:480;ColorDepth:16),(Width:320;Height:480;ColorDepth:24),
 (Width:320;Height:480;ColorDepth:32),(Width:360;Height:200;ColorDepth: 8),
 (Width:360;Height:200;ColorDepth:15),(Width:360;Height:200;ColorDepth:16),
 (Width:360;Height:200;ColorDepth:24),(Width:360;Height:200;ColorDepth:32),
 (Width:360;Height:240;ColorDepth: 8),(Width:360;Height:240;ColorDepth:15),
 (Width:360;Height:240;ColorDepth:16),(Width:360;Height:240;ColorDepth:24),
 (Width:360;Height:240;ColorDepth:32),(Width:360;Height:350;ColorDepth: 8),
 (Width:360;Height:350;ColorDepth:15),(Width:360;Height:350;ColorDepth:16),
 (Width:360;Height:350;ColorDepth:24),(Width:360;Height:350;ColorDepth:32),
 (Width:360;Height:400;ColorDepth: 8),(Width:360;Height:400;ColorDepth:15),
 (Width:360;Height:400;ColorDepth:16),(Width:360;Height:400;ColorDepth:24),
 (Width:360;Height:400;ColorDepth:32),(Width:360;Height:480;ColorDepth: 8),
 (Width:360;Height:480;ColorDepth:15),(Width:360;Height:480;ColorDepth:16),
 (Width:360;Height:480;ColorDepth:24),(Width:360;Height:480;ColorDepth:32),
 (Width:400;Height:300;ColorDepth: 8),(Width:400;Height:300;ColorDepth:15),
 (Width:400;Height:300;ColorDepth:16),(Width:400;Height:300;ColorDepth:24),
 (Width:400;Height:300;ColorDepth:32),(Width:512;Height:384;ColorDepth: 8),
 (Width:512;Height:384;ColorDepth:15),(Width:512;Height:384;ColorDepth:16),
 (Width:512;Height:384;ColorDepth:24),(Width:512;Height:384;ColorDepth:32));
 

И остается функция TryToAddToList:


 procedure TryToAddToList(DeviceMode: TDevMode);
 // Добавление видеорежима к списку, это это не дубликат
 // и режим действительно может быть установлен.
 var
   I: Integer;
 begin
   // Смотрим на предмет дублирования видеорежима (такое может быть из-за показателя
   // частоты смены кадров или из-за того, что мы явно пробуем все режимы низкого разрешения)
   for I := 1 to NumberVideomodes - 1 do
     with DeviceMode do
       if ((dmBitsPerPel = VideoModes[I].ColorDepth) and
         (dmPelsWidth = VideoModes[I].Width) and
         (dmPelsHeight = VideoModes[I].Height)) then
         Exit; // повтор видеорежима (дубликат)
 
   // устанавливаем тестируемый режим (на самом деле мы не устанавливаем данный режим,
   // а хотим получить сообщение о его поддержке видеокартой).
   if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <>
     DISP_CHANGE_SUCCESSFUL then
     Exit;
 
   // если это новый, поддерживаемый режим, то добавляем его к списку
   with DeviceMode do
   begin
     VideoModes[NumberVideomodes].ColorDepth := dmBitsPerPel;
     VideoModes[NumberVideomodes].Width := dmPelsWidth;
     VideoModes[NumberVideomodes].Height := dmPelsHeight;
     VideoModes[NumberVideomodes].Description := Format('%d x %d, %d bpp',
       [dmPelsWidth, dmPelsHeight, dmBitsPerPel]);
   end;
   Inc(NumberVideomodes);
 end;
 

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


 procedure RestoreDefaultMode;
 // восстанавливаем видеорежим по умолчанию
 var T : TDevMode absolute 0; // маленькая хитрость: создаем указатель на ноль
 begin
 // Так как первый параметр является переменной, мы не можем использовать ноль
 // непосредственно. Взамен мы используем переменную с абсолютным адресом нуля.
 ChangeDisplaySettings(T,CDS_FULLSCREEN);
 end;
 




Передача функции как параметра

В нашем случае лучшим решением будет использование процедурного типа. Допустим, что DllFunction() на входе хочет получить определенную функцию, поясним это на примере кода:


 type
   TMyFuncType = function: integer;
 
 var
   MyFunc: TMyFuncType;
 
 function foo: integer;
 begin
   result := 1;
 end;
 
 begin
   MyFunc := foo;
   DllFunction(longint(MyFunc));
 

Вы можете это сделать и так:


 DllFunction( longint( @foo )) ;
 

Все же я не уверен в вопросах корректности использования таким образом в вызовах DLL. памяти (для меня пока неясна работа с памятью, находящейся в другом сегменте), как в этом примере, так что возможно для корректной работы вам придется объявить foo с директивой far, экспортировать ее в модуле, или что-то еще.

Также, в зависимости от того, как написана DllFunction(), вы можете в вызове подразумевать приведение типа:


 function DllFunction( p: TMyFuncType ): Integer;
 far; external 'mydll';
 

В этом случае вам не нужна будет переменная MyFunc или оператор @.

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


 unit Unit1;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 type
 
   IntFunc = function: integer;
 
 function DllFunction(iFunc: IntFunc): integer; far;
 begin
 
   DllFunction := iFunc; {Обратите внимание на то, что это вызов функции}
 end;
 
 function iFoo: integer; far;
 begin
 
   iFoo := 1;
 end;
 
 procedure TestIFunc;
 var
 
   i: integer;
 begin
 
   i := DllFunction(iFoo);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
 
   TestIFunc;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
 
   Close;
 end;
 
 end.
 

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


 i := longint(@foo)
 

Другая вещь, которую вы можете сделать - исключить работу с longint и вызывать функцию dll следующим образом:


 DLLfunction (@foo);
 

Имейте в виду, что если вы собираетесь вызывать foo из DLL, то необходимо предусмотреть вопросы совместимости, для получения дополнительной информации почитайте описание функции MakeProcInstance.




Функция для работы с палитрами и RGB

У меня трудности с пониманием операций, производимых в Delphi над палитрой. По существу, я имею 4 открытых формы, которые должны использовать цвета, которые не входят в стандрартный набор из 20 именованных цветов. Ячейки таблицы также должны использовать мои нестандартные цвета. Есть какой-либо способ обновления системной палитры для того, чтобы все формы использовали один и тот же цвет?

При работе с палитрами рекомендуется пользоваться функцией RGB. Если вы используете ее для изменения свойства "Color", Windows довольно хорошо справляется с задачай подбора цветов для низкого разрешения, а в системах с высоким разрешением вы получите точный цвет RGB. Это могло бы послужить выходом из создавшейся у вас ситуации. Вот пример формы, которая "линяет" от красного до синего:


 procedure TForm1.FormClick(Sender: TObject);
 var
   blue: Byte;
 begin
   For blue := 0 to 255 do
   Begin
     Color := RGB(255-blue,0,blue);
     Update;
   End;
 end;
 




Указатель на функцию

Это то, что я нашел при создании простой машины состояний:

Ниже приведен простой пример для Borland Delphi, использующий указатели функций для управления программным потоком. Просто создайте простую форму с единственной кнопкой и скопируйте код из Unit1 во вновь созданный модуль. Добавьте к проекту Unit2 и скомпилируйте проект. Дайте мне знать, если у вас возникнут какие-либо проблемы.


 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
   CurrProc: LongInt;
   MyVal: LongInt;
 
 implementation
 
 uses Unit2;
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   NewProc: LongInt;
   MyString: string;
 begin
 
   CurrProc := 2; { начальная точка в таблице методов }
   MyVal := 0; { вспомогательная переменная }
   NewProc := 0;
     { возвращаемое значение для следующего индекса в таблице методов }
   while CurrProc < 6 do
   begin
     { выполняем текущий индекс в таблице методов и получаем следующую процедуру }
     NewProc := ProcTable[CurrProc](MyVal);
 
     { просто показываем значения NewProc и CurrProc }
     FmtStr(MyString, 'NewProc [%d] CurrProc [%d]', [NewProc, CurrProc]);
     MessageDlg(MyString, mtInformation, [mbOK], 0);
 
     { присваиваем текущую процедуру возвращаемой процедуре }
     CurrProc := NewProc;
   end;
 
 end;
 
 end.
 


 { Это простой пример, определяющий массив указателей на функции }
 
 interface
 
 type
 
   { определяем Procs как функцию }
   Procs = function(var ProcNum: LongInt): LongInt;
 
 var
 
   { объявляем массив указателей на функции }
   ProcTable: array[1..5] of Procs;
 
   { определения интерфейсов функций }
 function Proc1(var MyVal: LongInt): LongInt; far;
 function Proc2(var MyVal: LongInt): LongInt; far;
 function Proc3(var MyVal: LongInt): LongInt; far;
 function Proc4(var MyVal: LongInt): LongInt; far;
 function Proc5(var MyVal: LongInt): LongInt; far;
 
 implementation
 
 uses Dialogs;
 
 function Proc1(var MyVal: LongInt): LongInt;
 begin
 
   MessageDlg('Процедура 1', mtInformation, [mbOK], 0);
   Proc1 := 6;
 end;
 
 function Proc2(var MyVal: LongInt): LongInt;
 begin
 
   MessageDlg('Процедура 2', mtInformation, [mbOK], 0);
   Proc2 := 3;
 end;
 
 function Proc3(var MyVal: LongInt): LongInt;
 begin
 
   MessageDlg('Процедура 3', mtInformation, [mbOK], 0);
   Proc3 := 4;
 end;
 
 function Proc4(var MyVal: LongInt): LongInt;
 begin
 
   MessageDlg('Процедура 4', mtInformation, [mbOK], 0);
   Proc4 := 5;
 end;
 
 function Proc5(var MyVal: LongInt): LongInt;
 begin
 
   MessageDlg('Процедура 5', mtInformation, [mbOK], 0);
   Proc5 := 1;
 end;
 
 initialization
 
   { инициализируем содержание массива указателей на функции }
   @ProcTable[1] := @Proc1;
   @ProcTable[2] := @Proc2;
   @ProcTable[3] := @Proc3;
   @ProcTable[4] := @Proc4;
   @ProcTable[5] := @Proc5;
 
 end.
 

Я думаю это можно сделать приблизительно так: объявите в каждой форме процедуры, обрабатывающие нажатие кнопки, типа процедуры CutButtonPressed(Sender:TObject) of Object; затем просто назначьте события кнопок OnClick этим процедурам при наступлении событий форм OnActivate. Этот способ соответствует концепции ОО-программирования, но если вам не нравится это, то вы все еще можете воспользоваться указателями функций, которая предоставляет Delphi.

Объявите базовый класс формы с объявлениями абстрактных функций для каждой функции, которую вы хотите вызывать из вашего toolbar. Затем наследуйте каждую вашу форму от базового класса формы и создайте определения этих функций.

Пример: (Здесь может встретиться пара синтаксических ошибок - я не компилил это)


 type
   TBaseForm = class(TForm)
   public
     procedure Method1; virtual; abstract;
   end;
 
 type
   TDerivedForm1 = class(TBaseForm)
   public
     procedure Method1; override;
   end;
 
   TDerivedForm2 = class(TBaseForm)
   public
     procedure Method1; override;
   end;
 
 procedure TDerivedForm1.Method1;
 begin
   ....
 end;
 
 procedure TDerivedForm2.Method1;
 begin
   ....
 end;
 
 {Для вызова функции из вашего toolbar,
 получите активную в настоящий момент форму и вызовите Method1}
 
 procedure OnButtonClick;
 var
   AForm: TBaseForm;
 begin
   AForm := ActiveForm as TBaseForm;
   AForm.Method1;
 end;
 




Указатель на функцию 2

Что лично я использую, чтобы вызвать какую-то функцию из DLL:

  1. Объявите тип:

  2.  type
     TYourDLLFunc = function(Parm1: TParm1; Parm2: TParm2): TParm3;
     

  3. Объявите переменную этого типа:

  4.  var
     YourDllFunc: TYourDLLFunc;
     

  5. Получаем дескриптор DLL:

  6.  DLLHandle := LoadLibrary('YourDLL.DLL');
     

  7. Получаем адрес функции:

  8.  @YourDLLFunc := GetProcAddress(DLLHandle, 'YourDLLFuncName');
     

  9. Для использования функции теперь используйте переменную YourDLLFunc, например:

  10.  Parm3 := YourDLLFunc(Parm1, Parm2);
     




Гауссово размывание (Gaussian Blur) в Delphi

Автор: Den is Com

Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает Adobe Photoshop. Мне кажется есть множество фильтров, которые можно переделать или оптимизировать для быстроты обработки изображений.

Ядро гауссовой функции exp(-(x^2 + y^2)) есть разновидность формулы f(x)*g(y), которая означает, что мы можем выполнить двумерную свертку, делая последовательность одномерных сверток - сначала мы свертываем каждую строчку изображения, затем - каждую колонку. Хороший повод для ускорения (N^2 становится N*2). Любая свертка требует некоторого место для временного хранения результатов - ниже в коде программа BlurRow как раз распределяет и освобождает память для каждой колонки. Вероятно это должно ускорить обработку изображения, правда не ясно насколько.

Поле "size" в записи TKernel ограничено значением 200. Фактически, если вы хотите использовать еще больший радиус, это не вызовет проблем - попробуйте со значениями radius = 3, 5 или другими. Для большого количества данных методы свертки на поверку оказываются эффективнее преобразований Фурье (как показали опыты).

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

Во всяком случае вы можете сделать так:


 unit GBlur2;
 
 interface
 
 uses Windows, Graphics;
 
 type
 
   PRGBTriple = ^TRGBTriple;
   TRGBTriple = packed record
     b: byte; //легче для использования чем типа rgbtBlue...
     g: byte;
     r: byte;
   end;
 
   PRow = ^TRow;
   TRow = array[0..1000000] of TRGBTriple;
 
   PPRows = ^TPRows;
   TPRows = array[0..1000000] of PRow;
 
 const
   MaxKernelSize = 100;
 
 type
 
   TKernelSize = 1..MaxKernelSize;
 
   TKernel = record
     Size: TKernelSize;
     Weights: array[-MaxKernelSize..MaxKernelSize] of single;
   end;
   //идея заключается в том, что при использовании TKernel мы игнорируем
   //Weights (вес), за исключением Weights в диапазоне -Size..Size.
 
 procedure GBlur(theBitmap: TBitmap; radius: double);
 
 implementation
 
 uses SysUtils;
 
 procedure MakeGaussianKernel(var K: TKernel; radius: double;
 
   MaxData, DataGranularity: double);
 //Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
 //Для текущего приложения мы устанавливаем переменные MaxData = 255,
 //DataGranularity = 1. Теперь в процедуре установим значение
 //K.Size так, что при использовании K мы будем игнорировать Weights (вес)
 //с наименее возможными значениями. (Малый размер нам на пользу,
 //поскольку время выполнения напрямую зависит от
 //значения K.Size.)
 var
   j: integer;
   temp, delta: double;
   KernelSize: TKernelSize;
 begin
 
   for j := Low(K.Weights) to High(K.Weights) do
   begin
     temp := j / radius;
     K.Weights[j] := exp(-temp * temp / 2);
   end;
 
   //делаем так, чтобы sum(Weights) = 1:
 
   temp := 0;
   for j := Low(K.Weights) to High(K.Weights) do
     temp := temp + K.Weights[j];
   for j := Low(K.Weights) to High(K.Weights) do
     K.Weights[j] := K.Weights[j] / temp;
 
   //теперь отбрасываем (или делаем отметку "игнорировать"
   //для переменной Size) данные, имеющие относительно небольшое значение -
   //это важно, в противном случае смазавание происходим с малым радиусом и
   //той области, которая "захватывается" большим радиусом...
 
   KernelSize := MaxKernelSize;
   delta := DataGranularity / (2 * MaxData);
   temp := 0;
   while (temp < delta) and (KernelSize > 1) do
   begin
     temp := temp + 2 * K.Weights[KernelSize];
     dec(KernelSize);
   end;
 
   K.Size := KernelSize;
 
   //теперь для корректности возвращаемого результата проводим ту же
   //операцию с K.Size, так, чтобы сумма всех данных была равна единице:
 
   temp := 0;
   for j := -K.Size to K.Size do
     temp := temp + K.Weights[j];
   for j := -K.Size to K.Size do
     K.Weights[j] := K.Weights[j] / temp;
 
 end;
 
 function TrimInt(Lower, Upper, theInteger: integer): integer;
 begin
 
   if (theInteger <= Upper) and (theInteger >= Lower) then
     result := theInteger
   else if theInteger > Upper then
     result := Upper
   else
     result := Lower;
 end;
 
 function TrimReal(Lower, Upper: integer; x: double): integer;
 begin
 
   if (x < upper) and (x >= lower) then
     result := trunc(x)
   else if x > Upper then
     result := Upper
   else
     result := Lower;
 end;
 
 procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
 var
   j, n, LocalRow: integer;
   tr, tg, tb: double; //tempRed и др.
 
   w: double;
 begin
 
   for j := 0 to High(theRow) do
 
   begin
     tb := 0;
     tg := 0;
     tr := 0;
     for n := -K.Size to K.Size do
     begin
       w := K.Weights[n];
 
       //TrimInt задает отступ от края строки...
 
       with theRow[TrimInt(0, High(theRow), j - n)] do
       begin
         tb := tb + w * b;
         tg := tg + w * g;
         tr := tr + w * r;
       end;
     end;
     with P[j] do
     begin
       b := TrimReal(0, 255, tb);
       g := TrimReal(0, 255, tg);
       r := TrimReal(0, 255, tr);
     end;
   end;
 
   Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
 end;
 
 procedure GBlur(theBitmap: TBitmap; radius: double);
 var
   Row, Col: integer;
   theRows: PPRows;
   K: TKernel;
   ACol: PRow;
   P: PRow;
 begin
   if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
 
     raise
       exception.Create('GBlur может работать только с 24-битными изображениями');
 
   MakeGaussianKernel(K, radius, 255, 1);
   GetMem(theRows, theBitmap.Height * SizeOf(PRow));
   GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
 
   //запись позиции данных изображения:
   for Row := 0 to theBitmap.Height - 1 do
 
     theRows[Row] := theBitmap.Scanline[Row];
 
   //размываем каждую строчку:
   P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
   for Row := 0 to theBitmap.Height - 1 do
 
     BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
 
   //теперь размываем каждую колонку
   ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
   for Col := 0 to theBitmap.Width - 1 do
   begin
     //- считываем первую колонку в TRow:
 
     for Row := 0 to theBitmap.Height - 1 do
       ACol[Row] := theRows[Row][Col];
 
     BlurRow(Slice(ACol^, theBitmap.Height), K, P);
 
     //теперь помещаем обработанный столбец на свое место в данные изображения:
 
     for Row := 0 to theBitmap.Height - 1 do
       theRows[Row][Col] := ACol[Row];
   end;
 
   FreeMem(theRows);
   FreeMem(ACol);
   ReAllocMem(P, 0);
 end;
 
 end.
 

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   b: TBitmap;
 begin
   if not openDialog1.Execute then
     exit;
 
   b := TBitmap.Create;
   b.LoadFromFile(OpenDialog1.Filename);
   b.PixelFormat := pf24Bit;
   Canvas.Draw(0, 0, b);
   GBlur(b, StrToFloat(Edit1.text));
   Canvas.Draw(b.Width, 0, b);
   b.Free;
 end;
 

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




Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки

Автор: Den is Com

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

Данный метод позволяет создавать тень у текстовых меток TLabel. Не требует лазить в Photoshop и что-то ваять там - тень рисуется динамически, поэтому и объём программы не раздувает. Создание тени присходит в фоновом режиме, во время "простоя" процессора.

Пример использования:


 ShowFade(CaptionLabel);
 //или
 ShowFadeWithParam(CaptionLabel,3,3,2,clGray);
 

Blur.pas


 unit blur;
 
 interface
 
 uses
 
   Classes, graphics, stdctrls, gblur2;
 const
   add_width = 4;
 
   add_height = 5;
 type
 
   TBlurThread = class(TThread)
   private
     { Private declarations }
     text_position: Integer;
     FadeLabel: TLabel;
     Temp_Bitmap: TBitmap;
 
     procedure ShowBlur;
     procedure SetSize;
   protected
     F_width, F_X, F_Y: Integer;
     F_color: TColor;
     procedure Execute; override;
   public
 
     constructor Create(Sender: TLabel; Fade_width: integer; Fade_X: Integer;
       Fade_Y: Integer; Fade_color: TColor);
     destructor Destroy;
 
   end;
 procedure ShowFade(Sender: TLabel);
 procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
   Integer; Fade_Y: Integer; Fade_color: TColor);
 
 implementation
 
 procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
   Integer; Fade_Y: Integer; Fade_color: TColor);
 var
   SlowThread: TBlurThread;
 begin
   SlowThread := TBlurThread.Create(Sender, Fade_width, Fade_X, Fade_Y,
     Fade_color);
   SlowThread.Priority := tpIdle;
   SlowThread.Resume;
 end;
 
 procedure ShowFade;
 var
   SlowThread: TBlurThread;
 begin
   SlowThread := TBlurThread.Create(Sender, 3, 3, 3, clBlack);
   SlowThread.Priority := tpIdle;
   //SlowThread.Priority:=tpLowest;
   //SlowThread.Priority:=tpTimeCritical;
   SlowThread.Resume;
 end;
 
 constructor TBlurThread.Create(Sender: TLabel; Fade_width: integer; Fade_X:
   Integer; Fade_Y: Integer; Fade_color: TColor);
 begin
   Temp_Bitmap := TBitmap.Create;
   Temp_Bitmap.Canvas.Font := Sender.Font;
   FadeLabel := Sender;
   F_width := Fade_width;
   F_X := Fade_X;
   F_Y := Fade_Y;
   F_color := Fade_color;
   inherited Create(True);
 end;
 
 destructor TBlurThread.Destroy;
 begin
   Temp_Bitmap.Free;
   inherited Destroy;
 end;
 
 procedure TBlurThread.ShowBlur;
 begin
   FadeLabel.Canvas.Draw(text_position + F_X, F_Y, Temp_Bitmap);
   FadeLabel.Canvas.TextOut(text_position, 0, FadeLabel.Caption);
 end;
 
 procedure TBlurThread.SetSize;
 begin
   if FadeLabel.Width < (Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
     + F_X {add_width}) then
   begin
     FadeLabel.Width := Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
       + F_X {add_width};
     FadeLabel.Tag := 2;
   end
   else
     FadeLabel.Tag := 0;
 
   if FadeLabel.Height < (Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
     F_width + F_Y {add_height}) then
   begin
     FadeLabel.Height := Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
       F_width + F_Y {add_height};
     FadeLabel.Tag := 1;
   end
   else if FadeLabel.Tag <> 2 then
     FadeLabel.Tag := 0;
 
 end;
 
 { TBlurThread }
 
 procedure TBlurThread.Execute;
 begin
 
   { Place thread code here }
   Synchronize(SetSize);
 
   if FadeLabel.Tag = 0 then
   begin
     Temp_Bitmap.Width := FadeLabel.Width;
     Temp_Bitmap.Height := FadeLabel.Height;
     Temp_Bitmap.Canvas.Brush.Color := FadeLabel.Color;
     Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect);
     Temp_Bitmap.Canvas.Font.Color := F_color; //clBlack
 
     if FadeLabel.Alignment = taRightJustify then
       text_position := FadeLabel.Width -
         Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X {add_width}
     else if FadeLabel.Alignment = taCenter then
       text_position := (FadeLabel.Width -
         Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X
         {add_width}) div 2
     else
       text_position := 0;
 
     Temp_Bitmap.Canvas.TextOut(0, 0, FadeLabel.Caption);
     Temp_Bitmap.PixelFormat := pf24Bit;
     GBlur(Temp_Bitmap, F_width);
     //Temp_Bitmap.SaveToFile('a.bmp');
     Synchronize(ShowBlur);
   end;
 
 end;
 
 end.
 




GDI - графика в Delphi

Автор: Alistair Keys

Жаргон GDI.

GDI расшифровывается как Graphics Device Interface, и представляет собой интерфейс, который Windows использует для рисования 2D графики. Также это самый медленный способ отображения графики из существующих, однако самый простой для понимания основ. Итак, для начала, поговорим об основных понятиях и терминах в GDI.

Начнём с того, что GDI обычно не используют для создания крутых графических эффектов, для этого есть DirectX, OpenGL, или любые графические библиотеки (такие как: DelphiX, FastLib, DIBUltra, Graphics32...). Однако, для создание простых эффектов с минимальными усилиями GDI вполне сгодится.

С GDI тесно связана ещё одна аббревиатура - DC ("Device Context" - контекст устройства). Это то, на чём мы рисуем, и в Delphi контекст устройства представлен как TCanvas. Идея контекста устройства заключается в том, что это универсальное устройство вывода, поэтому можно использовать одинаковые функции как для экрана, так и для принтера.

Все графические функции в Delphi являются надстройками над стандартными GDI функциями Windows. Позже мы поговорим об этих функциях.

А теперь самое время приступить к рассмотрению того, как устроен GDI. Ниже, в таблице, представлены некоторые важные классы:

ИМЯ ОПИСАНИЕ
Pen Используется для рисования простых линий. Обычно применяется для функции LineTo или при рисовании рамки для определённой фигуры (например для функции Rectangle).
Brush Кисть используется для заполнения области определённым цветом. Применяется в функциях Rectangle, FillRect или FloodFill.
Font Используется для задания шрифта, которым будет нарисован текст. Можно указать имя шрифта, размер и т.д.
Region Позволяет задать регион (замкнутое пространство). Регионом может быть круг, квадрат или произвольная фигура. Позволяет так же делать дырки в фигурах.

Однако, пора переходить от слов к делу, а именно, начать рисовать линии и фигуры.

Рисование линий

Сперва необходимо чётко уяснить, что координата (0,0) это верхний левый угол экрана. То есть значения по оси y увеличиваются вниз экрана. Соответственно, координата (0, 50) означает, что мы просто отступили на 50 пикселей от верха экрана.

Самое главное, что надо знать при рисовании линий и фигур, это различие между пером (Pen) и кистью (Brush). Всё очень просто: перо (Pen) используется при рисовании линий или рамок, а кисть (Brush) для заполнения фигуры.

Ниже приведены две функции, которые используются для рисования линий и обе принадлежат TCanvas:

ИМЯ ОПИСАНИЕ ПРИМЕР
MoveTo Перемещает точку начала рисования линии в указанные координаты x и y Canvas.MoveTo(50, 100);
LineTo Рисует линию начиная с текущей позиции (см. MoveTo) до указанных координат x и y. Canvas.LineTo(50, 100);

Эффект перемещения точки начала рисования линии так же достигается при помощи установки своства PenPos в канвасе... например, "Canvas.PenPos.x := 20;", "Canvas.PenPos.y := 50", или "Canvas.PenPos := Point(20,50);".

По умолчанию, точка начала рисования установлена в (0,0), то есть, если сразу вызвать "Canvas.LineTo(100,100);" то будет нарисована линия из точки (0,0) в точку (100, 100). Точка начала рисования автоматически переместится в (100, 100), то есть, если выполнить команду "Canvas.LineTo(200, 100);", то следующая линия будет нарисована из точки (100, 100) в (200, 100). Поэтому, если мы хотим рисовать линии несоединённые друг с другом, то придётся воспользоваться методом MoveTo.

Линия, нарисованная при помощи LineTo использует текущее перо канваса (типа TPen). Основные свойства пера, это ширина - "Canvas.Pen.Width := 4;" (при помощи которого можно задавать различную ширину линий), и цвет "Canvas.Pen.Color := clLime;".

Взглянем на простой пример беспорядочного рисования разноцветных линий:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // инициализируем генератор
   // случайных чисел
   Randomize;
 end;
 
 const
   NUM_LINES = 2000;
 
 procedure TForm1.DrawLines;
 var
   i: Integer;
 begin
   for i := 0 to NUM_LINES - 1 do
   begin
     Canvas.Pen.Color :=
       RGB(Random(256),
       Random(256),
       Random(256));
     Canvas.LineTo
       (Random(ClientWidth),
       Random(ClientHeight));
   end;
 end;
 

Процедура DrawLines вызывается из обработчика кнопки OnClick. Количество линий задаётся в константе NUM_LINES. Между прочим, функция RGB, составляет цвет каждой линии из трёх основных составляющих: красного, зелёного и синего (значения от 0 до 255) и возвращает нам цвет в виде TColor. О цветах поговорим немного позже, а вот так выглядит нарисованный пейзаж:

Теперь, когда линии нарисованы, попробуйте немножко подвигать форму. Если форму переместить за края экрана, то Вы увидите, что линии частично стёрлись. Это не глюк, и решается эта проблема очень просто. Но не сейчас ;-). Сперва посмотрим, как рисовать различные фигуры.

Рисование фигур

Для рисования фигур, в TCanvas предусмотрены следующие функции:

ИМЯ ОПИСАНИЕ ПРИМЕР
Ellipse Рисует элипс, вписанный в невидимый квадрат с координатами верхнего левого угла и правого нижнего. Если координаты х и y у углов будут совпадать, то получится круг. Canvas.Ellipse(0,0,50,50);
FillRect Заполняет прямоугольник цветом текущей кисти (brush), но никак не за пределами него. Canvas.FillRect( Bounds(0,0,100,100));
FloodFill Заполняет данную область цветом текущей кисти, до тех пор пока не будет достигнут край. Canvas.FloodFill(10, 10, clBlack, fsBorder);
Rectangle Рисует прямоугольник (или квадрат), заполненный цветом текущей кисти и обрамлённый цветом текущего пера Canvas.Rectangle( Bounds(20, 20, 50, 50));
RoundRect Тоже, что и Rectangle, но с загруглёнными углами. Canvas.RoundRect( 20, 20, 50, 50, 3, 3);

Ещё есть очень нужная функция TextOut, которая позволяет рисовать текст, используя шрифт, заданный в канвасе:

ИМЯ ОПИСАНИЕ ПРИМЕР
TextOut Рисует данную строку на канвасе начиная с координат (x,y) - фон текста заполняется текущим цветом кисти. Canvas.TextOut(10, 10, 'Some text');

Кстати, функция позволяет рисовать текст, не заполняя его фон. Если Вам необходимо изменить шрифт, используемый в TextOut, то необходимо изменить свойство Font канваса (это свойство имеет тип TFont) - например "Canvas.Font.Name := 'Verdana';", "Canvas.Font.Size := 24;" или "Canvas.Font.Color := clRed;".

Вкратце хотелось бы обратить Ваше внимание на довольно полезный класс TRect, который умеет хранить в себе значения лево, право, верха и низа (кстати, в Windows API это RECT). То ест, достаточно указать левую и верхнюю координату и ширину и высоту области, а TRect автоматически подставит в виде (лево, верх, лево + ширина, верх + высота). Ещё есть другая функция Rect(), которая делает тоже самое, но координаты в ней задаются напрямую как лево, право, верх и низ. Ну и по желанию, можно использовать API функцию SetRect.

Ниже представлен пример, который рисует случайным образом различные фигуры:


 const
   NUM_SHAPES = 200;
 
 procedure TForm1.DrawShapes;
 var
   i, ShapeLeft, ShapeTop: Integer;
 begin
   for i := 0 to NUM_SHAPES - 1 do
   begin
     Canvas.Brush.Color :=
       RGB(Random(256),
       Random(256),
       Random(256));
     ShapeLeft := Random(ClientWidth);
     ShapeTop := Random(ClientHeight);
     // теперь, случайным образом, решаем что рисовать
     case Random(3) of
       0: Canvas.Rectangle(ShapeLeft,
           ShapeTop,
           ShapeLeft + Random(50),
           ShapeTop + Random(50));
       1: Canvas.Ellipse(ShapeLeft,
           ShapeTop,
           ShapeLeft + Random(50),
           ShapeTop + Random(50));
       2:
         begin
           Canvas.Font.Size := 10 + Random(7); // от 10 до 16
           Canvas.TextOut(ShapeLeft, ShapeTop, 'Some text');
         end;
     end;
   end;
 end;
 

Как Вы уже успели заметить, некоторые фигурки имеют цвет рамки, отличающийся от того цвета, которым заполнена фигура. Это как раз тот момент, о котором я упоминал выше. Кистью мы заполняем объекты, а пером обрамляем. Если цвет кисти (brush) меняется случайным образом, то цвет пера(pen) остаётся постоянным. Из-за этого и получается такая картина.

Перерисовка окна

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

Рисование, это то, что мы делали выше. То есть, рисовали любые линии и графические фигуры. Однако, рисунок сохранялся до тех пор, пока окно(форма) не было обновлено.

Перерисовка несколько отличается от понятия "рисование". Когда окну необходимо перерисоваться, то Windows посылает определённое сообщение. Это сообщение поступает в обработчик события "OnPaint". Любой код, который поместить в обработчик OnPaint будет вызван каждый раз, когда форме необходимо обновиться.

Для примера, поместите следующий код в проект:


 procedure TForm1.DrawSomeText;
 begin
   Canvas.TextOut(10, 10, 'Some text');
 end;
 

Если поместить на форму кнопку и вызывать DrawSomeText из обработчика кнопки OnClick, то проблема с исчезновением текста при перемещении формы останется. ОДНАКО, если вызвать DrawSomeText из обработчика формы OnPaint, то текст останется на своём месте окончательно.

Дескрипторы, или как пользоваться аналогичными API функциями

Итак, мы научились рисовать линии, различные фигуры, научились делать так, чтобы наше творение не стиралось при перемещении формы, и проделали мы всё это при помощи стандартных функций VCL (таких как Canvas.TextOut и т.д.). Однако, что делать, если Вы не хотите пользоваться графическими функциями VCL, которые всего навсего являются надстройками над аналогичными функциями из Windows API? Пожалуйста! Никто нам не запрещает пользоваться API функциями напрямую! Но постойте-ка, все они требуют какого-то HDC! Что такое HDC?

Почти всё в Windows использует "Дескриптор" (Handle). Дескриптор, это способ идентификации Вашего объекта в системе. У каждого окна есть свой дескриптор, у каждой кнопки тоже есть свой дескриптор и т.д. Именно поэтому все наши объекты имеют дескриптор в качестве свойства - например, "MyForm.Canvas.Handle".

Тип HDC это Дескриптор(Handle) Контекста Устройства (Device Context). Я уже говорил в самом начале, что TCanvas включает в себя большинство функций DC. Поэтому, мы спокойно можем подставлять свойство канваса Handle везде, где нам это потребуется.

Ради интереса можно взглянуть на таблицу, в которой представлены примеры вызовов некоторых функций из VCL и их аналогов из Windows API.

VCL WINDOWS API
Canvas.TextOut(x,y,myString); TextOut(Canvas.Handle, x, y, PChar(myString), Length(String));
Canvas.FloodFill(X, Y, Color,fsBorder); ExtFloodFill(Canvas.Handle, x, y, YourColour, FLOODFILLBORDER);
Canvas.LineTo(x,y); LineTo(Canvas.Handle, x, y);
Canvas.MoveTo(x,y); MoveToEx(Canvas.Handle, x, y, nil);

Так же можно использовать разные дескрипторы, чтобы рисовать в разных местах. Например, можно использовать "SomeBmp.Canvas.Handle" для рисования на картинке (битмапе), либо "Form1.Canvas.Handle", чтобы рисовать на форме.

В API версии функции TextOut необходимо передавать строку завершённую нулём. Это значит, что вместо того, чтобы передать строку в функцию напрямую, необходимо передать её как PChar. Так же не забывайте передавать в функцию длину строки. Для этого можно воспользоваться функцией Length.

Ну что, Вам уже захотелось поместить на форму какую-нибудь красивую картинку ?

Что такое Битмапы (Bitmaps)?

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

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

Битмапы можно рисовать не только на форме, но и по всему экрану. Может это и может показаться немного странным, но иногда это бывает полезно, особенно при создании скринсейвера. Однако, сначала нам необходимо разобраться с тем, как работать с битмапами. Вот небольшой пример:


 procedure Form1.DrawBitmap(const Filename: string; const x, y: Integer);
 var
   Bmp: TBitmap;
 begin
   // Сперва убедимся, что файл существует!
   if not FileExists(Filename) then
   begin
     ShowMessage('The bitmap ' + Filename + ' was not found!');
     Exit;
   end;
 
   Bmp := TBitmap.Create;
   try
     Bmp.LoadFromFile(Filename);
     Canvas.Draw(x, y, Bmp);
   finally
     Bmp.Free;
   end;
 end;
 

Эта функция пытается загрузить и показать картинку, (с именем Filename, например 'myBitmap.bmp') начиная с точки (x,y).

Сразу скажу, что эта функция довольно неэффективна. Она создаёт и уничтожает битмап каждый раз когда вызывается, а так же каждый раз проверяет существование файла. Лучше объявлять объект TBitmap как часть формы, создавать и загружать картинку в FormCreate, а освобождать её в FormDestroy.

Функции рисования в GDI

TCanvas имеет несколько полезных функций, которые работают с типом TGraphic. Тип TGraphic является базовым классом для графических объектов в Delphi, таких как: битмапы (TBitmap), иконки (TIcon), метафайлы (TMetafile) и JPEG-и (TJPEGImage). Все они используют одни и те же функции, которые приведены в таблице:

Все эти функции являются методами TCanvas.

ИМЯ ОПИСАНИЕ ПРИМЕР ИСПОЛЬЗОВАНИЯ
Draw Рисует TGraphic на канвасе так как он есть, не растягивая. Canvas.Draw(5,10,MyGraphic);
StrechDraw Рисует TGraphic на канвасе, подгоняя (растягивая) его под заданную область. Canvas.StretchDraw( Bounds(0,0,32,32), MyGraphic);
CopyRect Копирует часть TCanvas-а в другой, при необходимости растягивая его. Canvas.CopyRect( Bounds(0,0,32,32), MyBmp.Canvas, Bounds(0, 0, 640, 480));

TCanvas.Draw является обёрткой для API функции BitBlt:


 function BitBlt(
   hdcDest: HDC; // дескриптор конечного контекста устройства
   nXDest, // коорд. x верхнего левого угла конечного прямоугольника
   nYDest, // коорд. y верхнего левого угла конечного прямоугольника
   nWidth, // ширина конечного прямоугольника
   nHeight: Integer; // высота конечного прямоугольника
   hdcSrc: HDC; // дескриптор исходного контекста устройства
   nXSrc, // коорд. x верхнего левого угла исходного прямоугольника
   nYSrc: Integer; // коорд. y верхнего левого угла исходного прямоугольника
   dwRop: DWORD // код растровой операции
   ): Boolean;
 

Описанный выше способ позволяет рисовать битмап в run-time. Конечно, проще поместить на форму TImage и установить в ней картинку. Изображение будет постоянно оставаться на том месте, где Вы его поместили, но это скучно ;-). Куда интереснее сделать при помощи битмапов анимацию.

С другой стороны, поняв принципы работы с битмапами, Вам будет легче перейти к другим графическим библиотекам (например DirectX).

Продолжение следует ...




Генерация звукого сигнала на встроенном динамике


 procedure Sound(Frequency, Duration: Integer);
 asm
    push edx
    push eax
    mov eax, Win32Platform
    cmp eax, VER_PLATFORM_WIN32_NT
    jne @@9X
    call Windows.Beep
    ret
 @@9X:
    pop eax
    pop edx
    push ebx
    push edx
    mov bx, ax
    mov ax, 34DDh
    mov dx, 0012h
    cmp dx, bx
    jnc @@2
    div bx
    mov bx, ax
    in al, 61h
    test al, 3
    jnz @@1
    or al, 3
    out 61h, al
    mov al, 0B6h
    out 43h, al
 @@1:
    mov al, bl
    out 42h, al
    mov al, bh
    out 42h, al
    call Windows.Sleep
    in al, 61h
    and al, 0FCh
    out 61h, al
    jmp @@3
 @@2:
    pop edx
 @@3:
    pop ebx
 end;
 




Создание уникального ID для новой записи

Американская школа для одаренных детей, 1970 год, урок информатики...
- А теперь, детки, какие програмки вы бы хотели написать, когда подрастете? Вот ты, Питер?
- Я бы написал такую крутую утилитку, которая бы быстро так лечила бы винчестер от ошибок!
- Молодец, Питер! А ты, Юджин?
- А я бы сделал такую программу, которая бы быстро и без глюков сжимала файлы!
- Умница, Юджин! А ты, Билли, чего молчишь?
- Ну, ничего-ничего!... Будет вам всем быстро, будет вам без глюков...

Существует несколько способов задавать в таблице уникальный ID.

  1. Вы можете использовать поле с автоприращением

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

  2. Вы можете использовать ID-таблицу

    Если у вас имеется приложение, где нескольким таблицам необходимы уникальные ID, создайте ID-таблицу с двумя полями:

    Table Name A (первичный ключ)
     Last Id N
    В методе BeforePost таблицы, которой необходим уникальный ID, делайте примерно так:

  3.  TableBeforePost(Sender: TObject)
     var
       Id: Integer;
     begin
       with TTable(Sender) do
       begin
         {проверяем, существует ли ID для этой записи}
         if Field[0].AsInteger = 0 then
         begin
           {ищем имя таблицы в ID-Таблице}
           IDTable.FindKey[Name]
             {извлекаем последний Id - подразумеваем блокировку записи}
           Id := IDTable.FieldByName['Last Id'].AsInteger;
           Inc(Id);
           {записываем новый Id в ID-таблицу - подразумеваем разблокировку таблицы}
           IDTable.FieldByName['Last Id'].AsInteger := Id;
           IDTable.Post;
           {записываем извлеченный ID в вашу таблицу}
           Field[0].AsInteger := Id;
         end;
       end;
     end;
     

    Если вы поместите этот код в обработчик события таблицы BeforePost, вы убедитесь в том, что все ID будут последовательными (без "дырок"). Недостаток: если пользовать во время попытки добавления новой записи вдруг передумает, вы будете иметь запись с заполненным только полем ID.

    В случае, если вы решили воспользоваться данным способом (последовательные ID), поместите приведенный выше код в обработчик события таблицы OnNewRecord.

  4. Вы можете использовать ID-файл

    Используйте те же принципы, что и в предыдущем способе, но вместо ID-таблицы используется ID-Файл. Это дает преимущество за счет более высокой скорости работы, но в многопользовательской среде вы должны сами заботиться о блокировке записей.




Как сгенерировать случайный пароль

Автор: Kurt Mueller

Чем хакер отличается от юзера? Хакер подбирает пароль с третьего раза, а юзер набирает с пятого.

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

Пароль создаётся из символов, содержащихся в таблице.

Внимание:

Длина пароля должна быть меньше, чем длина таблицы!

Запускаем генератор случайных чисел (только при старте приложения).


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Randomize;
 end;
 

Описываем функцию:


 function RandomPwd(PWLen: integer): string;
 // таблица символов, используемых в пароле
 const StrTable: string =
   '!#$%&/()=?@<>|{[]}\*~+#;:.-_' +
     'ABCDEFGHIJKLMabcdefghijklm' +
     '0123456789' +
     'ДЦЬдцьЯ' +
     'NOPQRSTUVWXYZnopqrstuvwxyz';
 var
   N, K, X, Y: integer;
 begin
   // проверяем максимальную длину пароля
   if (PWlen > Length(StrTable)) then
     K := Length(StrTable)-1
   else
     K := PWLen;
   SetLength(result, K);              // устанавливаем длину конечной строки
   Y := Length(StrTable);             // Длина Таблицы для внутреннего цикла
   N := 0;                            // начальное значение цикла
 
   while N < K do                     // цикл для создания K символов
   begin
     X := Random(Y) + 1;              // берём следующий случайный символ
     // проверяем присутствие этого символа в конечной строке
     if (pos(StrTable[X], result) = 0) then
     begin
       inc(N);                        // символ не найден
       Result[N] := StrTable[X];      // теперь его сохраняем
     end;
   end;
 end;
 

Ну и обработчик нажатия кнопки будет выглядеть так:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   cPwd: string;
 begin
   // вызываем функцию генерации пароля из 30 символов
   cPwd := RandomPwd(30);
   // ...
 end;
 




Генератор SQL-запросов Insert, Update

Приходит один программист к другому:
- Слышь, Петя, мне генератор случайных чисел нужен.
- Четырнадцать!

Вам ещё не надоело динамически генерировать SQL запросы insert и update ? Давайте посмотрим, как можно раз и навсегда упростить этот процесс.

Допустим Вы создавали запрос следующим образом (типы параметров Data1:string Data2: integer Data3:TdateTime)


 SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' +
 QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date(' +
 QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ',' +
 QuotedStr('dd/mm/yyyy') + '))';
 {Ужасно! ещё хуже, когда количество колонок увеличивается}
 

А если сделать функцию типа:


 SqlCmd := SqlInsert([Data1, Data2, Variant(Data3)],
 'MyTable', ['Field1','Field2','Field3']);
 

она эмулирует строку запроса наподобие:


 insert into MyTable(Fields1, Field2, Field3)
 values ('Sweets', 934, to_date('21/05/2001', 'dd/mm/yyyy'))
 

неправда ли она более проста в использовании ?

Здесь представлены функции SqlInsert и SqlUpdate. Вы наверное заметили, что я передаю TDateTime приведённый как Variant. Причина кроется в том, что VType в array of const не имеете TDateTime типа и даты просто представлены как vtExtended.

Функция SqlInsert имеет 2 переопределённых вызова, которые позволяют Вам включить или выполнить массив имён колонок.

Посмотрим, как выглядят эти функции:


 interface
 
 const
   // Возврат и перевод каретки
   CrLf = #13#10;
 
 // Прототипы функций
 
 function SqlInsert(Values : array of const;
 TableName : string; ColNames : array of string) : string; overload;
 
 function SqlInsert(Values : array of const;
 TableName : string) : string; overload;
 
 function SqlUpdate(Values : array of const; TableName : string;
 ColNames : array of string; WhereClause : string) : string;
 
 implementation
 
 // Помещаем TDateTime в Values (array of const)
 // Представлен как Variant
 
 function SqlInsert(Values : array of const;
 TableName : string; ColNames : array of string) : string;
 var
   RetVar : string;
   i : integer;
 begin
   RetVar := 'insert into ' + TableName + CrLf + '(' + ColNames[0];
   for i := 1 to High(ColNames) do
     RetVar := RetVar + ',' + ColNames[i];
   RetVar := RetVar + ')' + CrLf;
 
   RetVar := RetVar + 'values (';
 
   for i := 0 to High(Values) do
   begin
     case Values[i].VType of
       vtInteger, vtInt64 :
         RetVar := RetVar + IntToStr(Values[i].VInteger);
       vtChar :
         RetVar := RetVar + QuotedStr(Values[i].VChar);
       vtString :
         RetVar := RetVar + QuotedStr(Values[i].VString^);
       vtPChar :
         RetVar := RetVar + QuotedStr(Values[i].VPChar);
       vtExtended :
         RetVar := RetVar + FloatToStr(Values[i].VExtended^);
       vtAnsiString :
         RetVar := RetVar + QuotedStr(string(Values[i].VAnsiString));
       // TDateTime - иначе получаем как vtExtended
       vtVariant :
         RetVar := RetVar + 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
         TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
       else
         RetVar := RetVar + '??????';
     end;
 
     RetVar := RetVar + ',';
   end;
 
   Delete(RetVar,length(RetVar),1);
   RetVar := RetVar + ')';
   if High(Values) < High(ColNames) then
     ShowMessage('SQL Insert - Not enough values.');
   if High(Values) > High(ColNames) then
     ShowMessage('SQL Insert - Too many values.');
 
   Result := RetVar;
 end;
 
 
 function SqlInsert(Values : array of const;
 TableName : string) : string; overload;
 var
   RetVar : string;
   i : integer;
 begin
   RetVar := 'insert into ' + TableName + CrLf;
   RetVar := RetVar + 'values (';
 
   for i := 0 to High(Values) do
   begin
     case Values[i].VType of
     vtInteger, vtInt64 :
       RetVar := RetVar + IntToStr(Values[i].VInteger);
     vtChar :
       RetVar := RetVar + QuotedStr(Values[i].VChar);
     vtString :
       RetVar := RetVar + QuotedStr(Values[i].VString^);
     vtPChar :
       RetVar := RetVar + QuotedStr(Values[i].VPChar);
     vtExtended :
       RetVar := RetVar + FloatToStr(Values[i].VExtended^);
     vtAnsiString :
       RetVar := RetVar + QuotedStr(string(Values[i].VAnsiString));
     // TDateTime - иначе получаем как vtExtended
     vtVariant :
       RetVar := RetVar + 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
       TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
     else
       RetVar := RetVar + '??????';
     end;
     RetVar := RetVar + ',';
   end;
 
   Delete(RetVar,length(RetVar),1);
   RetVar := RetVar + ')';
 
   Result := RetVar;
 end;
 
 
 function SqlUpdate(Values : array of const; TableName : string;
 ColNames : array of string; WhereClause : string) : string;
 var
   RetVar, Parm : string;
   i : integer;
 begin
   RetVar := 'update ' + TableName + ' set' + CrLf;
 
   for i := 0 to Min(High(Values),High(ColNames)) do
   begin
     case Values[i].VType of
       vtInteger, vtInt64 :
         Parm := IntToStr(Values[i].VInteger);
       vtChar :
         Parm := QuotedStr(Values[i].VChar);
       vtString :
         Parm := QuotedStr(Values[i].VString^);
       vtPChar :
         Parm := QuotedStr(Values[i].VPChar);
       vtExtended :
         Parm := FloatToStr(Values[i].VExtended^);
       vtAnsiString :
         Parm := QuotedStr(string(Values[i].VAnsiString));
       // TDateTime - иначе получаем как vtExtended
       vtVariant : Parm := 'to_date(' + QuotedStr(FormatdateTime('dd/mm/yyyy',
         TDateTime(Values[i].VVariant^))) + ',' + QuotedStr('dd/mm/yyyy') + ')';
       else
         Parm := '??????';
     end;
 
     RetVar := RetVar + ColNames[i] + '=' + Parm + ',';
   end;
 
   Delete(RetVar,length(RetVar),1);
   RetVar := RetVar + CrLf + 'where ' + WhereClause;
   if High(Values) < High(ColNames) then
     ShowMessage('SQL Update - Not enough values.');
   if High(Values) > High(ColNames) then
     ShowMessage('SQL Update - Too many values.');
 
   Result := RetVar;
 end;
 




Узнать существущие имена таблиц БД Access


 procedure....
 var
   x: TStrings;
 begin
   x:=TstringList.Create;
   ADOConnection.GetTableNames(x, false или true) // <- почитай Help
   операции с x...
   x.Free;
 end;
 




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

Что дyмают о pyсских пpогpаммистах их западные коллеги.
1. Рyсские пpогpаммисты никогда не читают pyководств и pедко пользyются online подсказкой - они легко понимают новые пpогpаммы, потомy как pанее yже испpобовали все пpогpаммы подобного pода.
2. Рyсские пpгpаммисты никогда не платят за софт. Они или кpэкают его, или покyпают wonderful CD за 5 баксов с кyчей софта. В любом кpyпном гоpоде России.
3. Рyсские пpогpаммисты всегда использyют самые последние pазpаботки в пpогpаммном обеспечении - самые последние веpсии лyчших пpогpамм - потомy как не надо за них платить.
4. Рyсские пpогpаммисты очень любят поэкспеpиментиpовать с железом. Они pазбеpyт Ваш компьютеp и собеpyт его обpатно в течение нескольких минyт. Они помнят yстановки джампеpов на большинстве матеpинских плат, винтах и дpyгих yстpойствах. Они никогда не забывают какие пpеpывания и адpеса памяти использyются в настоящее вpемя в их компьютеpе.
5. Рyсские пpогpаммисты апгpейдят свой компьютеp до тех поp, пока не останется никаких свободных пpеpываний, места для добавочной памяти или не останется ни одного свободного слота. Если они не могyт апгpейдить дальше свой компьютеp, они покyпают еще один и соединяют оба сеткой.
6. Рyсские пpогpаммисты пpогpаммиpyют на всех ypовнях, и на пpоцессоpных кодах тоже, таблицы котоpых y них всегда находятся на pабочем столе. Они помнят назyбок список фyнкций пpеpывания 21h.
7. Рyсские пpогpаммисты помнят всю pаскладкy английской и pyсской клавиатypы. Вы можете спpосить посpеди ночи, какая клавиша находится междy А и L, и бyдете yдивлены ответом: "Какyю из семи назвать?"
8. Рyсские пpогpаммисты ненавидят Майкpософт и Майкpософтовские пpогpаммы, но использyют их.
9. Рyсские пpогpаммисты пpедпочитают Borland, а Microsoft компилятоpы инсталлиpyют только из-за того, что в них хоpоший help для Windows API.
10. Рyсские пpогpаммисты в Интеpнете чyвствyют себя очень комфоpтно. Они пpедпочитают всегда быть online, хотя бы потомy, что может сpочно что-то понадобиться.
11. Рyсские пpогpаммисты всегда в настpоении пpогpаммиpовать.
12. Есть два вида Рyсских пpогpаммистов - пеpвые ненавидят Windows и пpогpаммиpyют под Unix, втоpые ненавидят Windows и пpогpаммиpyют под них. Макинтошевские пpогpаммисты - не настоящие пpогpаммисты - им больше подходит название - "юзеpы".
13. Рyсские пpгpаммисты не любят "кодиpовать" чью-то дpyгyю идею. Каждая пpогpамма пишется пеpсонально.
14. Рyсские пpогpаммисты всегда имеют копии Doom, Duke Nukem и Quake на их жестком диске. Они могyт игpать ночи напpолет по сетке в Deathmath.
15. Рyсские пpгpаммисты никогда не использyют джойстик. Клавиатypа - вот главное оpyжие.
16. Рyсские пpогpаммисты никогда не сдаются. Они могyт вылавливать баги из их пpогpаммы, забыв о сне и еде.
17. Жены Рyсских пpогpаммистов несчастны, потомy как им не yделяется внимания, пока в доме есть хоть один компьютеp.
18. Рyсским пpогpаммистам недоплачивают. Hо и не сyществyет сyммы в миpе, способной yспокоить их желания.
19. Hачальники не любят Рyсских пpгpаммистов. А кто любит yмника, котоpый все знает?
20. Рyсские пpогpаммисты не любят использовать шаблоны. Их пpогpаммы - это индивидyально написанные пpоизведения с большой долей импpовизации. Пpичем, Рyсский пpогаммист стаpается во всю, чтобы побыстpее запyстить пpогpаммy и yвидеть ее в pаботе.


 uses
   Psapi, tlhelp32;
 
 procedure CreateWin9xProcessList(List: TstringList);
 var
   hSnapShot: THandle;
   ProcInfo: TProcessEntry32;
 begin
   if List = nil then Exit;
   hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
   if (hSnapShot <> THandle(-1)) then
   begin
     ProcInfo.dwSize := SizeOf(ProcInfo);
     if (Process32First(hSnapshot, ProcInfo)) then
     begin
       List.Add(ProcInfo.szExeFile);
       while (Process32Next(hSnapShot, ProcInfo)) do
         List.Add(ProcInfo.szExeFile);
     end;
     CloseHandle(hSnapShot);
   end;
 end;
 
 procedure CreateWinNTProcessList(List: TstringList);
 var
   PIDArray: array [0..1023] of DWORD;
   cb: DWORD;
   I: Integer;
   ProcCount: Integer;
   hMod: HMODULE;
   hProcess: THandle;
   ModuleName: array [0..300] of Char;
 begin
   if List = nil then Exit;
   EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
   ProcCount := cb div SizeOf(DWORD);
   for I := 0 to ProcCount - 1 do
   begin
     hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
       PROCESS_VM_READ,
       False,
       PIDArray[I]);
     if (hProcess <> 0) then
     begin
       EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
       GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
       List.Add(ModuleName);
       CloseHandle(hProcess);
     end;
   end;
 end;
 
 procedure GetProcessList(var List: TstringList);
 var
   ovi: TOSVersionInfo;
 begin
   if List = nil then Exit;
   ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
   GetVersionEx(ovi);
   case ovi.dwPlatformId of
     VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
     VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
   end
 end;
 
 function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
 var
   i: Integer;
   MyProcList: TstringList;
 begin
   MyProcList := TStringList.Create;
   try
     GetProcessList(MyProcList);
     Result := False;
     if MyProcList = nil then Exit;
     for i := 0 to MyProcList.Count - 1 do
     begin
       if not bFullpath then
       begin
         if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then
           Result := True
       end
       else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True;
       if Result then Break;
     end;
   finally
     MyProcList.Free;
   end;
 end;
 
 
 // Example 1: Is a Exe-File running ? 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if EXE_Running('Notepad.exe', False) then
     ShowMessage('EXE is running')
   else
     ShowMessage('EXE is not running');
 end;
 
 
 // Example 2: List running Exe-Files 
 procedure TForm1.Button3Click(Sender: TObject);
 var
   i: Integer;
   MyProcList: TstringList;
 begin
   MyProcList := TStringList.Create;
   try
     GetProcessList(MyProcList);
     if MyProcList = nil then Exit;
     for i := 0 to MyProcList.Count - 1 do
       ListBox1.Items.Add(MyProcList.Strings[i]);
   finally
     MyProcList.Free;
   end;
 end;
 




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



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



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


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