Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;  
var  
  I: Integer;  
  Dlg: TSaveDialog;  
  ASCIIFile: TextFile;  
  Res: Boolean;  
begin  
  if Active then  
    if (FieldCount > 0) and (RecordCount > 0) then  
      begin  
        Dlg := TSaveDialog.Create(Application);  
        Dlg.FileName := FASCIIFileName;  
        Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';  
        Dlg.Options := Dlg.Options+[ofPathMustExist,   
          ofOverwritePrompt, ofHideReadOnly];  
        Dlg.Title := 'Экспоритровать данные в ASCII-файл';  
        try  
          Res := Dlg.Execute;  
          if Res then  
            FASCIIFileName := Dlg.FileName;  
        finally  
          Dlg.Free;  
        end;  
        if Res then  
          begin  
            AssignFile(ASCIIFile, FASCIIFileName);  
            Rewrite(ASCIIFile);  
            First;  
            if FASCIIFieldNames then  
              begin  
                for I := 0 to FieldCount-1 do  
                  begin  
                    Write(ASCIIFile, Fields[I].FieldName);  
                    if I <> FieldCount-1 then  
                     Write(ASCIIFile, FASCIISeparator);  
                  end;  
                Write(ASCIIFile, #13#10);  
              end;  
            while not EOF do  
              begin  
                for I := 0 to FieldCount-1 do  
                  begin  
                    Write(ASCIIFile, Fields[I].Text);  
                    if I <> FieldCount-1 then  
                      Write(ASCIIFile, FASCIISeparator);  
                  end;  
                Next;  
                if not EOF then  
                 Write(ASCIIFile, #13#10);  
              end;  
            CloseFile(ASCIIFile);  
            if IOResult <> 0 then  
              MessageDlg('Ошибка при создании или переписывании '+  
                'в ASCII-файл', mtError, [mbOK], 0);  
          end;  
      end  
    else  
      MessageDlg('Нет данных для экспортирования.',  
        mtInformation, [mbOK], 0)  
  else  
    MessageDlg('Таблица должна быть открытой, чтобы данные '+  
      'можно было экспортировать в ASCII-формат.', mtError,  
      [mbOK], 0);  
end;  

Учимся ставить ограничения

В этом уроке я покажу вам 2 способа поставить временное ограничение на работу программы.

Способ №1 Более интересный.

Первое что нам нужно сделать это кинуть на форму 2 компонента label с закладки Standart и один компонент timer с закладки system.
Объявляем переменные: для реализации данного способа нам понадобиться две глобальные переменные:

Opentime
Closetime тип у них будет tDateTime
В общем если кто не понял то после ключевого слова var пишем вот такую строчку:

closetime, opentime: tdatetime;  

Идем дальше, теперь создаем обработчик событий на форме OnCreate - для этого просто кликаем на форме 2 раза
между begin end пишем следующий код:

opentime:= time; //Функция time выдает нам время в данный момент  
closetime:= opentime+strtotime('00:00:30');  
//Здесь мы добавляем к времени старта нужное время.  
//В данном случае - в формате чч:мм:сс  
label1.Caption:=timetostr(opentime);  

С формой разобрались, переходим к таймеру также создаем обработчик событий на нем OnTime
Между begin end; пишем:

if time > closetime then //Если текущее время > времени окончания //программы то  
begin  
showmessage('Время работы программы истекло ! '); //Показываем //сообщение  
close; //закрываем программу  
end;  
Label2.Caption:=timetostr(opentime-closetime); // иначе показываем время //до завершения программы  

Вот в принципе и все, осталось только выставить true в свойстве Enabled у таймера.

Способ №2 Более простой.

Кидаем на форму компонент timer с закладки system. Свойство Enabled выставляем на true. Свойство Interval ставим равное 30000 (через 30 сек программа закроется).
Создаем обработчик событий Ontime в нем прописываем следующий код

showmessage('Время работы программы истекло ! ');  
close;  

Вот и все!

Учимся увеличивать часть экрана под курсором

В этом уроке я хочу вам рассказать, как в Delphi увеличить определённую область экрана в районе курсора мышки. Ну что запускаем Delphi, нам понадобиться: Image с закладки Additional, TackBar (Win32), Timer (System) кидаем эти компоненты на форму. Теперь давайте установим свойство min компонента trackbar равным 1, а свойство interval компонента Timer также сделаем равным 1. Все основные действия происходят в Timer'е поэтому создаем обработчик событий OnTime именно на нем. Ниже приведен код данного события.

Delphi увеличиваем часто экрана исходник

procedure tform1.timer1timer(sender: tobject);  
var  
srect,drect,posforme :trect;  
iwidth,iheight,dmx,dmy:integer;  
itmpx,itmpy :real;  
c :tcanvas;  
kursor :tpoint;  
  
begin  
if not isiconic(application.handle) then  
begin // Получаем координаты курсора  
getcursorpos(kursor);  
  
// posform представляет прямоугольник с  
// координатами form (image control).  
posforme:=rect(form1.left,  
form1.top,  
form1.left+form1.width,  
form1.top+form1.height);  
//Показываем magnified screen  
//если курсор за пределами формы.  
if not ptinrect(posforme,kursor) then begin  
// Далее код можно использовать для увеличения выбранной  
// части экрана.  
iwidth:=image1.width;  
iheight:=image1.height;  
drect:=bounds(0,0,iwidth,iheight);  
itmpx:=iwidth / (trackbar1.position * 4);  
itmpy:=iheight / (trackbar1.position * 4);  
srect:=rect(kursor.x,kursor.y,kursor.x,kursor.y);  
inflaterect(srect,round(itmpx),round(itmpy));  
//Получаем обработчик(handle) окна рабочего стола.  
c:=tcanvas.create;  
try  
c.handle:=getdc(getdesktopwindow);  
//Передаём часть изображения окна в tImage.  
image1.canvas.copyrect(drect,c,srect);  
finally  
c.free;  
end;  
end;  
// Обязательно обрабатываем все сообщения windows.  
application.processmessages;  
end;  
end;   

Как видите все просто. А теперь попробуйте сами ументшить часть экрана над которой находиться курсор. Слабо))

Пирамидальная сортировка

Алгоритм пирамидальной сортировки (heapsort) — один из самых быстрых алгоритмов сортировки.

Program heapsort;   
   
{$APPTYPE CONSOLE}   
   
type   
  tkey = integer;   
  int = integer;   
   
const N = 10;     
   
var a,b : array [0..N+1] of tkey;   
   
function parent(x : int) : int;   
begin   
  result:=x shr 1;   
end;   
   
function left(x : int) : int;   
begin   
  result := x shl 1;   
  if result > a[0] then result := N+1;   
end;   
   
function right(x:int):int;   
begin   
  result := x shl 1 + 1;   
  if result > a[0] then result := N+1;   
end;   
   
procedure swap(i,j : int);   
var temp : tkey;   
begin   
  temp := a[i];   
  a[i] := a[j];   
  a[j] := temp;   
end;   
   
procedure moveup(x : int);   
begin   
  while (a[x] > a[parent(x)]) and (parent(x) > 0)  do begin   
    swap(x, parent(x));   
    x := parent(x);   
  end;   
end;   
   
procedure movedown(x : int);   
var max : integer;   
begin   
  if a[left(x)] > a[right(x)] then max := left(x)   
  else max := right(x);   
  while (a[max] > a[x]) and (max <= a[0]) do begin   
    swap(max, x);   
    x := max;   
    if a[left(x)] > a[right(x)] then max := left(x)   
    else max := right(x);   
  end;   
end;   
   
   
procedure update(x : int; k : tkey);   
begin   
  a[x] := k;   
  moveup(x);   
  movedown(x);   
end;   
   
procedure add(k : tkey);   
begin   
  inc(a[0]);   
  update(a[0], k);   
end;   
   
procedure delete(x : int);   
begin   
  swap(x, a[0]);   
  dec(a[0]);   
  update(x, a[x]);   
end;   
   
procedure hsort;   
var i:int;   
begin   
  a[0] := 1;   
  a[1] := b[1];   
  for i := 2 to N do   
    add(b[i]);   
  for i := 1 to N do   
    delete(1);   
end;   
   
var i : int;   
   
begin   
  randomize;   
  fillchar(a, sizeof(a), 0);   
  fillchar(b, sizeof(b), 0);     
   
  for i := 1 to N do   
    b[i] := random(10);   
   
  writeln('Non-sorted elements');   
  for i := 1 to N do   
    write(b[i], ' ');   
  writeln;   
   
  hsort;   
   
  writeln('Sorted elements');   
  for i := 1 to N do   
    write(a[i], ' ');   
  readln;   
end.  

Многострочная подсказка (Hints)

unit MHint;  
  
interface  
  
uses  
  SysUtils, WinTypes, WinProcs, Messages,  
  Classes, Graphics, Controls, Forms, Dialogs;  
    
type  
  TMHint = class(TComponent)  
  private  
    ScreenSize: Integer;  
    FActive: Boolean;  
    FSeparator: Char;  
    FOnShowHint: TShowHintEvent;  
  protected  
    procedure SetActive(Value: Boolean);  
    procedure SetSeparator(Value: char);  
    procedure NewHintInfo(var HintStr: string;   
      var CanShow: Boolean;  
      var HintInfo: THintInfo);  
  public  
    constructor Create(AOwner: TComponent); override;  
  published  
    property Active: Boolean  
      read FActive write SetActive;  
    property Separator: Char  
      read FSeparator write SetSeparator;  
  end;  
  
procedure Register;  
  
implementation  
  
constructor TMHint.Create(AOwner: TComponent);  
  
begin  
  inherited Create(AOwner);  
  FActive := True;  
  FSeparator := '@';  
  Application.OnShowHint := NewHintInfo;  
  ScreenSize := GetSystemMetrics(SM_CYSCREEN);  
end;  
  
procedure TMHint.SetActive(Value: Boolean);  
begin  
  FActive := Value;  
end;  
  
procedure TMHint.SetSeparator(Value: Char);  
begin  
  FSeparator := Value;  
end;  
  
procedure TMHint.NewHintInfo(var HintStr: string;   
  var CanShow: Boolean;  
  var HintInfo: THintInfo);  
var   
  I: Byte;  
begin  
  if FActive then  
   begin  
      I := Pos(FSeparator, HintStr);  
      while I > 0 do  
        begin  
          HintStr[I] := #13;  
          I := Pos(FSeparator, HintStr);  
        end;  
      if HintInfo.HintPos.Y+10 > ScreenSize then  
        HintInfo.HintPos.Y := ScreenSize-11;  
    end;  
end;  
  
procedure Register;  
begin  
  RegisterComponents('MyComponents', [TMHint]);  
end;  
end. 

Изучаем ассемблер в Delphi

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

Основное направление статьи, это познакомиться с использованием ассемблера в Object Pascal. Однако, не будем пропускать и те аспекты программирования, которые будут требовать пояснения для конкретных примеров, приведённых в этой статье.

Использование Ассемблера в Борландовком Delphi
Перед тем, как начать, хотелось бы определиться с уровнем знаний, необходимых для нормального усвоения данного материала. Необходимо быть знакомым со встроенными средствами отладки в Delphi. Так же необходимо иметь представление о таких терминах как тип реализации (instantiation), null pointer и распределение памяти. Если в чём-то из вышеупомянутого Вы сомневаетесь, то постарайтесь быть очень внимательны и осторожны при воплощении данного материала на практике. Кроме того, будет обсуждаться только 32-битный код, так что понадобится компилятор не ниже Delphi 2.0.

Зачем использовать Ассемблер?
На мой взгляд, Object Pascal, это инструмент, позволяющий генерировать быстрый и эффективный код, однако использование ассемблера в некоторых случаях позволяет решать некоторые задачи более эффективно. За всю работу с Delphi, я пришёл к выводу, что использование низкоуровневого кода необходимо в двух случая.

(1) Обработка большого количества данных. Nb. В данный случай не входит ситуация, когда используется язык запроса данных.

(2) В высокоскоростных подпрограммах работы с дисплеем. Nb. Имеется ввиду использование простых процедур на чистом паскале, но никак не внешних библиотек и DirectX.

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

Что такое Ассемблер?
Надеюсь, что Все читатели этой статьи имеют как минимум поверхностное представление о работе процессора. Грубо говоря, это калькулятор с большим объёмом памяти. Память, это не более чем упорядоченная последовательнось двоичных цифр. Каждая такая цифра является байтом. Каждый байт может содержать в себе значение от 0 до 255, а так же имеет свой уникальный адрес, при помощи которого процессор находит нужные значения в памяти. Процессор так же имеет набор регистров (это можно расценить как глобальные переменные). Например eax,ebx,ecx и edx, это универсальные 32-битные регистры. Это значит, что самое большое число, которое мы можем записать в регистр eax, это 2 в степени 32 минус 1, или 4294967295.

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

05/0a/00/00/00
Однако, такая запись абсолютно не читабельна и, как следствие, не пригодна при отладке программы. Так вот Ассемблер, это простое представление машинных команд в более удобном виде. Теперь давайте посмотрим, как будет выглядеть прибавление 10 к eax в ассемблерном представлении:

add eax,10 {a := a + 10}

А вот так выглядит вычитаение значения ebx из eax

sub eax,ebx {a := a - b }

Чтобы сохранить значние, можно просто поместить его в другой регистр

mov eax,ecx {a := c }

или даже лучше, сохранить значение по определённому адресу в памяти

mov [1536],eax {сохраняет значение eax по адресу 1536}

и конечно же взять его от туда

mov eax,[1536]

Однако, тут есть важный момент, про который забывать не желательно. Так как регистр 32-битный(4 байта), то его значение будет записано сразу в четыре ячейки памяти 1536, 1537, 1538 и 1539.

А теперь давайте посмотрим, как компилятор преобразует действия с переменными в машинный код. Допустим у нас есть строка

Count := 0;

Для компилятора это означает, что надо просто запомнить значение. Следовательно, компилятор генерирует код, который сохраняет значение в памяти по определённому адресу и следит, чтобы не произошло никаких накладок, и обзывает этот адрес как 'Count'. Вот как выглядит такой код

mov eax,0 
mov Count,eax

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

mov Count,0

из-за того, что как минимум один параметр инструкции должен являться регистром.
Если посмотреть на строку

Count := Count + 1;

то её ассемблерное представление будет выглядеть как

mov eax,Count
add eax,1
mov Count,eax

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

Итак, рассмотрим первый пример. Сразу извинюсь за тривиальность, но с чего-то надо начинать.

function Sum(X,Y:integer):integer;   
begin   
 Result := X+Y;   
end; 

А вот так будет выглядеть оперция сложения двух целых чисел на ассемблере:

function Sum(X,Y:integer):integer;   
begin   
 asm  
  mov eax,X  
  add eax,Y  
  mov Result,eax  
 end;  
end;  

Этот код прекрасно работает, однако он не даёт нам преимущества в скорости, а так же потерялось восприятие кода. Но не стоит огорчаться, так как те немногие знания, которые Вы почерпнули из этого материала, можно использовать с большей пользой. Допустим, нам необходимо преобразовать явные значения Red,Green, и Blue в цвета типа TColor, подходящие для использования в Delphi. Тип TColor описан как 24-битный True Colour хранящийся в формате целого числа, то есть четыре байта, старший из которых равен нулю, а далее по порядку красный, зелёный, синий.

function GetColour(Red,Green,Blue:integer):TColor;   
begin   
 asm  
{ecx будет содержать значение TColor}  
  mov ecx,0   
{начинаем с красной компоненты}  
  mov eax,Red   
{необходимо убедиться, что красный находится в диапазоне 0<=Red<=255}  
  and eax,255   
{сдвигаем значение красного в правильное положение}  
  shl eax,16   
{выравниваем значение TColor}  
  xor ecx,eax   
{проделываем тоже самое с зелёным}  
  mov eax,Green   
  and eax,255  
  shl eax,8  
  xor ecx,eax  
{и тоже самое с синим}  
  mov eax,Blue   
  and eax,255  
  xor ecx,eax  
  mov Result, ecx  
 end;  
end;  

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

Изменяем миниатюру программы в Windows 7

Многим пользователям давно известно, что в операционных системах Windows Vista и Windows 7 при наведении курсора мышки на приложение в панели задач, вылетает окно с миниатюрой (мини-видом) этой программы (рис.1). Нашей сегодняшней задачей будет изменить эту картинку, подставив туда своё произвольное изображение.

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

procedure TForm1.FormCreate(Sender: TObject);  
var  
DEnable: DWORD;  
bmp: TBItmap;  
begin  
DEnable:= DWMNCRP_ENABLED;  
If S_OK <>  
DwmSetWindowAttribute(Handle,DWMWA_FORCE_ICONIC_REPRESENTATION,  
@DEnable,SizeOf(DEnable));  
then MessageBox(0,’Error’,0,0);  
  
If S_OK <>  
DwmSetWindowAttribute(Handle,DWMWA_HAS_ICONIC_BITMAP,  
@DEnable,SizeOf(DEnable));  
then MessageBox(0,’Error’,0,0);  
  
Bmp:= TBitmap.Create;  
Bmp.LoadFromFile('полный путь к нужной картинке');  
If S_OK <>  
DwmSetIconicThumbnail(Handle,Bmp.Handle,0);  
then MessageBox(0,’Error’,0,0);  
end;  

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

Функция DwmSetWindowAttribute

1-ый параметр, это ссылка на идентификатор окна (иначе хэндл).
2-ой параметр задаёт атрибуты для изменения
3-ий это служебный параметр, им может быть определенная переменная - всё зависит от атрибута.
4-ый задаёт размер служебного параметра.

Функция DwmSetIconicThumbnail

1-ый - параметр её отвечает за идентификатор нашей формы.
2-ой - ссылка на HBitmap.
3-ый в нём задаются параметры экрана, или можно выставить 0 чтобы не морочить голову.

Внимание !
Для тех, у кого стоит версия ниже Delphi 2009 – и операционная система Windows 7 Необходимо перед ключевым словом implementation после описания класса дописать импортируемые функции:

function DwmSetWindowAttribute(hwnd: HWND; dwAttribute: DWORD;  
pvAttribute: Pointer; cbAttribute: DWORD): HResult; stdcall; external 'dwmapi.dll';  
  
function DwmSetIconicThumbnail(hwnd: HWND; hbmp: HBITMAP;  
dwSITFlags: DWORD): HResult; stdcall; external 'dwmapi.dll';   

Изменение стандартной формы

Вас наверное часто удивляла форма окна, которая появляется при загрузке Norton Utilites и других подобных программ. Она имела не прямоугольный размер и ВЫ задавались вопросом : как получить такую форму? / Хотя я подозреваю, что это обычный Bitmap/ Оказывается сделать это довольно просто. При этом Ваша форма может иметь самые замысловатые очертания т.к. все это задается с помощью полигона.

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

SetWindowRgn(Handle, R, True);  

Handle - указатель на форму, вид которой хотим поменять
R - указатель на регион
ТТретий параметр - флаг, при значении TRUE сразу после установки перерисовка
Для установки R смотрите функцию CreatePolygonRgn . В примере я задал в качестве региона простой треугольник, но при большей изобретательности можно создавать очень интересные варианты. Например форму-круг или эллипс.

Прозрачная форма
ППриведу простой пример, как можно использовать данную форму. Допустим Вам надо сделать программу- напоминалку. Висит эта форма и на ней постоянно отображаются Ваши встречи, дела, праздники или другая полезная информация. Получится этакий Activ Desctop :) Но будет он жрать ресурсов на порядки меньше.Реализуется все это очень просто. Переписываем конструктор:

constructor TForm1.Create(AOwner: TComponent);  
begin  
  inherited;  
  HorzScrollBar.Visible:= False;  // убираем сколлбары, чтобы не мешались  
  VertScrollBar.Visible:= False;  // при изменении размеров формы  
  RebuildWindowRgn;               // строим новый регион  
end;  

А вот процедура "перестройки" региона формы:

procedure TForm1.RebuildWindowRgn;  
var  
  FullRgn, Rgn: THandle;  
  ClientX, ClientY, I: Integer;  
begin  
  // определяем относительные координаты клиентской части  
  ClientX:= (Width - ClientWidth) div 2;  
  ClientY:= Height - ClientHeight - ClientX;  
  FullRgn:= CreateRectRgn(0, 0, Width, Height); // создаем регион для всей формы  
  // создаем регион для клиентской части формы и вычитаем его из FullRgn  
  Rgn:= CreateRectRgn(ClientX, ClientY, ClientX + ClientWidth,  
                      ClientY +ClientHeight);  
  CombineRgn(FullRgn, FullRgn, Rgn, rgn_Diff);  
  // теперь добавляем к FullRgn регионы каждого контрольного элемента  
  for I:= 0 to ControlCount -1 do  
    with Controls[I] do begin  
      Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left +Width,  
                          ClientY + Top + Height);  
      CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or);  
    end;  
    SetWindowRgn(Handle, FullRgn, True);  // устанавливаем новый регион окна  
end;  

И самый последний штрих. Если Ваша форма, будет с изменяемыми размерами, то Вам надо добавить:

procedure TForm1.Resize;  
begin  
  inherited;  
  RebuildWindowRgn;               // строим новый регион  
end;  

Перемещение формы
Еще один штрих - произвольное перемещение формы, а не за Title Bar. Так сделано в программе WinAmp. Пишем всего одну процедуру:

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);  
begin  
inherited; // вызов унаследованного обработчика  
if M.Result = htClient then // Мышь сидит на окне? Если да  
M.Result := htCaption; // - то пусть Windows думает, что мышь на caption bar  
end; 

Защита формы паролем

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

Теперь непосредственно займемся разработкой формы запроса пароля. Хотя разрабатывать нам ничего и не надо: самый простой вариант такой формы Delphi поставляет. Вам надо выбрать пункт меню File -> New, в открывшемся диалоговом окне выберите закладку Dialogs, щелкните на значке Password Dialog и нажмите Ok. На экране появится готовая форма запроса пароля с именем PasswordDlg.

На этой форме будут две кнопки Ok и Cancel, текстовое поле ввода пароля с именем Password, метка Label1 с надписью Enter Password. Заменим свойство Caption метки Label1 на более приятное русскому глазу 'Введите пароль'. Также поменяем свойство Caption и для самой формы на 'Запрос пароля', например.

Обратите внимание на свойство PasswordChar поля ввода Edit равно * (звездочке) - это означает, что при вводе все символы будут заменены на звездочки.

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

PasswordDlg.ShowModal;  

Этот код запустит нашу форму запроса пароля (PasswordDlg) перед основной. И сделает недоступной основную форму, до закрытия формы запроса пароля. Теперь запустите программу, компилятор спросит Вас хотите ли Вы добавить в Uses, модуль второй формы, конечно же надо ответить, что хотите!

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

Для этого напишем обработчик для события OnCloseQuery для формы запроса. Здесь мы будем сравнивать содержимое строки ввода пароля с нашей константой, которую объявим в этом же обработчике. Таким образом получается такой код:

procedure TPasswordDlg.FormCloseQuery(Sender: TObject;  
var CanClose: Boolean);  
const pass=`велкам`; //наш пароль  
begin  
if Password.Text = pass then CanClose:=true  
else Application.Terminate;  
end;  

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

if Password.Text = pass then CanClose:=true  

надо заменить на:

if lowerCase(Password.Text) = lowerCase(pass) then CanClose:=true 

Теперь попробуем защитить форму паролем, который будет храниться в зашифрованном виде. Зашифруем пароль самым простым способом - Xor. Для этого напишем свою функцию:

function TPasswordDlg.xortext(text:string):string;  
var key, longkey : string;  
i : integer;  
toto: char;  
begin  
key:=`da`; //ключ  
for i := 0 to (length(text) div length(key)) do  
longkey := longkey + key;  
for i := 1 to length(text) do begin  
toto := chr((ord(text[i]) XOR ord(longkey[i])));  
result := result + toto;  
end;  
end; 

Через свое имя функция будет возвращать зашифрованную строку переданную в параметре Text. Не забудьте объявить эту функцию в разделе Public:

public  
{ public declarations }  
function xortext(text:string):string;  

Теперь поменяем обработчик события OnCloseQuery, описанный в первом пример, на такой:

procedure TPasswordDlg.FormCloseQuery(Sender: TObject;  
var CanClose: Boolean);  
var pass:string;  
begin  
pass:=xortext('велкам');  
  
if xortext(Password.Text) = pass then CanClose:=true  
else Application.Terminate;  
end;  

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

Защита программ и данных с использованием электронных ключей

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

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

unit MainMAC;  
    interface  
    uses  
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, NB30, ExtCtrls;  
    type  
    TGetMACForm = class(TForm)  
       Timer1: TTimer;  
       Timer2: TTimer;  
       procedure FormCreate(Sender: TObject);  
       procedure Timer1Timer(Sender: TObject);  
       procedure Timer2Timer(Sender: TObject);  
       procedure FormClose(Sender: TObject; var Action: TCloseAction);  
    private  
       { Private declarations }  
        procedure Test;  
    public  
       { Public declarations }  
    end;  
       var  
       GetMACForm: TGetMACForm;  
        i:String;  
        N,NP: ^String;  
        Nl,d:Integer;  
        Ln:TStringList;  
    Const N1='0';  
    Const N2='5';  
    Const N3='2';  
    Const N4='1';  
    Const N5='A';  
    Const N6='B';  
    Const N7='-';  
    Const N8='C';  
    implementation  
       {$R *.DFM}  
    type  
      TNBLanaResources = (lrAlloc, lrFree);  
    type  
      PMACAddress = ^TMACAddress;  
      TMACAddress = array[0..5] of Byte;  
    function GetLanaEnum(LanaEnum: PLanaEnum): Byte;  
     var  
       LanaEnumNCB: PNCB;  
     begin  
       New(LanaEnumNCB);  
       ZeroMemory(LanaEnumNCB, SizeOf(TNCB));  
       try  
        with LanaEnumNCB^ do  
          begin  
          ncb_buffer := PChar(LanaEnum);  
          ncb_length := SizeOf(TLanaEnum);  
          ncb_command := Char(NCBENUM);  
          NetBios(LanaEnumNCB);  
          Result := Byte(ncb_cmd_cplt);  
          end;  
       finally  
          Dispose(LanaEnumNCB);  
          end;  
     end;  
    procedure TGetMACForm.FormCreate(Sender: TObject);  
     var  
       LanaEnum: PLanaEnum;  
       I: Integer;  
     begin  
      New(N);  
      New(Np);  
     N^:=N1+N1+N7+N1+N1+N7+N3+N4+N7+N8+N2+N7+N5+N4+N7+N1+N6 ;  
      Ln := TStringList.Create;  
      New(LanaEnum);  
      ZeroMemory(LanaEnum, SizeOf(TLanaEnum));  
        try  
         if GetLanaEnum(LanaEnum) = NRC_GOODRET then  
           begin  
            with Ln do  
               begin  
               Clear;  
               BeginUpdate;  
               nl:= Byte(LanaEnum.length) - 1;  
               for I := 0 to Byte(LanaEnum.length) - 1 do  
                      Add(IntToStr(Byte(LanaEnum.lana[I])));  
               EndUpdate ;  
               end;  
            end;  
       finally  
         Dispose(LanaEnum);  
        end;  
      Test ;  
     end;  
    function ResetLana(LanaNum, ReqSessions, ReqNames: Byte;  
     LanaRes: TNBLanaResources): Byte;  
     var  
       ResetNCB: PNCB;  
     begin  
      New(ResetNCB);  
      ZeroMemory(ResetNCB, SizeOf(TNCB));  
      try  
       with ResetNCB^ do  
         begin  
         ncb_lana_num := Char(LanaNum); // Set Lana_Num  
         ncb_lsn := Char(LanaRes); // Allocation of new resources  
         ncb_callname[0] := Char(ReqSessions); // Query of max sessions  
         ncb_callname[1] := #0; // Query of max NCBs (default)  
         ncb_callname[2] := Char(ReqNames); // Query of max names  
         ncb_callname[3] := #0; // Query of use NAME_NUMBER_1  
         ncb_command := Char(NCBRESET);  
         NetBios(ResetNCB);  
         Result := Byte(ncb_cmd_cplt);  
         end;  
      finally  
        Dispose(ResetNCB);  
      end;  
     end;  
    function GetMACAddress(LanaNum: Byte; MACAddress: PMACAddress): Byte;  
    var  
      AdapterStatus: PAdapterStatus;  
      StatNCB: PNCB;  
     begin  
      New(StatNCB);  
      ZeroMemory(StatNCB, SizeOf(TNCB));  
      StatNCB.ncb_length := SizeOf(TAdapterStatus) + 255 * SizeOf(TNameBuffer);  
      GetMem(AdapterStatus, StatNCB.ncb_length);  
      try  
        with StatNCB^ do  
         begin  
         ZeroMemory(MACAddress, SizeOf(TMACAddress));  
         ncb_buffer := PChar(AdapterStatus);  
         ncb_callname := '* ' + #0;  
         ncb_lana_num := Char(LanaNum);  
         ncb_command := Char(NCBASTAT);  
         NetBios(StatNCB);  
         Result := Byte(ncb_cmd_cplt);  
         if Result = NRC_GOODRET then  
            MoveMemory(MACAddress, AdapterStatus, SizeOf(TMACAddress));  
         end;  
      finally  
        FreeMem(AdapterStatus);  
        Dispose(StatNCB);  
       end;  
     end;  
    procedure TGetMACForm.Test;  
    var  
      LanaNum: Byte;  
      MACAddress: PMACAddress;  
      RetCode: Byte;  
     begin  
       for d:=0 to nl do  
         begin  
         LanaNum := StrToInt(Ln.Strings[d]);  
         RetCode := ResetLana(LanaNum, 0, 0, lrAlloc);  
         if RetCode <> NRC_GOODRET then  
           begin  
           Beep;  
           ShowMessage('Reset Error! RetCode = $' + IntToHex(RetCode, 2));  
           end;  
      New(MACAddress);  
     try  
       RetCode := GetMACAddress(LanaNum, MACAddress);  
       if RetCode = NRC_GOODRET then  
          begin  
          np^ := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',  
         [MACAddress[0], MACAddress[1], MACAddress[2],  
          MACAddress[3], MACAddress[4], MACAddress[5]]);  
          if N^=np^ then i:='1';  
         end;  
        finally  
         Dispose(MACAddress);  
        end;  
      end;  
      Dispose(Np);  
      Timer1.Enabled:=true;  
     end;  
    procedure TGetMACForm.Timer1Timer(Sender: TObject);  
     begin  
      If i='1' then Timer2.Enabled:=false  
        else Timer2.Enabled:=true;  
     end;  
    procedure TGetMACForm.Timer2Timer(Sender: TObject);  
     begin  
      Close;  
     end;  
    procedure TGetMACForm.FormClose(Sender: TObject; var Action: TCloseAction);  
     begin  
      Dispose(N);  
     end;  
    end.  

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

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


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

Защита приложений от крупных шрифтов

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

Вы наверняка задавались вопросом о том, как избежать искажений. И находили в сети одни и те же рецепты: использовать шрифты TrueType и отключать свойство Scaled у форм. Рецепт, предлагающий использовать только шрифты TrueType + Scaled = False для форм - верен. Однако тут есть некоторые неудобства.
Дело в том, что ни один из стандартных TrueType шрифтов не сравнится по качеству отображения с MS Sans Serif, который по умолчанию используется в вашем приложении. Самый близкий - Arial все же имеет довольно заметные отличия и проигрывает MS Sans Serif по читаемости.

Искажений форм так же полностью избежать не удастся. Особенно это может повлиять на компоновку сложных форм, а также при использовании в интерфейсе изображений и прочих немасштабируемых элементов. Иногда хочется просто запретить масштабирование и защитить программу от влияния крупных шрифтов. Но использовать MS Sans Serif в этом случае нельзя, так как в режиме крупных шрифтов система "сдвигает" их на 2 пункта вверх и шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах.

Для справки: В режиме стандартных размеров шрифтов в качестве системного используется, в основном, MS Sans Serif - рубленый шрифт без засечек. Он имеет размеры 8pt, 10pt, 12pt, 14pt, 18pt и 24pt. В основном используется размер 8pt. В режиме крупных шрифтов система увеличивает все шрифты на 120%. ( С 96 pixels per inch до 120 pixels per inch). Шрифт MS Sans Serif имеет всего 6 размеров. Поэтому 8pt становится 10pt, 10pt - 12pt и т.д. Шрифт 8pt MS Sans Serif выглядит как 10pt MS Sans Serif при мелких шрифтах. Шрифты же TrueType могут имеют произвольные размеры и шаг изменения равен 1pt. Поэтому при крупных шрифтах размеры TrueType и не-TrueType шрифтов изменяются по разному.

Предлагаемое решение способно защитить программу от влияния режима крупных шрифтов и не отказываться от шрифта MS Sans Serif при разработке программы. Подход состоит в том, чтобы заменять все шрифты MS Sans Serif на Arial при запуске программы при крупных шрифтах. Создавать программу, естественно, следует при мелких шрифтах.

Можно написать невизуальный компонент и добавить его на каждую форму. Компонент при загрузке проверяет режим и при обнаружении режима "Big Fonts" "обходит" все визуальные компоненты для замены шрифта. Также компонент заботится о том, чтобы свойство Scaled у форм было отключено.

unit glSmallFontsDefence;   
   
interface   
   
uses   
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;   
   
type   
  TglSmallFontsDefence = class(TComponent)   
  private   
    procedure UpdateFonts(Control: TWinControl);   
    { Private declarations }   
  protected   
    procedure Loaded; override;   
  public   
    constructor Create(AOwner: TComponent); override;   
  published   
    { Published declarations }   
  end;   
   
procedure Register;   
   
implementation   
  
function IsSmallFonts: boolean;{Значение функции TRUE если мелкий шрифт}   
var DC: HDC;   
begin   
  DC:=GetDC(0);   
  Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96);   
  { В случае крупного шрифта будет 120}   
  ReleaseDC(0, DC);   
end;   
   
procedure Register;   
begin   
  RegisterComponents('Gl Components', [TglSmallFontsDefence]);   
end;   
   
{ TglSmallFontsDefence }   
   
constructor TglSmallFontsDefence.Create(AOwner: TComponent);   
begin   
  inherited;   
  if (Owner is TForm) then (Owner as TForm).Scaled := false;   
end;   
   
procedure TglSmallFontsDefence.Loaded;   
begin   
  inherited;   
  if (Owner is TForm) then (Owner as TForm).Scaled := false;   
  if csDesigning in ComponentState then   
  begin   
    if not IsSmallFonts then   
      ShowMessage('Проектирование приложения в режиме крупных' +  
               ' шрифтов недопустимо!'#13#10+  
                  'Компонент TglSmallFontsDefence отказывается' +  
                  ' работать в таких условиях.');   
  end else   
    UpdateFonts((Owner as TForm));   
end;   
   
procedure TglSmallFontsDefence.UpdateFonts(Control: TWinControl);   
var   
  i: integer;   
  procedure UpdateFont(Font: TFont);   
  begin   
    if CompareText(Font.Name, 'MS Sans Serif') <> 0 then exit;   
    Font.Name := 'Arial';   
  end;   
begin   
  if IsSmallFonts then exit;   
  UpdateFont(TShowFont(Control).Font);   
  with Control do   
  for i:=0 to ControlCount-1 do   
  begin   
    UpdateFont(TShowFont(Controls[i]).Font);   
    if Controls[i] is TWinControl then UpdateFonts(Controls[i] as TWinControl);   
  end;   
   
end;   
   
   
end.  

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

Автор: Андрей Чудин

Защита от SoftIce

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

В этой статье я приведу код, который будет блокировать SoftIce95.

Во-первых проверь, прописан ли у тебя в разделе uses модуль windows. Прописан? Нет, так прописывай и поехали дальше…

Напишем функцию когда SoftIce загружен и выхода из системы. Затем, в конче кода, в разделе initialization совместим их.

Привожу код с комментариями:

interface  
  
implementation  
  
uses windows;  
  
function isSoftIce95Loaded: boolean; // функция загрузки SoftIce  
 var hfile:thandle;  
 begin  
 result:=false;  
 hfile:=createfileA('\\.\sice',generic_read or generic_write,   
      file_share_read or file_share_write,   
      nil, open_existing,  file_attribute_normal,0);  
 if(hfile <> invalid_handle_value) then begin  
 closehandle(hfile);  
 result:=true;  
 end;  
end;  
  
function winexit(flags:integer):boolean; // функция выхода из системы  
  
// эта функция поможет   
//нам определить выходить ли из системы или продолжать работу программы  
function Setprivilege (privilegename:string; enable:boolean):boolean;   
var  
tpPrev, tp:TTokenPrivileges;  
token: Thandle;  
dwRetLen: Dword;  
begin  
result:= false;  
openprocesstoken (GetCurrentProcess, token_adjust_privileges or token_query,token);  
tp.privilegecount:=1;  
if lookupprivilegeValue(nil, pchar(privilegename),tp.Privileges[0].luid) then begin  
if enable then tp.privileges[0].attributes:=se_privilege_enabled  
else tp.privileges[0].attributes:=0;  
dwRetLen:=0;  
result:=AdjustTokenPrivileges(token,false, tp, sizeof(tpprev),tpprev, dwretlen);  
end;  
closeHandle(token);  
end;  
  
begin   
if SetPrivilege ('SeShutdownPrivilege', true) then begin // если true то выходим из системы   
exitwindowsex(flags,0);  
SetPrivilege('SeShutdownPrivilege', false); // иначе работаем дальше  
end;  
end;  
  
initialization // начинаем сравнивать  
if isSoftIce95Loaded then begin // если SoftIce95 загружен то  
winexit (ewx_shutdown or ewx_force); // выходим из системы  
halt;  
end;  

Ну вот и все, идем пить пиво :)

Я привел код для 95-ого SoftIce, но не забывай есть еще NT-ный

А от NT-ого тебе придется догадаться самому. Сразу говорю, поменять надо всего пару букв.

Загрузка настроек программы из файла

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

procedure TForm1.FormShow(Sender: TObject);  
Var f:file of Integer; // файловая переменная, тип integer  
i:Integer; // целочистенная переменная  
begin  
AssignFile(f,'pos.ini');  
{$I-} // Отключаем контроль ошибок  
Reset(f);  
{$I+} // Включаем контроль ошибок  
if IOResult<>0 then Exit;  
Read(f,i); //считать из файла значение  
Form1.Top:=i; // верхнее положение окна  
Read(f,i);  
Form1.Left:=i; // левое положение окна  
Read(f,i);  
Form1.Width:=i; // ширина окна  
Read(f,i);  
Form1.Height:=i; // высота окна  
CloseFile(f);  
end;  

Здесь при запуске программа загружает нужные настройки из файла pos.ini находящимся в той же папке что и сама программа.

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

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);  
Var f:file of Integer; // файловая переменная, тип integer  
begin  
AssignFile(f,'pos.ini'); // Привязываем строку пути файла к файловой переменной  
{$I-} // Отключаем контроль ошибок  
Rewrite(f);  
{$I+} // Включаем контроль ошибок  
if IOResult<>0 then Exit; // Если ошибка то выходим  
Write(f,Form1.Top); // Записываем в файл положение окна по верикали  
Write(f,Form1.Left); // Записываем в файл положение окна по горизонтали  
Write(f,Form1.Width); // Записываем в файл ширину формы  
Write(f,Form1.Height); // Записываем в файл высоту формы  
CloseFile(f); // Завершаем работу с файлом  
end;  

Данный пример подойдет не только для сохранения размера окна программы, но и для сохранения других настроек.

Забавное программирование в Delphi

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

Итак, поехали...

Автоматически нажимающаяся кнопка
Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!

Предлагаю взглянуть на две версии данного компонента. В более простой версии обработчик перемещения мышки просто перехватывает сообщения Windows с нужным кодом и вызывает обработчик события OnClick:

type  
  TAutoButton1 = class(TButton)  
  private  
    procedure WmMouseMove (var Msg: TMessage);  
      message wm_MouseMove;  
  end;  
  
procedure TAutoButton1.WmMouseMove (var Msg: TMessage);  
begin  
  inherited;  
  if Assigned (OnClick) then  
    OnClick (self);  
end;  

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

type  
  TAutoKind = (akTime, akMovement, akBoth);  
  
  TAutoButton2 = class(TButton)  
  private  
    FAutoKind: TAutoKind;  
    FMovements: Integer;  
    FSeconds: Integer;  
    // really private  
    CurrMov: Integer;  
    Capture: Boolean;  
    MyTimer: TTimer;  
    procedure EndCapture;  
    // обработчики сообщений  
    procedure WmMouseMove (var Msg: TWMMouse);  
      message wm_MouseMove;  
    procedure TimerProc (Sender: TObject);  
    procedure WmLBUttonDown (var Msg: TMessage);  
      message wm_LBUttonDown;  
    procedure WmLButtonUp (var Msg: TMessage);  
      message wm_LButtonUp;  
  public  
    constructor Create (AOwner: TComponent); override;  
  published  
    property AutoKind: TAutoKind  
      read FAutoKind write FAutoKind default akTime;  
    property Movements: Integer  
      read FMovements write FMovements default 5;  
    property Seconds: Integer  
      read FSeconds write FSeconds default 10;  
  end;  

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

procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse);  
begin  
  inherited;  
  if not Capture then  
  begin  
    SetCapture (Handle);  
    Capture := True;  
    CurrMov := 0;  
    if FAutoKind <> akMovement then  
    begin  
      MyTimer := TTimer.Create (Parent);  
      if FSeconds <> 0 then  
        MyTimer.Interval := 3000  
      else  
        MyTimer.Interval := FSeconds * 1000;  
      MyTimer.OnTimer := TimerProc;  
      MyTimer.Enabled := True;  
    end;  
  end  
  else // захватываем  
  begin  
    if (Msg.XPos > 0) and (Msg.XPos < Width)  
      and (Msg.YPos > 0) and (Msg.YPos < Height) then  
    begin  
      // если мы подсчитываем кол-во движений...  
      if FAutoKind <> akTime then  
      begin  
        Inc (CurrMov);  
        if CurrMov >= FMovements then  
        begin  
          if Assigned (OnClick) then  
            OnClick (self);  
          EndCapture;  
        end;  
      end;  
    end  
    else // за пределами... стоп!  
      EndCapture;  
  end;  
end;  
  
procedure TAutoButton2.EndCapture;  
begin  
  Capture := False;  
  ReleaseCapture;  
  if Assigned (MyTimer) then  
  begin  
    MyTimer.Enabled := False;  
    MyTimer.Free;  
    MyTimer := nil;  
  end;  
end;  
  
procedure TAutoButton2.TimerProc (Sender: TObject);  
begin  
  if Assigned (OnClick) then  
    OnClick (self);  
  EndCapture;  
end;  
  
procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);  
begin  
  if not Capture then  
    inherited;  
end;  
  
procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);  
begin  
  if not Capture then  
    inherited;  
end;  

Как осуществить ввод текста в компоненте Label ?
Многие программисты задавая такой вопрос получают на него стандартный ответ "используй edit box." На самом же деле этот вопрос вполне решаем, хотя лейблы и не основаны на окне и, соответственно не могут получать фокус ввода и, соответственно не могут получать символы, вводимые с клавиатуры. Давайте рассмотрим шаги, которые были предприняты мной для разработки данного компонента.

Первый шаг, это кнопка, которая может отображать вводимый текст:

type  
  TInputButton = class(TButton)  
  private  
    procedure WmChar (var Msg: TWMChar);  
      message wm_Char;  
  end;  
  
procedure TInputButton.WmChar (var Msg: TWMChar);  
var  
  Temp: String;  
begin  
  if Char (Msg.CharCode) = #8 then  
  begin  
    Temp := Caption;  
    Delete (Temp, Length (Temp), 1);  
    Caption := Temp;  
  end  
  else  
    Caption := Caption + Char (Msg.CharCode);  
end;  

С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на объявление класса:

type  
  TInputLabel = class (TLabel)  
  private  
    MyEdit: TEdit;  
    procedure WMLButtonDown (var Msg: TMessage);  
      message wm_LButtonDown;  
  protected  
    procedure EditChange (Sender: TObject);  
    procedure EditExit (Sender: TObject);  
  public  
    constructor Create (AOwner: TComponent); override;  
  end;  

Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него. Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная на API функции DrawFocusRect:

constructor TInputLabel.Create (AOwner: TComponent);  
begin  
  inherited Create (AOwner);  
  
  MyEdit := TEdit.Create (AOwner);  
  MyEdit.Parent := AOwner as TForm;  
  MyEdit.Width := 0;  
  MyEdit.Height := 0;  
  MyEdit.TabStop := False;  
  MyEdit.OnChange := EditChange;  
  MyEdit.OnExit := EditExit;  
end;  
  
procedure TInputLabel.WMLButtonDown (var Msg: TMessage);  
begin  
  MyEdit.SetFocus;  
  MyEdit.Text := Caption;  
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);  
end;  
  
procedure TInputLabel.EditChange (Sender: TObject);  
begin  
  Caption := MyEdit.Text;  
  Invalidate;  
  Update;  
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);  
end;  
  
procedure TInputLabel.EditExit (Sender: TObject);  
begin  
  (Owner as TForm).Invalidate;  
end;  

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

Компонент звуковой кнопки имеет два новых свойства:

type  
  TDdhSoundButton = class(TButton)  
  private  
    FSoundUp, FSoundDown: string;  
  protected  
    procedure MouseDown(Button: TMouseButton;  
      Shift: TShiftState; X, Y: Integer); override;  
    procedure MouseUp(Button: TMouseButton;  
      Shift: TShiftState; X, Y: Integer); override;  
  published  
    property SoundUp: string  
      read FSoundUp write FSoundUp;  
    property SoundDown: string  
      read FSoundDown write FSoundDown;  
  end;  

Звуки будут проигрываться при нажатии и отпускании кнопки:

procedure TDdhSoundButton.MouseDown(  
  Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
begin  
  inherited;  
  PlaySound (PChar (FSoundDown), 0, snd_Async);  
end;  
  
procedure TDdhSoundButton.MouseUp(Button: TMouseButton;  
  Shift: TShiftState; X, Y: Integer);  
begin  
  inherited;  
  PlaySound (PChar (FSoundUp), 0, snd_Async);  
end;  

Экранный вирус
Никогда не видели экранного вируса? Представьте, что Ваш экран заболел и покрылся красными пятнами :) А если эта болезнь нападёт на какое-нибудь окно ? Всё, что нам надо, это получить контекст устройства при помощи API функции GetWindowDC и рисовать, что душе угодно.

К исходному коду особых комментариев не требуется, скажу лишь только то, что основная часть кода находится в обработчике события OnTimer:

type  
  TScreenVirus = class(TComponent)  
  private  
    FTimer: TTimer;  
    FInterval: Cardinal;  
    FColor: TColor;  
    FRadius: Integer;  
  protected  
    procedure OnTimer (Sender: TObject);  
    procedure SetInterval (Value: Cardinal);  
  public  
    constructor Create (AOwner: TComponent); override;  
    procedure StartInfection;  
  published  
    property Interval: Cardinal  
      read FInterval write SetInterval;  
    property Color: TColor  
      read FColor write FColor default clRed;  
    property Radius: Integer  
      read FRadius write FRadius default 10;  
  end;  
  
constructor TScreenVirus.Create (AOwner: TComponent);  
begin  
  inherited Create (AOwner);  
  FTimer := TTimer.Create (Owner);  
  FInterval := FTimer.Interval;  
  FTimer.Enabled := False;  
  FTimer.OnTimer := OnTimer;  
  FColor := clRed;  
  FRadius := 10;  
end;  
  
procedure TScreenVirus.StartInfection;  
begin  
  if Assigned (FTimer) then  
    FTimer.Enabled := True;  
end;  
  
procedure TScreenVirus.SetInterval (Value: Cardinal);  
begin  
  if Value <> FInterval then  
  begin  
    FInterval := Value;  
    FTimer.Interval := Interval;  
  end;  
end;  
  
procedure TScreenVirus.OnTimer (Sender: TObject);  
var  
  hdcDesk: THandle;  
  Brush: TBrush;  
  X, Y: Integer;  
begin  
  hdcDesk := GetWindowDC (GetDesktopWindow);  
  Brush := TBrush.Create;  
  Brush.Color := FColor;  
  SelectObject (hdcDesk, Brush.Handle);  
  X := Random (Screen.Width);  
  Y := Random (Screen.Height);  
  Ellipse (hdcDesk, X - FRadius, Y - FRadius,  
    X + FRadius, Y + FRadius);  
  ReleaseDC (hdcDesk, GetDesktopWindow);  
  Brush.Free;  
end;  

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

В приведённом ниже примере при помощи обычного диалогового окна пользователю показывается сообщение об ошибке, причём кнопка "close" накак не хочет нажиматься. У этого диалога есть зависимое окно, которое показывается, при нажатии кнопки "details".

Поддельная форма с сообщением об ошибке имеет кнопку "details", которая открывает вторую часть формы. Это достигается путём добавления компонента за пределы самой формы:

object Form2: TForm2  
  AutoScroll = False  
  Caption = 'Error'  
  ClientHeight = 93  
  ClientWidth = 320  
  OnShow = FormShow  
  object Label1: TLabel  
    Left = 56  
    Top = 16  
    Width = 172  
    Height = 65  
    AutoSize = False  
    Caption =   
      'Программа выполнила недопустимую ' +  
      'операцию. Если проблема повторится, ' +  
      'то обратитесь к разработчику программного обеспечения.'  
    WordWrap = True  
  end  
  object Image1: TImage  
    Left = 8  
    Top = 16  
    Width = 41  
    Height = 41  
    Picture.Data = {...}  
  end  
  object Button1: TButton  
    Left = 240  
    Top = 16  
    Width = 75  
    Height = 25  
    Caption = 'Close'  
    TabOrder = 0  
    OnClick = Button1Click  
  end  
  object Button2: TButton  
    Left = 240  
    Top = 56  
    Width = 75  
    Height = 25  
    Caption = 'Details >>'  
    TabOrder = 1  
    OnClick = Button2Click  
  end  
  object Memo1: TMemo // за пределами формы!  
    Left = 24  
    Top = 104  
    Width = 265  
    Height = 89  
    Color = clBtnFace  
    Lines.Strings = (  
      'AX:BX    73A5:495B'  
      'SX:PK    676F:FFFF'  
      'OH:OH   7645:2347'  
      'Crash    3485:9874'  
      ''  
      'What'#39's going on here?')  
    TabOrder = 2  
  end  
end  

Когда пользователь нажимает кнопку "details", то программа просто изменяет размер формы:

procedure TForm2.Button2Click(Sender: TObject);  
begin  
  Height := 231;  
end;  

Вторая форма, которая наследуется от первой имеет перемещающуюся кнопку "close":

procedure TForm3.Button1Click(Sender: TObject);  
begin  
  Button1.Left := Random (ClientWidth - Button1.Width);  
  Button1.Top := Random (ClientHeight - Button1.Height);  
end;  

В заключении, можно сделать дырку в окне, используя API функцию SetWindowRgn:

procedure TForm1.Button4Click(Sender: TObject);  
var  
  HRegion1, Hreg2, Hreg3: THandle;  
  Col: TColor;  
begin  
  ShowMessage ('Ready for a real crash?');  
  Col := Color;  
  Color := clRed;  
  PlaySound ('boom.wav', 0, snd_sync);  
  HRegion1 := CreatePolygonRgn (Pts,  
    sizeof (Pts) div 8,  
    alternate);  
  SetWindowRgn (  
    Handle, HRegion1, True);  
  ShowMessage ('Now, what have you done?');  
  Color := Col;  
  ShowMessage ('Вам лучше купить новый монитор');  
end;  

Еще пара способов получения содержимого страницы

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

Компонент TIdHTTP
Идем на вкладку Indy Clients и из широчайшего выбора компонентов останавливаемся на TIdHTTP. Компонент TIdHTTP (Indy клиент HTTP) используется для поддержки сетевого протокола HTTP на стороне клиента (поддерживаются версии 1.0 и 1.1, включая операции GET, POST и HEAD). Кроме того, обеспечивается поддержка аутентификации пользователей и применение прокси-серверов. Можете самостоятельно поэкспериментировать с ним. Я же покажу самое простое. Киньте на новую форму этот компонент, мемо и кнопку. В обработчике клика кнопки напишите:

 try   
  s := IdHTTP1.Get('http://yandex.ru');   
  Memo1.Text := s;   
except   
end;   

Всего одна строчка кода — и в переменной s у вас окажется всё, что вернет Get-запрос. Мы получили все, что нужно для дальнейшей обработки.

UrlDownloadToFile
В uses добавляем UrlMon. Объявляем функцию:

function DownloadFile(SourceFile, DestFile: string): Boolean;  

Реализация:

function DownloadFile(SourceFile, DestFile: string): Boolean;   
begin   
  try   
    Result := UrlDownloadToFile(nil, PChar(SourceFile),   
PChar(DestFile), 0,   
         nil) = 0;   
  except   
       Result := False;   
  end;   
end;  

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

try   
  SLBody:=TStringList.Create;   
  sFileName:=ExtractFilePath(Application.ExeName) + 'cache.txt';   
  currBody:='';   if DownloadFile(LinkStr,sFileName) then   
     SLBody.LoadFromFile(sFileName);   
  currBody:=SLBody.Text;   
  DeleteFile(sFileName);   
finally   
  SLBody.Free;   
end;  

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

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