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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



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

Автор: Nomadic

Новости геральдики: Барон Билл Гейтс, виконт Редмондский по прозвищу Мелкомягкий. В гербе на зеленом поле четыре окна лежащие пофигообразно. Щит поддерживается двумя фигурами ламеров с мышами в зубах. В тэмборе - виртуальный шлем SFX-1.

В копилку. Исходный код, FAQ - желающие могут взять с Internet сами (информация взята с http://www.softmosis.ca, проверено - работает).

Основной модуль, регистрация и вызов


 ...
 public
   { Public declarations }
   FWordApp: _Application;
   FWordDoc: _Document;
   FWordSink: TWordConnection;
 ...
 
 procedure StartWordConnection(WordApp: _Application;
   WordDoc: _Document;
   var WordSink: TWordConnection);
 var
   PointContainer: IConnectionPointContainer;
   Point: IConnectionPoint;
 begin
   try
     // TWordConnection is the COM object which receives the
     // notifications from Word. Make sure to free WordSink when
     // you are done with it.
     WordSink := TWordConnection.Create;
     WordSink.WordApp := WordApp;
     WordSink.WordDoc := WordDoc;
 
     // Sink with a Word application
     OleCheck(WordApp.QueryInterface(IConnectionPointContainer, PointContainer));
     if Assigned(PointContainer) then
     begin
       OleCheck(PointContainer.FindConnectionPoint(ApplicationEvents, Point));
       if Assigned(Point) then
         Point.Advise((WordSink as IUnknown), WordSink.AppCookie);
     end;
 
     // Sink with a Word document advise
     OleCheck(WordDoc.QueryInterface(IConnectionPointContainer, PointContainer));
     if Assigned(PointContainer) then
     begin
       OleCheck(PointContainer.FindConnectionPoint(DocumentEvents, Point));
       if Assigned(Point) then
         Point.Advise((WordSink as IUnknown), WordSink.DocCookie);
     end;
 
   except
     on E: Exception do
       ShowMessage(E.Message);
   end;
 end;
 
 procedure TmainForm.btnStartClick(Sender: TObject);
 begin
   FWordApp := CoApplication_.Create;
   FWordDoc := FWordApp.Documents.Add(EmptyParam, EmptyParam);
   FWordApp.Visible := True;
   StartWordConnection(FWordApp, FWordDoc, FWordSink);
 end;
 
 procedure TmainForm.btnExitClick(Sender: TObject);
 begin
   FWordApp.Quit(EmptyParam, EmptyParam, EmptyParam);
 end;
 

Модуль отслеживания линков


 unit ConnectionObject;
 
 interface
 
 uses Word_TLB, dialogs;
 
 type
   TWordConnection = class(TObject, IUnknown, IDispatch)
   protected
     {IUnknown}
     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
     function _AddRef: Integer; stdcall;
     function _Release: Integer; stdcall;
 
     { IDispatch }
     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
       stdcall;
     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
         stdcall;
 
   public
     WordApp: _Application;
     WordDoc: _Document;
     AppCookie, DocCookie: Integer;
   end;
 
 implementation
 
 { IUnknown Methods }
 
 uses windows, activex, main;
 
 procedure LogComment(comment: string);
 begin
   Form1.Memo1.Lines.Add(comment);
 end;
 
 function TWordConnection._AddRef: Integer;
 begin
   Result := 2;
 end;
 
 function TWordConnection._Release: Integer;
 begin
   Result := 1;
 end;
 
 function TWordConnection.QueryInterface(const IID: TGUID;
   out Obj): HResult;
 begin
   Result := E_NOINTERFACE;
   Pointer(Obj) := nil;
   if (GetInterface(IID, Obj)) then
     Result := S_OK;
   if not Succeeded(Result) then
     if (IsEqualIID(IID, DocumentEvents) or IsEqualIID(IID, ApplicationEvents))
       then
       if (GetInterface(IDispatch, Obj)) then
         Result := S_OK;
 end;
 
 { IDispatch Methods }
 
 function TWordConnection.GetIDsOfNames(const IID: TGUID; Names: Pointer;
   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
 begin
   Result := E_NOTIMPL;
 end;
 
 function TWordConnection.GetTypeInfo(Index, LocaleID: Integer;
   out TypeInfo): HResult;
 begin
   Pointer(TypeInfo) := nil;
   Result := E_NOTIMPL;
 end;
 
 function TWordConnection.GetTypeInfoCount(out Count: Integer): HResult;
 begin
   Count := 0;
   Result := E_NOTIMPL;
 end;
 
 function TWordConnection.Invoke(DispID: Integer; const IID: TGUID;
   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
   ArgErr: Pointer): HResult;
 begin
   //This is the entry point for Word event sinking
   Result := S_OK;
   case DispID of
     1: ; // Startup
     2: ShowMessage('quit'); // Quit
     3: ; // Document change
     4: ; // New document
     5: ; // Open document
     6: ShowMessage('close'); // Close document
   else
     Result := E_INVALIDARG;
   end;
 end;
 
 end.
 




Преобразование формата MS BINARY в IEEE

"Использование, независимое от машинного уровня" не так просто в реализации с процессорами, выпущенными до Intel-го математического сопроцессора 80x87. Я не уверен в том, что процессоры 80x86 имели какие-либо родные инструкции для выполнения операций с плавающей точкой. По-видимости, поэтому Microsoft создал свой собственный формат для чисел с плавающей точкой; он сам осуществлял всю арифметику с помощью библиотеки времени выполнения. Сегодня 80x87 осуществляет такую арифметику автоматически, и IEEE теперь стандарт.

Delphi хранит следующие типы чисел с плавающей точкой в формате IEEE:

  Single      4 байт
   Double      8 байт
   Extended   10 байт
Обратите внимание на то, что тип Real (6 байт) отсутствует в данном списке. Я могу ошибаться, но мне кажется что тип Real - синтезированный в Pascal тип; он может без особых проблем существовать на процессорах ниже 80x87.

[В сторону: электронная справка Delphi сообщает, что по умолчанию (через директиву компилятора $N+), компилятор будет генерировать код для выполнения ВСЕХ операций с плавающей точкой, используя инструкции 80x87, включая тип Real. Также, для работы с типом Real, компилятор генерирует вызовы библиотеки времени выполнения, или же я полностью неправ в вышесказанном! :) ]

Во всяком случае, в электронной справке Visual Basic я увидел, что VB оперирует с типами данных Single и Double, которые также относятся к типу IEEE, и идентичны Delphi-типам Single и Double. Тем не менее, в справке отсутствует упоминание "Microsoft Binary Format".

Для того, чтобы разобраться в вопросе, я "опустился" до DOS и запустил QBasic, новую версию интерпретатора Microsoft QuickBasic, включаемую теперь в поставку DOS. Если мы посмотрим в электронную справку, то увидим следующее:

MKSMBF$ и MKDMBF$ преобразуют числа формата IEEE в "числовые строки" формата Microsoft-Binary, которые могут храниться в строковых переменных типа FIELD. CVSMBF и CVDMBF преобразуют эти строки обратно в числа формата IEEE.

MKSMBF$(выражение-единичной-точности!)
 MKDMBF$(выражение-двойной-точности#)
 CVSMBF (4-байтовая-числовая-строка)
 CVDMBF (8-байтовая-числовая-строка)
 
    Функция     Возвращаемое значение
 
    MKSMBF$     4-байтовая строка, содержащая число в формате Microsoft-Binary-format
    MKDMBF$     8-байтовая строка, содержащая число в формате Microsoft-Binary-format
    CVSMBF      Число единичной точности в формате IEEE
    CVDMBF      Число двойной точности в формате IEEE
Эти функции могут оказаться полезными при поддержке файлов данных, созданных с помощью старых версий Basic.

Суммируя вышесказанное, можно дать 3 рекомендации для получения доступа к вашим "MetaStock"-файлам:

  1. Напишите вашу программу в QBasic/DOS
  2. Найдите замену (с учетом совместимости с Delphi) для функций преобразований, упомянутых выше.
  3. Напишите эти функции сами. Вы должны найти документацию для старых типов Single и Double, применявшихся в "Microsoft Binary Format", возможно в справочных файлах старых версий MS Basic.



Несколько колонок в TComboBox


 procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
   Index: Integer; Rect: TRect; State: TOwnerDrawState);
 var
   strVal, strAll: string;
   pos1, pos2: Integer;
   rc: TRect;
   arrWidth: array [0..3] of Integer;
 begin
   Combobox1.Canvas.Brush.Style := bsSolid;
   Combobox1.Canvas.FillRect(Rect);
   // Die einzelnen Spalten mussen durch ';' getrennt sein 
   // the columns must be separated by ';' 
   strAll := Combobox1.Items[Index];
 
   arrWidth[0] := 0;
   arrWidth[1] := 100;  // Width of column 1 
   arrWidth[2] := 200;  // Width of column 2 
   arrWidth[3] := 300;  // Width of colimn 3 
 
   // Zeichenbereich fur erste Spalte 
   // Drawingrange for first column 
   rc.Left   := Rect.Left + arrWidth[0] + 2;
   rc.Right  := Rect.Left + arrWidth[1] - 2;
   rc.Top    := Rect.Top;
   rc.Bottom := Rect.Bottom;
 
   // Text fur erste Spalte ausfiltern 
   // Get text for first column 
   pos1   := Pos(';', strAll);
   strVal := Copy(strAll, 1, pos1 - 1);
   // Text ausgeben 
   // Draw Text 
   Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
   // Trennlinie zwischen Spalten zeichnen 
   // Draw separating line betwenn columns 
   Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
   Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);
 
   // Zeichenbereich fur zweite Spalte 
   // Drawingrange for second column 
   rc.Left  := Rect.Left + arrWidth[1] + 2;
   rc.Right := Rect.Left + arrWidth[2] - 2;
 
   // Text fur zweite Spalte ausfiltern 
   // Get text for second column 
   strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
   pos1   := Pos(';', strAll);
   strVal := Copy(strAll, 1, pos1 - 1);
 
   // Text ausgeben 
   // Draw Text 
   Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
   // Trennlinie zwischen Spalten zeichnen 
   // Draw separating line betwenn columns 
   Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
   Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);
 
   // Zeichenbereich fur dritte Spalte 
   // Drawingrange for third column 
   rc.Left  := Rect.Left + arrWidth[2] + 2;
   rc.Right := Rect.Left + arrWidth[3] - 2;
 
   // Text fur dritte Spalte ausfiltern 
   // Get text for third column 
   strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
   pos1   := Pos(';', strAll);
   strVal := Copy(strAll, 1, pos1 - 1);
 
   // Text ausgeben 
   // Draw Text 
   Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
   // Trennlinie zwischen Spalten zeichnen 
   // Draw separating line betwenn columns 
   Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
   Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);
   strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
 end;
 
 
 // Example/ Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with Combobox1.Items do
   begin
     Add('first;second;third;');
     Add('column1;column2;column3;');
   end;
 end;
 
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   //Oder im Objekt Inspektor einstellen 
   //Or set this Property in the Object Inspector 
   Combobox1.Style := csOwnerDrawFixed;
 end;
 




Мультиязыковое приложение

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

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

Вот некоторый код, дающий представление об этом методе:


 unit French1;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, IniFiles;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     procedure FormActivate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
   StringIndex: Integer;
 implementation
 
 {$R *.DFM}
 
 {$R MULTLANG.RES}
 
 { Вот содержимое ресурсного файла для этого проекта:
 1, "Attention"
 2, "No Condition definition selected!"
 3, "Always"
 4, "Cannot delete the 'always' condition."
 5, "Confirmation"
 6, "Delete the condition?"
 7, "Yes"
 8, "No"
 9, "Attention"
 10, "Pas de condition Selectionnйe"
 11, "Toulours"
 12, "Ne peux effacer la condition 'Toujours'"
 13, "Confirmation"
 14, "Effacer cette condition?"
 15, "&Oui"
 16, "&Non"
 }
 
 procedure TForm1.FormActivate(Sender: TObject);
 var
 
   {inifile : TIniFile; Опционально}
   ProgramLanguage: string;
 begin
 
   { Устанавливаем французский язык }
   ProgramLanguage := 'fra';
   { Дополнительно вы можете получить текущий язык из Win.INI:}
   {inifile := TInifile.Create('WIN.INI');
   ProgramLanguage := inifile.ReadString('intl', 'sLanguage', 'enu');
   inifile.Free;}
   { Простите за то, что я привожу здесь несколько языков, указанные
   ниже находились в файле setup.inf моей операционной системы.
 
   dan = Danish
   nld = Dutch
   enu = English (American)
   eng = English (International)
   fin = Finnish
   fra = French
   frc = French Canadian
   deu = German
   isl = Icelandic
   ita = Italian
   nor = Norwegian
   ptg = Portuguese
   esp = Spanish
   esn = Spanish (Modern)
   sve = Swedish
 
   }
 
   if ProgramLanguage = 'enu' then
   begin
     StringIndex := 0;
   end
   else if ProgramLanguage = 'fra' then
   begin
     StringIndex := 8;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   i, j, k: integer;
   DialogForm: tform;
 begin
 
   Application.NormalizeTopMosts;
   {No Condition definition selected!"}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex + 2), mtWarning,
     [mbOK]);
   {Attention}
   DialogForm.caption := LoadStr(StringIndex + 1);
   DialogForm.showmodal;
   Application.RestoreTopMosts;
   {Cannot delete the 'always' condition.}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex + 4), mtWarning,
     [mbOK]);
   {Always}
   DialogForm.caption := LoadStr(StringIndex + 3);
   DialogForm.showmodal;
   Application.RestoreTopMosts;
   {Delete the condition?}
   DialogForm := CreateMessageDialog(LoadStr(StringIndex + 6), mtInformation,
     [mbYes, mbNo]);
   {confirmation}
   DialogForm.caption := LoadStr(StringIndex + 5);
   for j := 0 to DialogForm.controlCount - 1 do
   begin
     if DialogForm.controls[j] is tButton then
       with tButton(DialogForm.controls[j]) do
       begin
         if caption = '&Yes' then
           caption := LoadStr(StringIndex + 7);
         if caption = '&No' then
           caption := LoadStr(StringIndex + 8);
       end;
   end;
   DialogForm.showmodal;
 end;
 
 end.
 




Многострочный заголовок у TBitBtn

Автор: Neil Rubenking

Выводите текст непосредственно на glyph'e TBitBtn'а:


 procedure TForm1.FormCreate(Sender: TObject);
 var
   R : TRect;
   N : Integer;
   Buff : array[0..255] of Char;
 begin
   with BitBtn1 do
   begin
     Caption := 'Delphi World is COOL programm!';
     Glyph.Canvas.Font := Self.Font;
     Glyph.Width := Width - 6;
     Glyph.Height := Height - 6;
     R := Bounds(0, 0, Glyph.Width, 0);
     StrPCopy(Buff, Caption);
     Caption := '';
     DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
     DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
     OffsetRect(R,(Glyph.Width - R.Right) div 2,
     (Glyph.Height - R.Bottom) div 2);
     DrawText(Glyph.Canvas.Handle,Buff,StrLen(Buff),R,
     DT_CENTER or DT_WORDBREAK);
   end;
 end;
 




Многострочный заголовок у TBitBtn 2

Я создал удобный компонент, инкапсулирующий обычную кнопку, но с возможностью многострочного заголовка. В *действительности* - это TBitBtn, чей Glyph *нарисован* в виде заголовка с переносом текста. Реальный заголовок невидим. Это работает! Попробуйте с этим поэкспериментировать и сообщите мне о ваших новых находках. Я был удивлен, что это свойство оказалось легко *подавить*. Тем более, что это свойство public/published, а не какой-то кот в мешке. Все это так, но вы можете перекрыть свойство другим с таким же именем и с атрибутом READ ONLY. И вы можете ссылать на свойство предка, как, например, "Inherited Glyph". ООП!


 unit C_wrapb;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Buttons;
 
 type
   TWrapBtn = class(TBitBtn)
   private
     { Private declarations }
     function GetGlyph: string;
     function GetMargin: Integer;
     function GetSpacing: Integer;
     function GetKind: TBitBtnKind;
     function GetLayout: TButtonLayout;
     function GetNumGlyphs: TNumGlyphs;
     procedure CMTextChanged(var Message: TMessage);
       message CM_TEXTCHANGED;
     procedure CMFontChanged(var Message: TMessage);
       message CM_FONTCHANGED;
     procedure WMSize(var Msg: TWMSize);
       message WM_SIZE;
     procedure CaptionGlyph;
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
     property Glyph: string read GetGlyph;
     property Margin: Integer read GetMargin;
     property Spacing: Integer read GetSpacing;
     property Kind: TBitBtnKind read GetKind;
     property Layout: TButtonLayout read GetLayout;
     property NumGlyphs: TNumGlyphs read GetNumGlyphs;
   end;
 
 procedure Register;
 
 implementation
 
 procedure TWrapBtn.CaptionGlyph;
 var
   GP: TBitmap;
   R: TRect;
   Buff: array[0..255] of Char;
 begin
   GP := TBitmap.Create;
   try
     with GP do
     begin
       Canvas.Font := Self.Font;
       StrPCopy(Buff, Caption);
       inherited Margin := 0;
       inherited Spacing := GetSpacing;
       Width := Self.Width - GetSpacing;
       Height := Self.Height - GetSpacing;
       R := Bounds(0, 0, Width, 0);
       DrawText(Canvas.Handle, Buff, StrLen(Buff), R,
         DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
       OffsetRect(R, (Width - R.Right) div 2,
         (Height - R.Bottom) div 2);
       DrawText(Canvas.Handle, Buff, StrLen(Buff), R,
         DT_CENTER or DT_WORDBREAK);
     end;
     inherited Glyph := GP;
     inherited NumGlyphs := 1;
   finally
     GP.Free;
   end;
 end;
 
 function TWrapBtn.GetGlyph: string;
 begin
   Result := '(Н/Д)';
 end;
 
 procedure TWrapBtn.CMTextChanged(var Message: TMessage);
 begin
   inherited;
   CaptionGlyph;
 end;
 
 procedure TWrapBtn.CMFontChanged(var Message: TMessage);
 begin
   inherited;
   CaptionGlyph;
 end;
 
 procedure TWrapBtn.WMSize(var Msg: TWMSize);
 begin
   inherited;
   CaptionGlyph;
 end;
 
 function TWrapBtn.GetMargin: Integer;
 begin
   Result := 0;
 end;
 
 function TWrapBtn.GetSpacing: Integer;
 begin
 {$IFDEF Win32}
   Result := 12;
 {$ELSE}
   Result := 6;
 {$ENDIF}
 end;
 
 function TWrapBtn.GetKind: TBitBtnKind;
 begin
   Result := bkCustom;
 end;
 
 function TWrapBtn.GetLayout: TButtonLayout;
 begin
   Result := blGlyphLeft;
 end;
 
 function TWrapBtn.GetNumGlyphs: TNumGlyphs;
 begin
   Result := 1;
 end;
 
 procedure Register;
 begin
   RegisterComponents('FAQ', [TWrapBtn]);
 end;
 
 end.
 




Кнопка с многострочным заголовком


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: Integer;
 begin
   i := GetWindowLong(Button1.Handle, GWL_STYLE);
   SetWindowLong(Button1.Handle, GWL_STYLE, i or BS_MULTILINE);
   Button1.Caption := 'Delphi World - ' + #13#10 + 'лучше не бывает!';
 end;
 




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

Приведу способ, как сделать кнопку с тремя (или более) строчками текста. Разместите на форме компонент TBitBtn и задайте ему достаточно длинный заголовок. Не волнуйтесь о том, что такой длинный заголовок "раздувает" кнопку налево и направо. Создайте обраб отчик формы OnCreate как показано ниже:


 var
   R: TRect;
   N: Integer;
   Buff: array[0..255] of Char;
   ...WITH BitBtn1 do
 begin
   Glyph.Canvas.Font := Self.Font;
   Glyph.Width := Width - 6;
   Glyph.Height := Height - 6;
   R := Bounds(0, 0, Glyph.Width, 0);
   StrPCopy(Buff, Caption);
   Caption := '';
   DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
     DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
   OffsetRect(R, (Glyph.Width - R.Right) div 2,
     (Glyph.Height - R.Bottom) div 2);
   DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
     DT_CENTER or DT_WORDBREAK);
 end;
 




Многострочный DBGrid

Автор: Chris Hall

Жена заявляет программисту:
Ж: Дорогой, у меня задержка...
П (не отрываясь от монитора): Хммммм.. ЭТО - БАГ 2000!!!

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

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

Я протестировал данный код и он отлично работал. Небольшая доводка все-же нужна (обработка blob-полей, обработка ошибок и пр.), но это не сложно.


 unit Dbmygrid;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, DB, DBTables, StdCtrls, ExtCtrls, Grids, DBGrids;
 
 type
 
   TMultiLineDBGrid = class(TDBGrid)
   private
     FLinesPerRow: Integer;
     procedure DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField;
       State: TGridDrawState);
     procedure LayoutChanged; override;
     procedure SetLinesPerRow(ALinesPerRow: Integer);
   public
     property LinesPerRow: Integer read FLinesPerRow write SetLinesPerRow default
       1;
     constructor Create(AOwner: TComponent); override;
   end;
 
 implementation
 
 constructor TMultiLineDBGrid.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   FLinesPerRow := 1;
   OnDrawDataCell := DrawDataCell;
 end;
 
 procedure TMultiLineDBGrid.LayOutChanged;
 begin
 
   inherited LayOutChanged;
   DefaultRowHeight := DefaultRowHeight * LinesPerRow;
 end;
 
 procedure TMultiLineDBGrid.DrawDataCell(Sender: TObject; const Rect: TRect;
   Field: TField; State: TGridDrawState);
 var
 
   Format: Word;
   C: array[0..255] of Char;
 begin
 
   if LinesPerRow = 1 then
     Format := DT_SINGLELINE or DT_LEFT
   else
     Format := DT_LEFT or DT_WORDBREAK;
 
   Canvas.FillRect(Rect);
 
   StrPCopy(C, Field.AsString);
   WinProcs.DrawText(Canvas.Handle, C, StrLen(C), Rect, Format);
 end;
 
 procedure TMultiLineDBGrid.SetLinesPerRow(ALinesPerRow: Integer);
 begin
 
   if ALinesPerRow <> FLinesPerRow then
   begin
     FLinesPerRow := ALinesPerRow;
     LayoutChanged;
   end;
 end;
 
 end.
 




Многостроковый TComboBox


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     ComboBox1: TComboBox;
     procedure FormCreate(Sender: TObject);
     procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
       var Height: Integer);
     procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
       Rect: TRect; State: TOwnerDrawState);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Combobox1.Style := csOwnerDrawVariable;
   // die Combobox mit einigen Beispielen fullen 
   // fill the combobox with some examples 
   with Combobox1.Items do
   begin
     Add('Short, kurzer String');
     Add('A long String. / Ein langer String.....');
     Add('Another String');
     Add('abcd defg hijk lmno');
     Add('..-.-.-.-.-.-.-.-.-');
   end;
 end;
 
 procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
   var Height: Integer);
   // Berechnet die notwendige Hohe fur einen mehrzeiligen Text 
   // Calculates the required height for a multiline text 
 var
   i, PosSp: Integer;
   strVal: string;
   strTmp: string;
 begin
   if Index >= 0 then
   begin
     strVal := Combobox1.Items[Index];
     // String auf mehrere Zeilen aufteilen, Zeilen sind mit #$D#$A getrennt 
     // wrap string to multiple lines, each line separated by #$D#$A 
     strTmp := WrapText(strVal, 20);
     // Anzahl der Zeilentrennungen plus eins = Anzahl Zeilen 
     // Number of line separators + 1 = number of lines 
     i := 1;
     while Pos(#$D#$A, strTmp) > 0 do
     begin
       i      := i + 1;
       strTmp := Copy(strTmp, Pos(#13#10, strTmp) + 2, Length(strTmp));
     end;
     // Hohe fur den Text berechnen 
     // calcualte the height for the text 
     Height := i * Combobox1.ItemHeight;
   end;
 end;
 
 procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
   Rect: TRect; State: TOwnerDrawState);
   // Schreibt einen Text auf die Combobox. Wenn der Text zu lange ist, wird er 
   // auf mehrere Zeilen aufgeteilt 
   // Writes a text to the combobox. If the text is too long, then it will be 
   // wrapped 
 var
   strVal: string;
   strTmp: string;
   intPos: Integer;
   i: Integer;
   rc: TRect;
 begin
   // Text auf mehrere Zeilen aufteilen 
   // wrap the text 
   strVal := WrapText(Combobox1.Items[Index], 20);
   i      := 0;
   Combobox1.Canvas.FillRect(Rect);
   // jede Textzeile einzeln ausgeben 
   // output each single line 
   while Pos(#$D#$A, strVal) > 0 do
   begin
     intPos := Pos(#$D#$A, strVal);
     // Aktuelle Zeile aus dem String kopieren 
     // copy current line from string 
     if intPos > 0 then
       strTmp := Copy(strVal, 1, intPos - 1)
     else
       strTmp := strVal;
     rc     := Rect;
     rc.Top := Rect.Top + i * Combobox1.ItemHeight;
     ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight,
       strTmp);
     // die ausgegebene Zeile aus dem String loschen 
     // delete the written line from the string 
     strVal := Copy(strVal, intPos + 2, Length(strVal));
     Inc(i);
   end;
   rc     := Rect;
   rc.Top := Rect.Top + i * Combobox1.ItemHeight;
   // Letzte Zeile schreiben 
   // write the last line 
   ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight, strVal);
   Combobox1.Canvas.Brush.Style := bsClear;
   // den Text mit einem Rechteck umrunden 
   // surround the text with a rectangle 
   Combobox1.Canvas.Rectangle(Rect);
 end;
 
 end.
 




Многострочный TStringGrid

Изобрели суперкомпьютер. Позвали англичанина, немца и русского колхозника и сказали:
- Назовите два числа и компьютер произведет с ними любую операцию. Если он не сможет посчитать, вы получите кучу денег!
Англичанин называет 10^6581 - компьютер все посчитал и его выгнали. Немец называет 236^65468749846 - компьютер все посчитал и его тоже выгнали.
Русский говорит:
- До х#я...
Компьютер зависает. Изобретатели посовещались и решили:
- Поехали к нему в колхоз, наверное, у них там все такие умные!
Приезжают в колхоз, смотрят - мужик поле косит. Подходят к нему и спрашивают:
- Мужик, скажи, а "до х#я" это много?
- Да как вам сказать... Видите поле, которое я кошу? Это до х#я.
- Не поняли... А вот поле через дорогу - это тоже до х#я?
- А это соседское, это до п#зды!!!

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


 // if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
 
 procedure TForm1.grid1DrawCell(Sender: TObject; Col, Row: Longint;
   Rect: TRect; State: TGridDrawState);
 var
   l_oldalign: word;
   l_YPos, l_XPos, i: integer;
   s, s1: string;
   l_col, l_row: longint;
 begin
   l_col := col;
   l_row := row;
   with sender as tstringgrid do
   begin
     if (l_row = 0) then
       canvas.font.style := canvas.font.style + [fsbold];
     if l_row = 0 then
     begin
       l_oldalign := settextalign(canvas.handle, ta_center);
       l_XPos := rect.left + (rect.right - rect.left) div 2;
       s := cells[l_col, l_row];
       while s <> '' do
       begin
         if pos(#13, s) <> 0 then
         begin
           if pos(#13, s) = 1 then
             s1 := ''
           else
           begin
             s1 := trim(copy(s, 1, pred(pos(#13, s))));
             delete(s, 1, pred(pos(#13, s)));
           end;
           delete(s, 1, 2);
         end
         else
         begin
           s1 := trim(s);
           s := '';
         end;
         l_YPos := rect.top + 2;
         canvas.textrect(rect, l_Xpos, l_YPos, s1);
         inc(rect.top, rowheights[l_row] div 3);
       end;
       settextalign(canvas.handle, l_oldalign);
     end
     else
     begin
       canvas.textrect(rect, rect.left + 2, rect.top + 2, cells[l_col, l_row]);
     end;
 
     canvas.font.style := canvas.font.style - [fsbold];
   end;
 end;
 




Многострочный TStringGrid 2

Как известно, Гай Юлий Цезарь умел делать несколько дел одновременно, но при этом ужасно тормозил процесс демократизации империи, за что и был убит своим лучшим другом - Хомой Брутом.
Вопрос: нужна ли нам истинная многозадачность такой ценой?


  procedure TForm1.grid1DrawCell(Sender: TObject; Col, Row: Longint;
    Rect: TRect; State: TGridDrawState);
 
   var l_oldalign : word;
       l_YPos,l_XPos,i : integer;
       s,s1 : string;
       l_col,l_row :longint;
 
  begin
    l_col := col;
    l_row := row;
    with sender as tstringgrid do
    begin
      if (l_row=0) then
        canvas.font.style:=canvas.font.style+[fsbold];
      if l_row=0 then
      begin
        l_oldalign:=settextalign(canvas.handle,ta_center);
        l_XPos:=rect.left + (rect.right - rect.left) div 2;
        s:=cells[l_col,l_row];
        while s<>'' do
        begin
          if pos(#13,s)<>0 then
          begin
            if pos(#13,s)=1 then
              s1:=''
            else
            begin
              s1:=trim(copy(s,1,pred(pos(#13,s))));
              delete(s,1,pred(pos(#13,s)));
            end;
            delete(s,1,2);
          end
          else
          begin
            s1:=trim(s);
            s:='';
          end;
          l_YPos:=rect.top+2;
          canvas.textrect(rect,l_Xpos,l_YPos,s1);
          inc(rect.top,rowheights[l_row] div 3);
        end;
        settextalign(canvas.handle,l_oldalign);
      end
      else
      begin
         canvas.textrect(rect,rect.left+2,rect.top+2,cells[l_col,l_row]);
      end;
 
      canvas.font.style:=canvas.font.style-[fsbold];
    end;
  end;
 




TTreeView с возможностью MultiSelect

TSelectableTree - TTreeView с возможностью MultiSelect'а

TSelectableTree - наследник от TCustomTreeView, обладает возможностью множественного выбора ( свойство MultiSelect ).

Соответственно дополнительные методы -

procedure SelectAll;
procedure UnSelectAll;
procedure InvertSelection;

Свойство DefaultPopup = True назначает для дерева PopUp-меню (по правой кнопке мыши) со следующими пунктами:

Отметить все
Снять все пометки
Инверсия выделения

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


 procedure TraverseTree(TreeView: TCustomTreeView; Node: TTreeNode;
   ATraverseTreeEvent : TTVTraverseEvent; AInfo : Pointer);
 var
   CNode: TTreeNode;
 begin
   if Assigned(ATraverseTreeEvent) then begin
     if Node = nil
       then CNode := TTreeView(TreeView).Items.GetFirstNode
       else CNode := Node;
     repeat
       ATraverseTreeEvent(CNode, AInfo);
       CNode := CNode.GetNext;
     until (CNode = nil) or (not CNode.HasAsParent(Node));
   end;
 end;
 




Многострочность в заголовках колонок StringGrid

Автор: Rick Rogers

У меня есть StringGrid, который выглядит очень красивым, за исключением заголовков колонок, где я хотел бы иметь их размер равным 1 ячейке, но с заголовком, размещенным в нескольких строках, например,

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

Рисовать сами ячейки вы можете в обработчике события OnDrawCell. Для определения ячейки (заголовок?), обрабатываемой в текущий момент, используйте параметр GridState.

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


 TFTVerticalAlignment = (vaTop, vaMiddle, vaBottom);
 
 procedure DrawTextAligned(const Text: string; Canvas: TCanvas; ъ
   var Rect: TRect; Alignment: TAlignment; VerticalAlignment:
   TFTVerticalAlignment; WordWrap: Boolean);
 var
   P: array[0..255] of Char;
   H: Integer;
   T: TRect;
   F: Word;
 begin
   StrPCopy(P, Text);
   T := Rect;
   with Canvas, Rect do
   begin
     F := DT_CALCRECT or DT_EXPANDTABS or DT_VCENTER or
       TextAlignments[Alignment];
     if WordWrap then
       F := F or DT_WORDBREAK;
     H := DrawText(Handle, P, -1, T, F);
     H := MinInt(H, Rect.Bottom - Rect.Top);
     if VerticalAlignment = vaMiddle then
     begin
       Top := ((Bottom + Top) - H) div 2;
       Bottom := Top + H;
     end
     else if VerticalAlignment = vaBottom then
       Top := Bottom - H - 1;
     F := DT_EXPANDTABS or DT_VCENTER or TextAlignments[Alignment];
     if WordWrap then
       F := F or DT_WORDBREAK;
     DrawText(Handle, P, -1, Rect, F);
   end;
 end;
 




Понимание много-поточности в VCL для веб-серверных ISAPI-расширений

Поймал Иван-дурак в проруби щуку. Та ему:
- Отпусти ты меня, Иван, и любое твое желание по-щучьму велению, по твоему хотению будет исполнено! Обрадовался Ванюха, кинул щуку обратно в прорубь и говорит:
- Хочу знать, не слезая с печи, все что в мире творится за лесами-за горами, за морями-окиянами. Хочу под музыку балдеть, на голых девок день и ночь пялиться, с заморскими дураками переписываться и все новые анекдоты про Царя-батюшку первому в мире узнавать! Так Иван-дурак стал первым на Руси пользователем Интернета.

В среде Delphi можно создавать высокоэффективные веб-серверные ISAPI-расширения на основе технологии WebBroker. Создайте проект с помощью мастера (New -> Web Server Application - ISAPI DLL). Прилагаемая справочная документация, а так же демонстрационный пример "$(DELPHI)\Demos\Webserv" позволяют достаточно быстро освоиться в приемах написания веб-серверных ISAPI-расширений. На выходе у вас получится обычная DLL (далее по тексту - библиотека).

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

Согласно спецификации ISAPI-расширений, созданная библиотека имеет всего три экспортируемые функции: GetExtensionVersion, HttpExtensionProc, TerminateExtension. Нас интересует только HttpExtensionProc, через которую выполняется вся работа: получение запросов с веб-сервера (Request), обработка и обратная отправка результата (Response).

Итак, рассмотрим весь путь прохождения данных. Запрос веб-сервера поступает через экспортируемую библиотекой функцию HttpExtensionProc в TISAPIApplication через инкапсулированный метод с одноименным названием (объект Application, как и в любом VCL-приложении другого вида, присутствует всегда: создается при инициализации и разрушается при завершении приложения, однако в данном случае имеет тип TISAPIApplication):


 function TISAPIApplication.HttpExtensionProc
 (var ECB: TEXTENSION_CONTROL_BLOCK): DWORD;
 var
   HTTPRequest: TISAPIRequest;
   HTTPResponse: TISAPIResponse;
 begin
   try
     HTTPRequest := NewRequest(ECB);
     try
       HTTPResponse := NewResponse(HTTPRequest);
       try
         if HandleRequest(HTTPRequest, HTTPResponse) then
           Result := HSE_STATUS_SUCCESS
         else
           Result := HSE_STATUS_ERROR;
       finally
         HTTPResponse.Free;
       end;
     finally
       HTTPRequest.Free;
     end;
   except
     HandleServerException(Exception(ExceptObject), ECB);
     Result := HSE_STATUS_ERROR;
   end;
 end;
 

Из приведенного кода видно, что переменные HTTPRequest и HTTPResponse объявлены локально, и объекты соответствующих типов создаются для каждого поступающего запроса веб-сервера. После инициализации этих переменных обработка переходит к TWebApplication.HandleRequest:


 function TWebApplication.HandleRequest(Request: TWebRequest;
 Response: TWebResponse): Boolean;
 var
   DataModule: TDataModule;
   Dispatcher: TCustomWebDispatcher;
   I: Integer;
 begin
   Result := False;
   DataModule := ActivateWebModule;
   if DataModule <> nil then
     try
       if DataModule is TCustomWebDispatcher then
         Dispatcher := TCustomWebDispatcher(DataModule)
       else
         with DataModule do
         begin
           Dispatcher := nil;
           for I := 0 to ComponentCount - 1 do
           begin
             if Components[I] is TCustomWebDispatcher then
             begin
               Dispatcher := TCustomWebDispatcher(Components[I]);
               Break;
             end;
           end;
         end;
       if Dispatcher <> nil then
       begin
         Result := TWebDispatcherAccess(Dispatcher).DispatchAction(Request, Response);
         if Result and not Response.Sent then
           Response.SendResponse;
       end
       else
         raise Exception.CreateRes(@sNoDispatcherComponent);
     finally
       DeactivateWebModule(DataModule);
     end;
 end;
 

Тут следующая хитрость: локально объявленная переменная DataModule получает ссылку на объект от метода TWebApplication.ActivateWebModule. Для каждого потока предоставляется неиспользуемый в настоящее время другими потоками объект типа TDataModule, для чего выполняется перемещение этих объектов между списками FInactiveWebModules и FActiveWebModules. Если список FInactiveWebModules исчерпан, то создается новый экземпляр объекта типа TDataModule. В результате этих манипуляций для каждого потока используется собственный экземпляр объекта типа TDataModule, и разработчик может быть уверен в поточно-безопасном объявлении полей данных своего объекта TWebModule! Но это еще не все.

Локально объявленные в TISAPIApplication.HttpExtensionProc переменные HTTPRequest и HTTPResponse, о которых говорилось выше, переданы методу TWebApplication.HandleRequest в качестве параметров Request и Response, который в свою очередь передает их методу TCustomWebDispatcher.DispatchAction:


 function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
 Response: TWebResponse): Boolean;
 var
   I: Integer;
   Action, default: TWebActionItem;
   Dispatch: IWebDispatch;
 begin
   FRequest := Request;
   FResponse := Response;
   {...}
 end;
 

Тут выполняется присваивание переменных Request и Response полям объекта TWebModule (как наследнику TCustomWebDispatcher). А нам уже известно, что экземпляр объекта TWebModule у каждого потока - собственный. Теперь посмотрим правде в глаза: у каждого запроса веб-сервера есть собственные экземпляры объектов TRequest и TResponse в полях TWebModule.Request и TWebModule.Response; и они поточно-безопасны.

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

Как видно из приведенного выше фрагмента кода TWebApplication.HandleRequest - DataModule передается в качестве параметра методу TWebApplication.DeactivateWebModule, в котором может быть переведен в список FInactiveWebModules, или вовсе разрушен (если выключено свойство CacheConnections - этим не стоит пользоваться без необходимости, так как существенно снижается производительность обработки запросов). После чего обработка возвращается к TISAPIApplication.HttpExtensionProc и ответ передается веб-серверу вызовом Response.SendResponse.

Отдельно следует отметить. Мне несколько раз попадались на глаза рекомендации устанавливать глобальную переменную IsMultiThread к True в dpr-файл проекта - этого делать не нужно, т.к. в конструкторе TWebApplication эта работа уже выполняется!

Если вы используете доступ к BDE посредством наследников TBDEDataSet (TTable, TQuery, TStoredProc) то все что вам нужно сделать для обеспечения поточно-безопасности, это присвоить в конструкторе TWebModule: Session.AutoSessionName := True (подробнее смотри в справочной документации: "Managing multiple sessions").

Реализация инкапсуляции WinSock в компонентах TClientSocket и TServerSocket, которые вам могут потребоваться, так же поточно-безопасна.

Конечно, если используется файловый ввод-вывод, а так же прямые вызовы WinSock, то тогда все же нужно выполнять много-поточную защиту самостоятельно и вам все же придется прочитать раздел документации "Programming with Delphi - Using threads". :-)

Замечание: изложенное выше относится к Delphi 5.




Выполнить код, когда приложение простаивает


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Edit1: TEdit;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   private
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
     procedure MyIdleHandler(Sender: TObject; var done: Boolean);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 { TForm1 }
 
 procedure TForm1.MyIdleHandler(Sender: TObject; var done: Boolean);
 begin
   // do something here 
   // hier irgendwas tun 
   Self.Left  := Random(Screen.Width - Self.Width);
   Self.Top   := Random(Screen.Height - Self.Height);
   Edit1.Text := TimeToStr(now);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   dt, dtn: TDateTime;
 begin
   // simulate heavy calculatin with this button 
   // umfangreiche Berechnungen simulieren 
   dt := Now;
   repeat
     dtn := Now;
   until dtn > (dt + 10 / 3600 / 24);
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // assign the Handler to OnIdle of the Application 
   // den Handler dem OnIdle von Application zuweisen 
   Application.OnIdle := MyIdleHandler;
 end;
 
 end.
 




Как узнать IP машины по имени

Школьный учитель спрашивает учеников о профессии родителей.
- Тим, чем твоя мама занимается на работе?
Тим встает и гордо говорит:
- Она - доктор.
- Замечательно, ну как насчет тебя, Эмми?
Девочка стеснительно произносит:
- Мой папа разносит почту.
- Спасибо, Эмми, - говорит учитель. - Ну, а твои родители что делают, Билл? Билл гордо встает и объявляет:
- Мой папа играет музыку в борделе!
Обалдевший учитель решил направиться к Биллу домой.
- В каких условиях вы растите ребенка? - спрашивает он у отца.
Тот отвечает:
- Вообще-то я программист и специализируюсь на TCP/IP коммуникационном протоколе в системе UNIX. Ну как объяснить это семилетнему пацану?


 uses
   WinSock;
 
 const
   WINSOCK_VERSION = $0101;
 
 function GetIPAddress(name: string): string;
 var
   WSAData: TWSAData;
   p: PHostEnt;
 begin
   WSAStartup(WINSOCK_VERSION, WSAData);
   p := GetHostByName(PChar(name));
   Result := inet_ntoa(PInAddr(p.h_addr_list^)^);
   WSACleanup;
 end;
 




Маленькая область заголовка

Автор: Neil

Вам необходима небольшая область заголовка подобно той, которую использует Microsoft для управления палитры в VB, правильно? Около 1/3 от высоты нормальной области заголовка, без текста и без блока системных кнопок? Хорошо, я могу дать вам небольшой пример.

  1. Создайте вторичную форму и установите BorderStyle в bsSingle
  2. Разместите на форме компонент Label, удалите значение свойства Caption, установите Color в clBlue и Align в alTop. Задайте высоту компонента такую, какую высоту заголовка вы хотите
  3. Добавьте следующие два метода к вашей форме:


     PROCEDURE TForm2.CreateParams(VAR Params: TCreateParams);
     BEGIN
       Inherited CreateParams(Params);
       WITH Params DO
         Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
     END;
     
     PROCEDURE TForm2.wmNCHitTest(VAR Msg: TWMNCHitTest);
     BEGIN
       Inherited;
       WITH Msg DO
         IF YPos-Top <= Label2.Height THEN
           Result := HTCAPTION;
     END;
     

  4. Объявите эти функции в секции private вашего модуля:

  5.  PROCEDURE CreateParams(VAR Params: TCreateParams); override;
     PROCEDURE wmNCHitTest(VAR Msg: TWMNCHitTest);
       message WM_NCHITTEST;
     

    Установите свойство вторичной формы Visible в True. Теперь у вас есть плавающее окно с мальнокой областью заголовка. Для создания также "небольшого" системного меню, НАРИСУЙТЕ его на форме и в ответ на событие WM_NCHITTEST установите Result в HTSYSMENU, если мышь в пределах области заголовка.




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


Попадают Гейтс, Клинтон и Гор в рай. Бог их и спрашивает:
- Ну во что вы верите? Клинтон:
- Ну я верю в демократию и т.д. Бог:
- Молодец, садись по мою правую руку, а ты Гор во что веришь? Гор:
- Ну я верю в то что есть проблема глобального потепления и экологии. Бог:
- Правильно веришь, садись по левую мою руку. Ну а во что веришь ты, Гейтс? Гейтс:
- Хе-хе, мне кажется я верю что вы сидите на моем месте.

В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, CommCtrl, ComCtrls, StdCtrls;
 
 type
   TMyTrackBar = class(TTrackBar)
     procedure CreateParams(var Params: TCreateParams); override;
   end;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
   MyTrackbar : TMyTrackbar;
 
 implementation
 {$R *.DFM}
 
 procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
 begin
   inherited;
   Params.Style := Params.Style and not TBS_ENABLESELRANGE;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   MyTrackBar := TMyTrackbar.Create(Form1);
   MyTrackbar.Parent := Form1;
   MyTrackbar.Left := 100;
   MyTrackbar.Top := 100;
   MyTrackbar.Width := 150;
   MyTrackbar.Height := 45;
   MyTrackBar.Visible := true;
 end;
 
 end.
 




Естественные ключи против искусственных ключей

Переехал программист из России в Северную Америку. Посылает своим родственникам оттуда посылку. Родственники удивилиcь - он обычно только на Новый Год посылки шлет, а тут до Нового Года еще 2 месяца, да и посылка еще в такой коробке, что слона можно поместить. вскрывают коробку, она оказывается изнутри пустая, только на самом дне какая то бумажка лежит. Достают они ее и видят что на бумажке написано: "Test".

Данная статья излагает взгляд автора на проблему, регулярно обсуждающуюся в группах новостей, посвящённых разработке приложений с использованием РСУБД.

О сущности проблемы

Каждая запись в таблице, входящей в РСУБД, должна иметь первичный ключ (ПК) - набор атрибутов, уникально идентифицирующий её в таблице. Случай, когда таблица не имеет первичного ключа, имеет право на существование, однако в данной статье не рассматривается.

В качестве первичного ключа может использоваться:

  • Естественный Ключ (ЕК) - набор атрибутов описываемой записью сущности, уникально её идентифицирующий (например, номер паспорта для человека);
  • Суррогатный Ключ (СК) - автоматически сгенерированное поле, никак не связанное с информационным содержанием записи. Обычно в роли СК выступает автоинкрементное поле типа INTEGER.

Есть два мнения:

  • СК должны использоваться, только если ЕК не существует. Если же ЕК существует, то идентификация записи внутри БД осуществляется по имеющемуся ЕК;
  • СК должны добавляться в любую таблицу, на которую существуют ссылки (REFERENCES) из других таблиц, и связи между ними должны организовываться только при помощи СК. Разумеется, поиск записи и представление её пользователю по прежнему производятся на основании ЕК.

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

Когда появляются СК

Для понимания места и значения СК рассмотрим этап проектирования, на котором они вводятся в структуру БД, и методику их введения.

Для ясности рассмотрим БД из 2-х отношений - Города (City) и Люди (People) Предполагаем, что город характеризуется Hазванием (Name), все города имеют разные названия, человек характеризуется Фамилией (Family), номером паспорта (Passport) и городом проживания (City). Также полагаем, что каждый человек имеет уникальный номер паспорта. Hа этапе составления инфологической модели БД её структура одинакова и для ЕК и для СК.


 CREATE TABLE City(
   name VARCHAR(30) not NULL PRIMARY KEY
 );
 
 CREATE TABLE People(
   Passport CHAR(9) not NULL PRIMARY KEY,
   Family VARCHAR(20) not NULL,
   City VARCHAR(30) not NULL REFERENCES City(name)
 );
 

Для ЕК все готово. Для СК делаем еще один этап и преобразуем таблицы следующим образом:


 CREATE TABLE City(
   /*
   В разных диалектах языка SQL автоинкрементное поле будет выражено по-разному -
   например, через IDENTITY, SEQUENCE или GENERATOR.
   Здесь мы используем условное обозначение AUTOINCREMENT.
   */
   Id INT not NULL AUTOINCREMENT PRIMARY KEY
   name VARCHAR(30) not NULL UNIQUE
 );
 
 CREATE TABLE People(
   Id INT not NULL AUTOINCREMENT PRIMARY KEY,
   Passport CHAR(9) not NULL UNIQUE,
   Family VARCHAR(20) not NULL,
   CityId INT not NULL REFERENCES City(Id)
 );
 

Обращаю внимание, что:

Все условия, диктуемые предметной областью (уникальность имени города и номера паспорта) продолжают присутствовать в БД, только обеспечиваются не условием PRIMARY KEY, а условием UNIQUE;

Ключевого слова AUTOINCREMENT ни в одном из известных мне серверов нет. Это просто обозначение, что поле генерируется автоматически.

В общем случае алгоритм добавления СК выглядит следующим образом:

  • В таблицу добавляется поле INTEGER AUTOINCREMENT;
  • Оно объявляется PRIMARY KEY;
  • Старый PRIMARY KEY (ЕК) заменяется на UNIQUE CONSTRAINT ;

Если в таблице есть REFERENCES на другие таблицы, то поля, входящие в REFERENCES, заменяются на одно поле типа INTEGER, составляющее первичный ключ (как People.City заменена на People.CityId).

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

Зачем всё это надо

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

Упрощение сопровождения

Это область, где СК демонстрируют наибольшие преимущества. Поскольку операции связи между таблицами отделены от логики "внутри таблиц" - и то и другое можно менять независимо и не затрагивая остального.

Hапример - выяснилось, что города имеют дублирующиеся названия. Решено ввести в City еще одно поле - Регион (Region) и сделать ПК (City, Region). В случае ЕК - изменяется таблица City, изменяется таблица People - добавляется поле Region (да, да, для всех записей, про размеры молчу), переписываются все запросы, в том числе на клиентах, в которых участвует City, в них добавляются строка AND XXX.Region = City.Region.

Да, чуть не забыл, большинство серверов сильно не любят ALTER TABLE на поля, входящие в PRIMARY KEY и FOREIGN KEY.

В случае СК - добавляется поле в City, изменяется UNIQUE CONSTRAINT. Всё.

Еще пример - в случае СК изменение списка полей в SELECT никогда не заставляет переписывать JOIN. В случае ЕК - добавилось поле, не входящее в ПК связанной таблицы - переписывайте.

Еще пример - поменялся тип данных поля, входящего в ЕК. И опять переделки кучи таблиц, заново оптимизация индексов...

В условиях меняющегося законодательства это достоинство СК само по себе достаточно для их использования.

Уменьшение размера БД

Предположим в нашем примере, что средняя длина названия города - 10 байт. Тогда на каждого человека в среднем будет приходиться 10 байт для хранения ссылки на город (реально несколько больше за счёт служебной информации на VARCHAR и гораздо больше за счёт индекса по People.City, который придётся построить, чтобы REFERENCES работала эффективно). В случае СК - 4 байта. Экономия - минимум 6 байт на человека, приблизительно 10 Мб для г. Hовосибирска. Очевидно, что в большинстве случаев уменьшение размера БД - не самоцель, но это, очевидно, приведет и к росту быстродействия.

Звучали аргументы, что БД может сама оптимизировать хранение ЕК, подставив вместо него в People некую хэш-функцию (фактически создав СК сама). Hо ни один из реально существующих коммерческих серверов БД так не делает, и есть основания полагать, что и не будет делать. Простейшим обоснованием такого мнения является то, что при подобной подстановке банальные операторы ADD CONSTRAINT … FOREIGN KEY или DROP CONSTRAINT … FOREIGN KEY будут приводить к нешуточной перетряске таблиц, с ощутимым изменением всей БД (надо будет физически добавить или удалить (с заменой на хэш-функцию)) все поля, входящие в CONSTRAINT.

Увеличение скорости выборки данных

Вопрос достаточно спорный, однако, исходя из предположений, что:

  • База данных нормализована;
  • Записей в таблицах много (десятки тысяч и более);

Запросы преимущественно возвращают ограниченные наборы данных (максимум единицы процентов от размера таблицы).

быстродействие системы на СК будет ощутимо выше. И вот почему:

ЕК могут потенциально дать более высокое быстродействие, когда:

  • Требуется только информация, входящая в первичные ключи связанных таблиц;
  • нет условий WHERE по полям связанных таблиц.

Т.е., в нашем примере это запрос типа:


 SELECT Family, City FROM People;
 

В случае СК этот запрос будет выглядеть как


 SELECT P.Family, C.Name
 FROM People P INNER JOIN City C ON P.CityId = C.Id;
 

Казалось бы, ЕК дает более простой запрос с меньшим количеством таблиц, который выполнится быстрее. Hо и тут не всё так просто: размеры таблиц для ЕК - больше (см. выше) и дисковая активность легко съест преимущество, полученное за счёт отсутствия JOIN`а. Ещё сильнее это скажется, если при выборке данных используется их фильтрование (а при сколько-либо существенном объеме таблиц оно используется обязательно). Дело в том, что поиск, как правило, осуществляется по информативным полям типа CHAR, DATETIME и т.п. Поэтому часто бывает быстрее найти в справочной таблице набор значений, ограничивающий возвращаемый запросом результат, а затем путем JOIN`а по быстрому INTEGER-индексу отобрать подходящие записи из большой таблицы. Например:


 (ЕК) SELECT Family, City FROM People WHERE City = 'Иваново';
 

будет выполняться в разы медленнее, чем


 (CК) SELECT P.Family, C.Name
 FROM People P INNER JOIN City C ON P.CityId = C.Id
 WHERE C.Name = 'Иваново';
 

В случае ЕК - будет INDEX SCAN большой таблицы People по CHARACTER-индексу. В случае СК - INDEX SCAN меньшей CITY и JOIN по эффективному INTEGER индексу.

А вот если заменить = 'Иваново' на LIKE '%ваново', то речь пойдет о торможении ЕК относительно СК на порядок и более.

Аналогично, как только в случае с ЕК понадобится включить в запрос поле из City, не входящее в её первичный ключ - JOIN будет осуществлятся по медленному индексу и быстродействие упадет ощутимо ниже уровня СК. Выводы каждый может делать сам, но пусть он вспомнит, какой процент от общего числа его запросов составляют SELECT * FROM ЕдинственнаяТаблица. У меня - ничтожно малый.

Да, сторонники ЕК любят проводить в качестве достоинства "информативность таблиц", которая в случае ЕК растет. Ещё раз повторю, что максимальной информативностью обладает таблица, содержащая всю БД в виде flat-file. Любое "повышение информативности таблиц" есть увеличение степени дублирования в них информации, что не есть хорошо.

Увеличение скорости обновления данных

INSERT
Hа первый взгляд ЕК быстрее - не надо при INSERT генерировать лишнего поля и проверять его уникальность. В общем-то так оно и есть, хотя это замедление проявляется только при очень высокой интенсивности транзакций. Впрочем и это неочевидно, т.к. некоторые серверы оптимизируют вставку записей, если по ключевому полю построен монотонно возрастающий CLUSTERED индекс. В случае СК это элементарно, в случае ЕК - увы, обычно недостижимо. Кроме этого, INSERT в таблицу на стороне MANY (который происходит чаще) пойдет быстрее, т.к. REFERENCES будут проверяться по более быстрому индексу.
UPDATE
При обновлении поля, входящего в ЕК, придётся каскадно обновить и все связанные таблицы. Так, переименование Ленинграда в Санкт-Петербург потребует с нашем примере транзакции на несколько миллионов записей. Обновление любого атрибута в системе с СК приведет к обновлению только одной записи. Очевидно, что в случае распределенной системы, наличия архивов и т.п. ситуация только усугубится. Если обновляются поля не входящие в ЕК – быстродействие будет почти одинаковым.
Еще о CASCADE UPDATE
Далеко не все серверы БД поддерживают их на декларативном уровне. Аргументы "это у вас сервер кривой" в этом случае вряд ли корректны. Это вынуждает писать отдельную логику для обновления, что не всегда просто (приводился хороший пример - при отсутствии CASCADE UPDATE обновить поле, на которое есть ссылки, вообще невозможно - надо отключать REFERENCES или создавать копию записи, что не всегда допустимо (другие поля могут быть UNIQUE)).
DELETE
В случае СК будет выполняться быстрее, по той простой причине, что проверка REFERENCES пойдет по быстрому индексу.

А есть ли хорошие ЕК?

Hичто не вечно под Луной. Самый, казалось бы, надежный атрибут вдруг отменяется и перестаёт быть уникальным (далеко ходить не буду - рубль обычный и рубль деноминированный, примерам несть числа). Американцы ругаются на неуникальность номера социального страхования, Microsoft - на китайские серые сетевые платы с дублирующимися MAC-адресами, которые могут привести к дублированию GUID, врачи делают операции по смене пола, а биологи клонируют животных. В этих условиях (и учитывая закон неубывания энтропии) закладывать в систему тезис о неизменности ЕК - закладывать под себя мину. Их надо выделять в отдельный логический слой и по возможности изолировать от остальной информации. Так их изменение переживается куда легче. Да и вообще: однозначно ассоциировать сущность с каким-то из атрибутов этой сущности - ну, странно, что-ли. Hомер паспорта ещё не есть человек. СК же - это некая субстанция, именно и означающая сущность. Именно сущность, а не какой-то из её атрибутов.

Типичные аргументы сторонников ЕК

В системе с СК не осуществляется контроль правильности ввода информации

Это не так. Контроль не осуществлялся бы, если бы на поля, входящие в ЕК не было наложено ограничение уникальности. Очевидно, что если предметная область диктует какие-то ограничения на атрибуты ЕК, то они будут отражены в БД в любом случае.

В системе с ЕК меньше JOIN`ов, следовательно, запросы проще и разработка удобнее

Да, меньше. Hо, в системе с СК тривиально пишется:


 CREATE VIEW PeopleEK AS
 SELECT P.Family, P.Passport, C.Name
 FROM People P INNER JOIN City C ON P.CityId = C.Id
 

И можно иметь все те же прелести. С более, правда, высоким быстродействием. При этом неплохо упомянуть, что в случае ЕК многим придется программировать каскадные операции, и, не дай Бог в распределённой среде, бороться с проблемами быстродействия. Hа фоне этого "короткие" запросы уже не кажутся столь привлекательными.

Введение ЕК нарушает третью нормальную форму

Вспомним определение:

Таблица находится в третьей нормальной форме (3НФ), если она удовлетворяет определению 2НФ, и ни одно из её неключевых полей не зависит функционально от любого другого неключевого поля.

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

Итак:

Таблица находится в нормальной форме Бойса-Кодда (НФБК), если и только если любая функциональная зависимость между его полями сводится к полной функциональной зависимости от возможного ключа.

Таким образом, таблица, имеющая СК, легко может быть нормализована хоть до 5НФ. Точнее будет сказать, что СК к нормализации не имеют никакого отношения. Более того, введение СК уменьшает избыточность данных в БД, что вообще хорошо согласуется с идеологией нормализации. В сущности, нормализация и есть уменьшение информативности отдельных таблиц по определенным правилам. Только СК устраняют аномалии не внутри таблицы, а на межтабличном уровне (типа устранения каскадных обновлений). Так сказать, система с СК - святее Папы Римского :-). В самом деле – ситуация, когда при изменении одного из полей таблицы приходится изменять содержимое этого же поля в других записях ЭТОЙ ЖЕ таблицы, рассматривается как аномалия обновления. Но в системе с ЕК придется проделать то же самое В СВЯЗАННОЙ таблице при изменении ключевого атрибута на стороне 1 отношения 1:N. Очевидно, что эта ситуация с точки зрения физической реализации БД ничем не лучше. В системе с СК таких ситуаций не возникает.

Таблицы в системе с ЕК информативнее

Максимальной информативностью обладает таблица, содержащая всю БД в виде flat-file. Любое "повышение информативности таблиц" есть увеличение степени дублирования в них информации, что не обязательно есть хорошо. Да и вообще термин "Информативность таблицы" сомнителен. Видимо, более важна информативность БД, которая в обоих случаях одинакова.

Заключение:

В общем-то, выводы очевидны – введение СК позволяет получить лучше управляемую, более компактную и быстродействующую БД. Разумеется, это не панацея. В некоторых случаях (например, таблица на которую нет REFERENCES и в которую осуществляется интенсивная вставка данных и т.п.) более верно использовать ЕК или не использовать ПК вообще (последнее категорически противопоказано для многих РСУБД и средств разработки клиентских приложений). Но речь шла именно о типовой методике, которую надо рекомендовать к применению в общем случае. Уникальные ситуации могут потребовать уникальных же решений (иногда и нормализацией приходится поступаться).




Добавление элементов управления в TTabbedNotebook и TNotebook

Я несколько раз видел в конференциях вопросы типа "как мне добавить элементы управления в TTabbedNotebook или TNotebook во время выполнения программы?". Теперь, когда у меня выдалось несколько свободных минут, я попытаюсь осветить этот вопрос как можно подробнее:

TTabbedNotebook

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

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

Первым шагом к раскрытию тайны послужит просмотр файла \DELPHI\DOC\TABNOTBK.INT, интерфейсной секции модуля TABNOTBK.PAS, в котором определен класс TTabbedNotebook. Беглый просмотр позволяет обнаружить класс TTabPage, описанный как хранилище элементов управления отдельной страницы TTabbedNotebook.

Вторым шагом в исследовании TTabbedNotebook может стать факт наличия свойством Pages типа TStrings. В связи с этим отметим, что Delphi-классы TStrings и TStringList соорганизуются с двумя свойствами: Strings и Objects. Другими словами, для каждой строки в TStrings есть указатель на соответствующий Objects. Во многих случаях этот дополнительный указатель игнорируется, нам же он очень пригодится.

После небольшого эксперимента выясняем, что свойство Objects указывает на нашу копию TTabPage и ссылается на имя страницы в свойстве Strings. Блестяще! Всегда полезно знать что ищешь. Теперь посмотрим что мы можем сделать:


 { Данная процедура добавляет кнопку в случайной позиции на }
 { текущей странице данного TTabbedNotebook.                }
 
 procedure AddButton(tabNotebook: TTabbedNotebook);
 var
   tabpage: TTabPage;
   button: TButton;
 begin
   with tabNotebook do
     tabpage := TTabPage(Pages.Objects[PageIndex]);
   button := TButton.Create(tabpage);
   try
     with button do
     begin
       Parent := tabpage;
       Left := Random(tabpage.ClientWidth - Width);
       Top := Random(tabpage.ClientHeight - Height);
     end;
   except
     button.Free;
   end;
 end;
 

TNotebook

Операция по заполнению элементами управления компонента TNotebook почти такая же, как и в TTabbedNotebook - разница лишь в типе класса - TPage вместо TTabPage. Тем не менее, если вы заглянете в DELPHI\DOC\EXTCTRLS.INT, декларацию класса TPage вы там не найдете. По неизвестной причине Borland не включил определение TPage и в DOC-файлы, поставляемые с Delphi. Декларация TPage в EXTCTRLS.PAS (можно найти в библиотеке VCL-исходников), правда, расположена в интерфейсной части модуля. Мы восполним пропущенную информацию о классе TPage:


 TPage = class(TCustomControl)
 private
   procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
 protected
   procedure ReadState(Reader: TReader); override;
   procedure Paint; override;
 public
   constructor Create(AOwner: TComponent); override;
 published
   property Caption;
   property Height stored False;
   property TabOrder stored False;
   property Visible stored False;
   property Width stored False;
 end;
 

Теперь, по аналогии с вышеприведенной процедурой, попробуем добавить кнопку на TNotebook. Все, что мы должны сделать - заменить "TTabbedNotebook" на "TNotebook" и "TTabPage" на "TPage". Вот что должно получиться:


 { Данная процедура добавляет кнопку в случайной позиции на }
 { текущей странице данного TNotebook.                      }
 
 procedure AddButton(Notebook1: TNotebook);
 var
   page: TPage;
   button: TButton;
 begin
   with Notebook1 do
     page := TPage(Pages.Objects[PageIndex]);
   button := TButton.Create(page);
   try
     with button do
     begin
       Parent := page;
       Left := Random(page.ClientWidth - Width);
       Top := Random(page.ClientHeight - Height);
     end;
   except
     button.Free;
   end;
 end;
 

Остальное не менее просто!




Негатив картинки

Надрали одного хакера в зад, тот жалуетсяа корешу:
- Вот, типа, поймали меня на улице геи и в зад отымели. Теперь в ж#пе дырка как у слона во рту.
А корешь ему и отвечает:
- Зазипуй!


 var
   Line: pByteArray;
   i, j: integer;
 begin
   // считываем высоту картинки
   for i := 0 to Image1.Picture.Bitmap.Height - 1 do
   begin
     //сканируем по линиям рисунок
     Line := Image1.Picture.Bitmap.ScanLine[i];
     for j := 0 to Image1.Picture.Bitmap.Width * 3 - 1 do
       //меняем цвет на обратный исходя из RGB
       Line^[j] := 255 - Line^[j];
   end;
   Image1.Refresh;
 end;
 




Обмен информацией между программами в сети по почтовым каналам


Автор: Chudin A.V

Как реализовать обмен информацией между Вашими приложениями в сети? ОС Windows предлагает несколько технологий. Эта статья опишет один очень простой и надежный способ для Win9x/NT - MailSlots.

The CreateMailslot function creates a mailslot with the specified name and returns a handle that a mailslot server can use to perform operations on the mailslot. The mailslot is local to the computer that creates it. An error occurs if a mailslot with the specified name already exists.

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

CreateMailslot
создание почтового канала;
GetMailslotInfo
определение наличия сообщения в канале;
ReadFile
чтение сообщения из канала, как из файла;
WriteFile
запись сообщения в канал, как в файл;

Функции работы с почтовыми каналами присутствуют как в Windows 9x, так и в Windows NT.

Рассмотрим создание почтового канала (сервер).


 //... создание канала с именем MailSlotName - по этому имени к нему
 // будут обращаться клиенты
 h := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName),
 0, MAILSLOT_WAIT_FOREVER,nil);
 
 if h = INVALID_HANDLE_VALUE then
 begin
   raise Exception.Create('MailSlotServer: Ошибка создания канала !');
 

Отправка сообщений по почтовомуо каналу (клиенты).


 if not GetMailSlotInfo(h,nil,DWORD(MsgNext),@MsgNumber,nil) then
 begin
   raise Exception.Create('TglMailSlotServer: Ошибка сбора информации!');
 end;
 
 if MsgNext <> MAILSLOT_NO_MESSAGE then
 begin
   beep;
   // чтение сообщения из канала и добавление в текст протокола
   if ReadFile(h,str,200,DWORD(read),nil) then
     MessageText := str
   else
     raise Exception.Create('TglMailSlotServer: Ошибка чтения сообщения !');
 end;
 

Все очень просто. Теперь для удобства использования создадим два компонента - клиент и сервер


 {
 Globus Delphi VCL Extensions Library
 ' GLOBUS LIB '
 Freeware
 Copyright (c) 2000 Chudin A.V, FidoNet: 1246.1
 gl3DCol Unit 05.2000 components TglMailSlotServer, TglMailSlotClient
 }
 unit glMSlots;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, extctrls;
 
 type
   TOnNewMessage = procedure (Sender: TObject; MessageText: string) of object;
 
   TglMailSlotServer = class(TComponent)
   private
     FMailSlotName, FLastMessage: string;
     FOnNewMessage: TOnNewMessage;
 
     Timer: TTimer; //...таймер для прослушивания канала
     h : THandle;
     str : string[250];
     MsgNumber,MsgNext,read : DWORD;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure Open; //...создание канала
     procedure Close; //...закрытие канала
   protected
     procedure Loaded; override;
     procedure OnTimer(Sender: TObject);
   published
     property MailSlotName: string read FMailSlotName write FMailSlotName;
     //...событие получения сообщения
     property OnNewMessage: TOnNewMessage read FOnNewMessage write FOnNewMessage;
   end;
 
 
   TglMailSlotClient = class(TComponent)
   private
     FMailSlotName, FServerName, FLastMessage: string;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     function Send(str: string):boolean; //...отправка сообщения
   protected
     procedure Loaded; override;
     procedure ErrorCatch(Sender : TObject; Exc : Exception);
   published
     property ServerName: string read FServerName write FServerName;
     property MailSlotName: string read FMailSlotName write FMailSlotName;
   end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Gl Components', [TglMailSlotServer, TglMailSlotClient]);
 end;
 
 constructor TglMailSlotServer.Create(AOwner: TComponent);
 begin
   inherited;
   FEnabled := true;
   FMailSlotName := 'MailSlot';
   Timer := TTimer.Create(nil);
   Timer.Enabled := false;
   Timer.OnTimer := OnTimer;
 end;
 
 destructor TglMailSlotServer.Destroy;
 begin
   Timer.Free;
   // закрытие канала
   Close;
   inherited;
 end;
 
 procedure TglMailSlotServer.Loaded;
 begin
   inherited;
   Open;
 end;
 
 procedure TglMailSlotServer.Open;
 begin
   // создание канала с именем MailSlotName - по этому имени к нему
   // будут обращаться клиенты
   h := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName),
   0, MAILSLOT_WAIT_FOREVER,nil);
   //h:=CreateMailSlot('\\.\mailslot\MailSlot', 0, MAILSLOT_WAIT_FOREVER,nil);
 
   if h = INVALID_HANDLE_VALUE then
     raise Exception.Create('TglMailSlotServer: Ошибка создания канала !');
   Timer.Enabled := true;
 end;
 
 procedure TglMailSlotServer.Close;
 begin
   if h <> 0 then
     CloseHandle(h);
   h := 0;
 end;
 
 procedure TglMailSlotServer.OnTimer(Sender: TObject);
 var
   MessageText: string;
 begin
   MessageText := '';
   // определение наличия сообщения в канале
   if not GetMailSlotInfo(h,nil,DWORD(MsgNext),@MsgNumber,nil) then
     raise Exception.Create('TglMailSlotServer: Ошибка сбора информации!');
 
   if MsgNext <> MAILSLOT_NO_MESSAGE then
   begin
     beep;
     // чтение сообщения из канала и добавление в текст протокола
     if ReadFile(h,str,200,DWORD(read),nil) then
       MessageText := str
     else
       raise Exception.Create('TglMailSlotServer: Ошибка чтения сообщения !');
   end;
 
   if (MessageText<>'')and Assigned(OnNewMessage) then
     OnNewMessage(self, MessageText);
 
   FLastMessage := MessageText;
 end;
 
 constructor TglMailSlotClient.Create(AOwner: TComponent);
 begin
   inherited;
   FMailSlotName := 'MailSlot';
   FServerName := '';
 end;
 
 destructor TglMailSlotClient.Destroy;
 begin
   inherited;
 end;
 
 procedure TglMailSlotClient.Loaded;
 begin
   inherited;
   Application.OnException := ErrorCatch;
 end;
 
 procedure TglMailSlotClient.ErrorCatch(Sender : TObject; Exc : Exception);
 var
   UserName: array[0..99] of char;
   i: integer;
 begin
   // получение имени пользователя
   i:=SizeOf(UserName);
   GetUserName(UserName,DWORD(i));
 
   Send('/'+UserName+'/'+FormatDateTime ('hh:mm',Time)+'/'+Exc.message);
   // вывод сообщения об ошибке пользователю
   Application.ShowException(Exc);
 end;
 
 function TglMailSlotClient.Send(str: string):boolean;
 var
   strMess: string[250];
   UserName: array[0..99] of char;
   h: THandle;
   i: integer;
 begin
   // открытие канала : MyServer - имя сервера
   // (\\.\\mailslot\xxx - монитор работает на этом же ПК)
   // xxx - имя канала
   if FServerName = '' then
     FServerName := '.\';
   h:=CreateFile( PChar('\\' + FServerName + '\mailslot\' + FMailSlotName),
   GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
   if h <> INVALID_HANDLE_VALUE then
   begin
     strMess := str;
     // передача текста ошибки (запись в канал и закрытие канала)
     WriteFile(h, strMess, Length(strMess) + 1, DWORD(i), nil);
     CloseHandle(h);
   end;
   Result := h <> INVALID_HANDLE_VALUE;
 end;
 
 end.
 

Компонент TglMailSlotServer создает почтовый канал с именем MailSlotName и принимает входящие сообщения. Компонент TglMailSlotClient отправляет сообщения в канал с именем MailSlotName на машине ServerName.

Эти компонеты входят в состав библиотеки GlobusLib, распространяемой с исходными текстами.




Управление сетевыми каталогами (BDE)

Если два различных пользователя подключают два различных сетевых каталога (net control directories, NCD), но при этом пути к каталогам одинаковые (это не трудно при работе с сетью), BDE думает, что в этом случае используются одни и те же NCD. Это может привести к _огромным_ проблемам.

Если два пользователя подключают один и тот же NCD, но с разными путями, BDE думает что используются два различных NCD и не позволяет второму пользователю редактировать таблицу. Например, пользователь A подключил NCD по пути G:\DATA\BDENET. Пользователь B подключил NCD по пути H:\BDENET, где H: подключен по пути G:\DATA. В этом случае оба пользователя пытаются использовать один и тот же NCD, но BDE не знает об этом.

Если в вышеприведенном примере пользователи используют один и тот же путь, но с различными буквами диска, BDE позволяет работать обоим пользователям, подразумевая, что они используют один и тот же NCD. Так, если пользователь A подключен к G:\DATA\BDENET, а пользователь B к H:\DATA\BDENET, BDE даст работать обоим.

Это полезно в peer-to-peer сети, где сервер также является и рабочей станцией. В этом случае некоторые (какие?) peer-to-peer OS не позволят серверу подключить сетевой диск к самому себе (я не уверен что у них невозможен эквивалент SUBST, но, по крайней мере, у тех OS, которые я знаю, это отсутствует) так что сервер может использовать только диск C: (или D:, или какой-то другой локальный диск), а рабочая станция нет, поскольку сама имеет собственный локальный диск C:.

Richard Davis

Дополнение от Mark Ostroff (Borland):

В дополнение к ИЗУМИТЕЛЬНОМУ ответу Richard'а, пожалуйста помните об одной ОЧЕНЬ важной вещи... НИКОГДА не допускайте ситуации (в ЛЮБОЙ сети), при которой вы имеете нескольких пользователей, имеющих доступ к одним и тем же таблицам, но использующих разные физические NET-файлы. Это создает ОГРОМНЫЕ проблемы, особенно в в корпоративных и peer-to-peer сетях.

Pdox DOS версии 4.0 использует ту же BDE-схему работы с сетью, что и таблицы Paradox. Необходимо учесть несколько важных моментов:

  1. Убедитесь в том, что у вас включена опция BDE Local Share, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE.
  2. Из-за странного поведения при работе с сетевыми каталогами, пути в файле контроля сети Pdox DOS у ваших пользователей должны быть ИДЕНТИЧНЫ BDE путям (например, тот же каталог И та же буква диска). Это должно быть сделано в случае, если и Pdox DOS, и BDE делают общими одни и те же таблицы и запущены ОБА приложения. Это может создать некоторые проблемы с установкой peer-to-peer сетей.
  3. Убедитесь в том, у вас выключена опция BDE Strict Integrity, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE. В противном случае BDE заблокирует пользователей Pdox DOS для редактирования данных в таблицах Paradox (в любом каталоге), у которых установлена опция целостности данных (Referential Integrity).
  4. Убедитесь в том, что номер версии Paradox, имеющийся в настройках BDE, совместим с OLDEST версией Pdox DOS для использования в вашей сети. Установить ее можно, выбрав соответствующий драйвер Paradox в BDE Config Utility и проверив значение в поле LEVEL. Установите номер версии Pdox DOS, округлив его до ближайшего МЕНЬШЕГО целого числа.



Обзор сети (типа Network Neighborhood - Сетевое Окружение)

Сеть - это дырки, связанные веревками.

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


 {
 Сетевая утилита. Аналогична функции NetWork-
 Neighborhood - Сетевое Окружение.
 }
 
 unit netres_main_unit;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,
 
   ComCtrls, StdCtrls, Buttons, Menus, ExtCtrls;
 
 type
 
   TfrmMain = class(TForm)
     tvResources: TTreeView;
     btnOK: TBitBtn;
     btnClose: TBitBtn;
     Label1: TLabel;
     barBottom: TStatusBar;
     popResources: TPopupMenu;
     mniExpandAll: TMenuItem;
     mniCollapseAll: TMenuItem;
     mniSaveToFile: TMenuItem;
     mniLoadFromFile: TMenuItem;
     grpListType: TRadioGroup;
     grpResourceType: TRadioGroup;
     dlgOpen: TOpenDialog;
     dlgSave: TSaveDialog;
     procedure FormCreate(Sender: TObject);
     procedure btnCloseClick(Sender: TObject);
     procedure FormShow(Sender: TObject);
     procedure mniExpandAllClick(Sender: TObject);
     procedure mniCollapseAllClick(Sender: TObject);
     procedure mniSaveToFileClick(Sender: TObject);
     procedure mniLoadFromFileClick(Sender: TObject);
     procedure btnOKClick(Sender: TObject);
   private
     ListType, ResourceType: DWORD;
     procedure ShowHint(Sender: TObject);
     procedure DoEnumeration;
     procedure DoEnumerationContainer(NetResContainer: TNetResource);
     procedure AddContainer(NetRes: TNetResource);
     procedure AddShare(TopContainerIndex: Integer; NetRes:
       TNetResource);
 
     procedure AddShareString(TopContainerIndex: Integer; ItemName:
       string);
 
     procedure AddConnection(NetRes: TNetResource);
   public
     { Public declarations }
   end;
 
 var
 
   frmMain: TfrmMain;
 
 implementation
 
 {$R *.DFM}
 
 procedure TfrmMain.ShowHint(Sender: TObject);
 begin
 
   barBottom.Panels.Items[0].Text := Application.Hint;
 end;
 
 procedure TfrmMain.FormCreate(Sender: TObject);
 begin
 
   Application.OnHint := ShowHint;
   barBottom.Panels.Items[0].Text := '';
 end;
 
 procedure TfrmMain.btnCloseClick(Sender: TObject);
 begin
 
   Close;
 end;
 
 {
 
 Перечисляем все сетевые ресурсы:
 }
 
 procedure TfrmMain.DoEnumeration;
 var
 
   NetRes: array[0..2] of TNetResource;
   Loop: Integer;
   r, hEnum, EntryCount, NetResLen: DWORD;
 begin
 
   case grpListType.ItemIndex of
     { Подключенные ресурсы: }
     1: ListType := RESOURCE_CONNECTED;
     { Возобновляемые ресурсы: }
     2: ListType := RESOURCE_REMEMBERED;
     { Глобальные: }
   else
     ListType := RESOURCE_GLOBALNET;
   end;
 
   case grpResourceType.ItemIndex of
     { Дисковые ресурсы: }
     1: ResourceType := RESOURCETYPE_DISK;
     { Принтерные ресурсы: }
     2: ResourceType := RESOURCETYPE_PRINT;
     { Все: }
   else
     ResourceType := RESOURCETYPE_ANY;
   end;
 
   Screen.Cursor := crHourGlass;
 
   try
     { Удаляем любые старые элементы из дерева: }
     for Loop := tvResources.Items.Count - 1 downto 0 do
       tvResources.Items[Loop].Delete;
   except
   end;
 
   { Начинаем перечисление: }
   r := WNetOpenEnum(ListType, ResourceType, 0, nil, hEnum);
   if r <> NO_ERROR then
   begin
     if r = ERROR_EXTENDED_ERROR then
       MessageDlg('Невозможно сделать обзор сети.' + #13 +
         'Произошла сетевая ошибка.', mtError, [mbOK], 0)
     else
       MessageDlg('Невозможно сделать обзор сети.',
         mtError, [mbOK], 0);
     Exit;
   end;
 
   try
     { Мы получили правильный дескриптор перечисления; опрашиваем ресурсы: }
     while (1 = 1) do
     begin
       EntryCount := 1;
       NetResLen := SizeOf(NetRes);
       r := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
       case r of
         0:
           begin
             { Это контейнер, организуем итерацию: }
             if NetRes[0].dwUsage = RESOURCEUSAGE_CONTAINER then
               DoEnumerationContainer(NetRes[0])
             else
               { Здесь получаем подключенные и возобновляемые ресурсы: } if ListType
                 in [RESOURCE_REMEMBERED, RESOURCE_CONNECTED] then
 
                 AddConnection(NetRes[0]);
           end;
 
         { Получены все ресурсы: }
         ERROR_NO_MORE_ITEMS: Break;
         { Другие ошибки: }
       else
         begin
           MessageDlg('Ошибка опроса ресурсов.', mtError, [mbOK], 0);
           Break;
         end;
       end;
     end;
 
   finally
     Screen.Cursor := crDefault;
     { Закрываем дескриптор перечисления: }
     WNetCloseEnum(hEnum);
   end;
 end;
 
 {
 
 Перечисление заданного контейнера:
 Данная функция обычно вызывается рекурсивно.
 }
 
 procedure TfrmMain.DoEnumerationContainer(NetResContainer:
   TNetResource);
 var
 
   NetRes: array[0..10] of TNetResource;
   TopContainerIndex: Integer;
   r, hEnum, EntryCount, NetResLen: DWORD;
 begin
 
   { Добавляем имя контейнера к найденным сетевым ресурсам: }
   AddContainer(NetResContainer);
   { Делаем этот элемент текущим корневым уровнем: }
   TopContainerIndex := tvResources.Items.Count - 1;
   { Начинаем перечисление: }
   if ListType = RESOURCE_GLOBALNET then
     { Перечисляем глобальные объекты сети: }
     r := WNetOpenEnum(ListType, ResourceType, RESOURCEUSAGE_CONTAINER,
       @NetResContainer, hEnum)
   else
     { Перечисляем подключаемые и возобновляемые ресурсы (другие получить здесь невозможно):
     }
 
     r := WNetOpenEnum(ListType, ResourceType, RESOURCEUSAGE_CONTAINER,
       nil, hEnum);
   { Невозможно перечислить ресурсы данного контейнера;
   выводим соответствующее предупреждение и едем дальше: }
   if r <> NO_ERROR then
   begin
     AddShareString(TopContainerIndex, '<Не могу опросить ресурсы
       (Ошибка #'+
 
       IntToStr(r) + '>');
       WNetCloseEnum(hEnum);
       Exit;
   end;
 
   { Мы получили правильный дескриптор перечисления; опрашиваем ресурсы: }
   while (1 = 1) do
   begin
     EntryCount := 1;
     NetResLen := SizeOf(NetRes);
     r := WNetEnumResource(hEnum, EntryCount, @NetRes, NetResLen);
     case r of
       0:
         begin
           { Другой контейнер для перечисления;
           необходим рекурсивный вызов: }
           if (NetRes[0].dwUsage = RESOURCEUSAGE_CONTAINER) or
             (NetRes[0].dwUsage = 10) then
             DoEnumerationContainer(NetRes[0])
           else
             case NetRes[0].dwDisplayType of
               { Верхний уровень: }
               RESOURCEDISPLAYTYPE_GENERIC,
                 RESOURCEDISPLAYTYPE_DOMAIN,
                 RESOURCEDISPLAYTYPE_SERVER: AddContainer(NetRes[0]);
               { Ресурсы общего доступа: }
               RESOURCEDISPLAYTYPE_SHARE:
                 AddShare(TopContainerIndex, NetRes[0]);
 
             end;
         end;
       ERROR_NO_MORE_ITEMS: Break;
     else
       begin
         MessageDlg('Ошибка #' + IntToStr(r) + ' при перечислении
           ресурсов.',mtError,[mbOK],0);
           Break;
       end;
     end;
   end;
 
   { Закрываем дескриптор перечисления: }
   WNetCloseEnum(hEnum);
 end;
 
 procedure TfrmMain.FormShow(Sender: TObject);
 begin
 
   DoEnumeration;
 end;
 
 {
 
 Добавляем элементы дерева; помечаем, что это контейнер:
 }
 
 procedure TfrmMain.AddContainer(NetRes: TNetResource);
 var
 
   ItemName: string;
 begin
 
   ItemName := Trim(string(NetRes.lpRemoteName));
   if Trim(string(NetRes.lpComment)) <> '' then
   begin
     if ItemName <> '' then
       ItemName := ItemName + ' ';
     ItemName := ItemName + '(' + string(NetRes.lpComment) + ')';
   end;
   tvResources.Items.Add(tvResources.Selected, ItemName);
 end;
 
 {
 
 Добавляем дочерние элементы к контейнеру, обозначенному как текущий верхний уровень:
 }
 
 procedure TfrmMain.AddShare(TopContainerIndex: Integer; NetRes:
   TNetResource);
 var
 
   ItemName: string;
 begin
 
   ItemName := Trim(string(NetRes.lpRemoteName));
   if Trim(string(NetRes.lpComment)) <> '' then
   begin
     if ItemName <> '' then
       ItemName := ItemName + ' ';
     ItemName := ItemName + '(' + string(NetRes.lpComment) + ')';
   end;
 
   tvResources.Items.AddChild(tvResources.Items[TopContainerIndex], ItemName);
 end;
 
 {
 
 Добавляем дочерние элементы к контейнеру, обозначенному как текущий верхний уровень;
 это просто добавляет строку для таких задач, как, например,
 перечисление контейнера. То есть некоторые контейнерные
 ресурсы общего доступа нам не доступны.
 }
 
 procedure TfrmMain.AddShareString(TopContainerIndex: Integer;
   ItemName: string);
 begin
 
   tvResources.Items.AddChild(tvResources.Items[TopContainerIndex], ItemName);
 end;
 
 {
 
 Добавляем соединения к дереву.
 По большому счету к этому моменту все сетевые ресурсы типа
 возобновляемых и текущих соединений уже отображены.
 }
 
 procedure TfrmMain.AddConnection(NetRes: TNetResource);
 var
 
   ItemName: string;
 begin
 
   ItemName := Trim(string(NetRes.lpLocalName));
   if Trim(string(NetRes.lpRemoteName)) <> '' then
   begin
     if ItemName <> '' then
       ItemName := ItemName + ' ';
     ItemName := ItemName + '-> ' + Trim(string(NetRes.lpRemoteName));
   end;
   tvResources.Items.Add(tvResources.Selected, ItemName);
 end;
 
 {
 
 Раскрываем все контейнеры дерева:
 }
 
 procedure TfrmMain.mniExpandAllClick(Sender: TObject);
 begin
 
   tvResources.FullExpand;
 end;
 
 {
 
 Схлопываем все контейнеры дерева:
 }
 
 procedure TfrmMain.mniCollapseAllClick(Sender: TObject);
 begin
 
   tvResources.FullCollapse;
 end;
 
 {
 
 Записываем дерево в выбранном файле:
 }
 
 procedure TfrmMain.mniSaveToFileClick(Sender: TObject);
 begin
 
   if dlgSave.Execute then
     tvResources.SaveToFile(dlgSave.FileName);
 end;
 
 {
 
 Загружаем дерево из выбранного файла:
 }
 
 procedure TfrmMain.mniLoadFromFileClick(Sender: TObject);
 begin
 
   if dlgOpen.Execute then
     tvResources.LoadFromFile(dlgOpen.FileName);
 end;
 
 {
 
 Обновляем:
 }
 
 procedure TfrmMain.btnOKClick(Sender: TObject);
 begin
 
   DoEnumeration;
 end;
 
 end.
 




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

Реальность из дистрибутива Windows ME - Удаленный доступ к домашней сети.

сервер:


 StrPCopy(buff, Edit1.Text);
 fPipeHandle := CreateNamedPipe(buff,
 Pipe_Access_Duplex or File_Flag_Overlapped,
 Pipe_Type_Message or Pipe_ReadMode_Byte or Pipe_Wait,
 5, $400, $400, 235, nil);
 

клиент:


 StrPCopy(buff,Edit1.Text);
 fFileHandle:=CreateFile(buff,
 Generic_Read or Generic_Write,
 File_Share_Read or File_Share_Write,
 nil,
 Open_Existing,
 File_Attribute_Normal or File_Flag_Overlapped or Security_Anonymous,
 0);
 if fFileHandle <> Invalid_Handle_Value then
 begin
 ...
 




Установка границ для вновь создаваемых элементов управления

Если вы создаете в среде Delphi новый элемент управления, и вам нужно контролировать или ограничить свойства Left, Top, Width и Height, то спешу вас обрадовать: есть одно простое решение сделать это. Тем не менее, в документации по Delphi я не увидел ни малейшего намека на данный способ (включая CWG).

Ключевой момент кроется в изменении Left, Top, Width, Height и каждого BoundsRect в Delphi методом SetBounds() (доступного в TControl и во всех его потомках). SetBounds() - виртуальная фунция, делающее установление позиции и размера элемента управления делом легким и приятным. Тем не менее, о чем умалчивается в документации, что TControl.SetBounds() вызывает методы TControl SetLeft(), SetTop(), SetWidth() и SetHeight() при каждом изменении значений свойств Left, Top, Width, Height и BoundsRect.

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

В следующем примере мы имеем управление, которое автоматически изменяет свои пользовательские свойства X & Y, с той целью, чтобы они ссылались на центр элемента управления при изменении значений Left, Top, Width, Height или BoundsRect. И наоборот, Left и Top будут изменяться всякий раз при изменении свойств X & Y:


 type
   TMyControl = class(TControl)
   private
     FX, FY: integer;
     {методы доступа к свойствам}
     procedure SetX(value: integer);
     procedure SetY(value: integer);
     ...
     public
     procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
     ...
       property X: integer read FX write SetX;
     property Y: integer read FY write SetY;
   end;
   ...
 
 procedure TMyControl.SetX(value: integer);
 begin
   if FX <> value then
     SetBounds(value - Width div 2, Top, Width, Height);
 end;
 
 procedure TMyControl.SetY(value: integer);
 begin
   if FY <> value then
     SetBounds(Left, value - Height div 2, Width, Height);
 end;
 
 procedure TMyControl.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
 begin
   {Продолжаем, и позволяем SetBounds() сделать свое дело...}
   inherited SetBounds(aLeft, aTop, aWidth, aHeight);
   {Теперь "регулируем" FX и FY согласно нашим новым границам.}
   FX := Width div 2;
   FY := Height div 2;
 end;
 

Также в документации не упоминается о том факте, что частные поля FLeft, FTop, FWidth и FHeight, которые TControl использует для хранения внутренних значений, используются в методах SetLeft(), SetTop() и пр. для сравнения с текущими границами прямоугольника, при совпадении которых он не обновляется. Фактически, эти переменные нигде, кроме как в методе TControl SetBounds(), не корректируются (как в случае с FX и FY в приведенном выше примере).

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

В следующем примере мы имеем управление, которое ограничивает свою ширину и высоту в 100 пикселей:


 type
   TMyControl = class(TControl)
     ...
     public
     procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
     ...
   end;
 
 ...
 
 procedure TMyControl.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
 begin
   if aWidth > 100 then
     aWidth := 100;
   if aHeight > 100 then
     aHeight := 100;
   inherited SetBounds(aLeft, aTop, aWidth, aHeight);
 end;
 




Как переслать файл через nonBlocking сокет

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


 //  а форме ServerSocket1, ClientSocket1 : (Active := False,
 //  Host := localhost, Port := 2001, xType := xNonBlocking),
 //  OpenDialog1, Button1, Memo1.
 
 procedure TfmMain.FormCreate(Sender: TObject);
 begin
   ServerSocket1.Active:=true;
   ClientSocket1.Active:=true;
 end;
 
 {--- Server ---}
 
 procedure TfmMain.Button1Click(Sender: TObject);
 var
   sStream : TMemoryStream;
 begin
   sStream := TMemoryStream.Create;
   if not OpenDialog1.Execute then
     Exit;
   sStream.LoadFromFile(OpenDialog1.FileName);
   ServerSocket1.Socket.Connections[0].SendStreamThenDrop(sStream);
 end;
 
 {--- Client ---}
 
 const
   MAX_BUF_SIZE = $4095;
 
 var
   fStream: TFileStream;
 
 {OnConnect}
 procedure TfmMain.ClientSocket1Connect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
   fStream:= TFileStream.Create('Receive.fil', fmCreate);
 end;
 
 {OnRead}
 procedure TfmMain.ClientSocket1Read(Sender: TObject;
   Socket: TCustomWinSocket);
 var
   count :Integer;
   buffer: Array [0..MAX_BUF_SIZE] of Char;
 begin
   repeat
     Socket.Lock;
     count:= Socket.ReceiveBuf(buffer,SizeOf(buffer));
     if count > 0 then
       fStream.WriteBuffer(buffer,count);
     Socket.Unlock;
    until (count <= 0);
 
    Memo1.Lines.Add(IntToStr(fStream.Size));
 end;
 
 {OnDisconnect}
 procedure TfmMain.ClientSocket1Disconnect(Sender: TObject;
   Socket: TCustomWinSocket);
 begin
    fStream.Free;
 end;
 
 




Как создать невизуальный компонент без иконки, которая изображается в Design-Time

Как создать невизуальный компонент без иконки, которая изображается в палитре компонентов в "design-time" (вроде TField)?

Ответ:

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




Некорректные вещественные значения

При использовании функции strtofloat для значения 1234.5544 я получаю что-то типа 1234.55440000000003, но ведь это неправильно!

Ничего здесь неправильного нет. Это просто погрешность чисел с плавающей точкой. Фактически источником ошибки является ошибка округления. Данная ошибка является следствием дефекта арифметики плавающей точки и того факта, что чаще всего десятичные дроби являются повторяющимися долями в двоичной системе счисления. Такие числа не могут представляться в конечном количестве битов. В связи с этим текстовое округление получается не всегда точным, т.к. большинство компьютеров подбирает последние цифры дробной части, исходя из ближайшего (с наименьшей разницей) эквивалента. Некоторые компьютеры не производят округления, а просто обрезают (выключают) последние биты, получая результирующую ошибку, правильно называемую ошибкой округления (в противоположность ошибке усечения, когда усекается расширение ряда). Для получения дополнительной информации обратитесь к Introduction to Numerical Methods (введение в числовые методы) авторов Peter A. Stark, Macmillian Company, 1970.

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

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


 IF ABS(CalculatedValue - TrueValue) < FuzzValue THEN ...
 

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


 IF ABS( (CalculatedValue - TrueValue) / TrueValue ) <
 AcceptableRelativeError THEN ...
 

, где AcceptableRelativeError определяет величину относительной погрешности (ну, и конечно, TrueValue <> 0.0).

Математеческий модуль Delphi 3 вычисляет относительную погрешность следующим образом (но оно не вынесено в секцию interface):


 FUNCTION RelSmall(X, Y: Extended): Boolean;
 { Возвращаем Истину, если разница между X и Y незначительна }
 CONST
   C1: Double = 1E-15;
   C2: Double = 1E-12;
 BEGIN
   Result := Abs(X) < (C1 + C2 * Abs(Y))
 END;
 




Notebook - добавление и удаление страниц

Автор: Mark Johnson

Как во время выполнения программы динамически добавлять и удалять страницы динамически созданного NoteBook?


 procedure AddPage(nbk: TNotebook; tabset: TTabSet; const pagename: string);
 { Добавляем новую страницу к NoteBook и новую закладку к tabset
 (параметр pagename задает имя страницы), размещаем на странице
 компонент Memo и выводим новую страницу на передний план.
 Подразумевается, что TabSet (набор закладок) имеет ровно по
 одной закладке на каждую страницу NoteBook с точным сохранением порядка. }
 
 var
   memo: TMemo;
   page: TPage;
 begin
   if nbk <> nil then
   begin
     nbk.Pages.Add(pagename); {добавляем страницу в TNotebook}
     nbk.PageIndex := nbk.Pages.Count - 1; {делаем новую страницу текущей}
     if tabset <> nil then
     begin
       tabset.Tabs.Add(pagename); {добавляем соответствующую закладку}
       tabset.TabIndex := nbk.PageIndex; {делаем новую закладку текущей}
     end;
     if nbk.PageIndex > -1 then
     begin {убедимся что страница существует}
       page := TPage(nbk.Pages.Objects[nbk.PageIndex]); {получаем объект страницы}
       }
         memo := TMemo.Create(page);
           {создаем TMemo (и страницей в качестве родителя)}
       try
         memo.Parent := page; {устанавливаем страницу в качестве Parent}
         memo.Align := alClient;
           {устанавливаем выравнивание для заполнения области клиента}
       except
         memo.Free; {освобождаем TMemo, если что-то идет неправильно}
       end;
       page.Visible := true; {показываем страницу}
     end;
   end;
 end;
 
 procedure DeletePage(nbk: TNotebook; tabset: TTabSet; index: integer);
 { Удаляем страницу, чей PageIndex = index из nbk и tabset. Подразумевается,
 что TabSet имеет ровно по одной закладке на каждую страницу NoteBook с
 точным сохранением порядка. }
 
 var
   switchto: integer;
 begin
   if nbk <> nil then
   begin
     if (index >= 0) and (index < nbk.Pages.Count) then
     begin
       if index = nbk.PageIndex then
       begin
         if index < nbk.Pages.Count - 1 then
         begin {если страница не последняя в списке}
           switchto := nbk.PageIndex;
             {выводим страницу за текущей, ставшей ею после удаления}
           if (index = 0) and (nbk.Pages.Count > 1) then {если первая страница}
             nbk.PageIndex := 1; {теперь показываем вторую страницу}
         end
         else
           switchto := nbk.PageIndex - 1;
             {в противном случае показываем страницу, расположенную перед текущей}
       end;
       nbk.Pages.Delete(index);
         {освобождаем страницу и все принадлежавшие ей элементы управления}
       if tabset <> nil then
       begin
         if index < tabset.Tabs.Count then
           tabset.Tabs.Delete(index); {удаляем соответствующую закладку}
       end;
       nbk.PageIndex := switchto;
     end;
   end;
 end;
 




Notebook как контейнер для форм

Автор: Neil

...у меня происходит утечка памяти при изменениях страниц в закладках NoteBook.

Вы не "теряете" ресурсы, вы их используете. Вы ИСПОЛЬЗУЕТЕ ресурсы на каждой страницы начиная с первой, которая доступна для вашего созерцания. Я упомянаю это потому, потому что проблема ПОТЕРИ ресурсов относится к другому типу проблемы.

Недавно я работал над проблемой показа других *ФОРМ* в главной форме, как если бы они были страницами NoteBook. Форма создается при перелистывании на эту "страницу", и разрушается при ее покидании. Это требует хранения неизменяемой информации, естественно, в главной форме, но это чрезвычайно нетребовательно к ресурсам. Главное, что вы храните поля индивидуальных данных в главной форме с именем "Child", а инициализируете в обработчике события экземпляра TForm2 (или имеющего другое имя, в зависимости от имени вашей первой дочерней формы) OnCreate. Поместите закладки в нижней части формы, и при изменении закладки освобождайте текущего "ребенка", а затем создавайте и делайте ребенком другой соответствующий экземпляр формы.

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


 procedure TPageForm.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   with Params do
   begin
     WndParent := Application.MainForm.Handle;
     Parent := Application.MainForm;
     Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
     Align := alClient;
   end;
 end;
 

Код главной формы должен выглядеть примерно так:


 procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
   var AllowChange: Boolean);
 begin
   LockWindowUpdate(Handle);
   Child.Free;
   case NewTab of
     0: Child := TForm2.Create(Application);
     1: Child := TForm3.Create(Application);
     2: Child := TForm4.Create(Application);
   end;
   Child.Show;
   LockWindowUpdate(0);
 end;
 

Надеюсь это окажется полезным!




Notebook как контейнер для форм 2

Автор: Ralph Friedman

Кто-нибудь может мне помочь в вопросе размещения подклассов форм на страницах компонента TTabbedNotebook?

Я пробовал следующий код и он отлично работает с компонентами, являющимися частью формы, содержащей TTabbedNotebook; тем не менее он не работает с дочерними формами:


 ChildForml[i].Parent := TWinControl(BrowseTabNotebook.Pages.Objects[i]);
 

В дочерней форме должен быть следующий код:


 private
   { Private }
   procedure CreateParams(var Params: TCreateParams); override;
 
 ...
 
 procedure TChildForm1.CreateParams(var Params: TCreateParams);
 begin
   { сначала вызываем унаследованные методы. }
   inherited CreateParams(Params);
   with Params do
   begin
     WndParent := Application.Mainform.Handle;
     Style := (Style or WS_CHILD) and not WS_POPUP;
   end;
 end;
 

Надеюсь это окажется полезным!




Проблема с освобождением ресурсов Notebook

Автор: Mike Scott

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


 procedure TForm1.TabSet1Click(Sender: TObject);
 var
   i: integer;
 begin
   Notebook1.PageIndex := TabSet1.TabIndex ;
   with Notebook1, Pages do
     for i := 0 to Count - 1 do
       if (i <> PageIndex) then
         TForm1(Objects[i]).DestroyHandle;
 end;
 

Как вы могли заметить, я привел тип страницы notebook (Objects[ i ]) к объектам TForm1, что на самом деле не так. Тем не менее, эта небольшая хитрость позволяет иметь доступ к защищенным членам извне метода класса, где они определены, в данном случае DestroyHandle - защищенный метод TWinControl.

Это работает, поскольку TForm1 является наследником TWinControl, и позволяет иметь доступ к защищенным членам TForm1 и ее наследникам. Быстро и грязно, но это работает! <g>

Не волнуйтесь, если вы видите, что невидимая страница показывается снова. VCL - довольно умная штука, поскольку захватывает данные от дескриптора окна и сохраняет это непосредственно в объекте. Затем, всякий раз, когда дескриптор требуется снова, то есть тогда, когда вы делаете страницу видимой, дескриптор окна пересоздается, туда снова копируются данные, и оп-ля, как будто ничего и не произошло - магия!

Я надеюсь это поможет.




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

Самое скандальное шоу мира "Окна" с Билом Гейтсом. Ежедневно на Ваших мониторах.

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

Дале следует пример обработчика сообщения:


 type
   TForm1 = class(TForm)
     Button1: TButton;
   private
     { Private declarations }
     procedure WMDisplayChange(var message: TMessage); message WM_DISPLAYCHANGE;
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMDisplayChange(var message: TMessage);
 begin
   {Do Something here}
   inherited;
 end;
 




Как отучить игры от проверки CD-ROM (на примере Hellfire)

Корреспондент газеты спрашивает системного администратора:
- Скажите, а у вас есть любовница?
- Есть!
- И где же она живет?
- А вон на том компакт-диске!

Использованные программы: Hellfire v2.0, W32Dasm v8.9, Dos Navigator v1.5

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

  • Заменяем в программе HellFire v2.0 проверку с диска CD-ROM на сетевой диск
  • Пишем Fake-CD для OS Windows 95

Заменяем в программе HellFire v2.0 проверку с диска CD-ROM на сетевой диск

Суть проблемы состоит в том, чтобы доказать программе, что винчестер на самом деле совсем не винчестер, а CD-ROM. Или скажем - как в данном случае - в выдаче за локальный CD сетевого, ну один CD на работе, а играть-то всем охота!

Приступим. Цель - Функция GetDriveType(). Она возвращает тип диска, имя которого ей передали. Вот ее прототип:


 UINT GetDriveType(LPCTSTR lpRootPathName);
 

Функция возвращает следующие значения:

Числовое
значение
ИдентификаторОписание диска
0-Невозможно определить тип
1-Диск не найден
2DRIVE_REMOVABLEГибкий (возможна замена)
3DRIVE_FIXEDЖесткий (замена невозможна)
4DRIVE_REMOTEСетевой диск
5DRIVE_CDROMCD-ROM
6DRIVE_RAMDISKRAM - Диск

Стандартно программа получает список всех дисков, проверяет их на "CDромность" и по нахождению проверяет наличие нужных файлов. Для проверки, необходимо, очевидно, сравнить возвращаемое значение с 5. Найдем этот момент программы, вот как он выглядит после дизассемблирования HellFire с помощью W32Dasm :


 Reference To: KERNEL32.GetDriveTypeA, Ord:00DFh  |
 :0041D976 FF151CA56F00  Call dword ptr [006FA51C]
 :0041D97C 83F805 cmp eax, 00000005
 :0041D97F 752A jne 0041D9AB
 

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


 bpx GetDriveType
 bpx GetDriveTypeA
 

В самом же W32Dasm можно воспользоваться списком использованных функций. Ищем KERNEL32.GetDriveTypeA и два раза щелкаем по функции мышью. В IDA такой список есть в конце отдизассемблированного файла. Листинг полученный Sourcer'ом придется исследовать обычным текстовым поиcком.

Запишем HEX-DUMP этого куска и найдем его в шеснадцатеричном редакторе. Например в DN: откроем файл hellfire.exe по F3, далее F4 (переход в HEX режим), F7 (поиск), в строке ввода HEX строки введем записанное ранне и вперед (т.е. ENTER).

Вместо 83F805 введем 83F804 и любой из подключенных сетевых дисков теперь будет восприпринят прораммой за CD, иначе введем 83F803 - тогда жесткие диски будут приниматься за CD. Фантазия может развиваться по-любому, можно изменить условие перехода после сравнения, тогда не придется заботится о типе диска.

Вот и все на сегодня, в следующий раз можно будет поговорить о минимизации количества данных, копируемых с диска. Эта проблема отнюдь не тривиальна, так как файлы обычно храняться в виде типа PAK как, например в QUAKE. Для простых же программ можно посоветовать обнулить все WAV, AVI файлы. Для этого есть специальные утилиты, но, конечно, проще создать файл нулевой длинны с таким же именем, например по Shift-F4 в любом дисковом коммандере (DN,NC,etc.).

Пишем Fake-CD для OS Windows 95

Для DOS существовала прекрасная утилита - FakeCD, которая подменяла MSСDEX и эмулировала таким образом CD-диск который, на самом деле, был каталогом на винчестере. Для Win95 такую программу найти не просто, поэтому необходимо ее сделать самим. Этим мы и займемся, тем более, что это будет прекрасная практика по копанию в недрах 95'ого.

Посмотрим на проблему, обсуждавшуюся раннее, с другой стороны. Заменим не использование функции, а саму функцию. Если в DOS для замены функций необходимо только было изменить обработчик прерываний, то в Windows такой финт уже не поможет. Выясним, где "живет" GetDriveType(). И - о ужас - это главная библиотека Win95 KERNEL32.DLL. Что делать? Как всегда, запастись кофе и напуcтить на KERNEL32.DLL дизассемблер. OK, ждем окончания процесса и смотрим список экспортируемых функций. Вот нужная нам:


 Exported fn(): GetDriveTypeA - Ord:013Fh
 :BFF777C4 57 push edi
 :BFF777C5 6A21 push 00000021
 ...
 ...
 ...
 :BFF777E1 F2 repnz
 :BFF777E2 AE scasb
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Address:
 |:BFF777DA(C)
 |
 :BFF777E3 648F02 pop dword ptr fs:[edx]
 :BFF777E6 83C408 add esp, 00000008
 :BFF777E9 5F pop edi
 :BFF777EA E9E5D4FFFF jmp BFF74CD4
 

Делаем переход в конце(кнопка Jump to на панели W32Dasm) и видим продолжение. Функция, оказывается-то, длинная! Не будем в ней разбираться, а лучше вспомним как происходит возврат значения из функции. Т.о. ищем строку типа


 mov eax,03000000
 

Нашли? Далее, как и при любом взломе, запомним последовательность HEX кодов нужной команды (а лучше нескольких следующих, так как загрузка в аккумулятор числа 3 не самая редкая операция) и найдем этот блок в копии библиотеки (в копии - потому что файл используется системой и не может быть изменен). Все, осталось лишь в режиме DOS подменить KERNEL32.DLL. Перезагрузимся и в Проводнике насладимся результатом - все ваши жесткие диски представленны в виде кругленьких пластинок ранее обозначавших CD.

А теперь - для ленивых - кусок кода, который возвращает 3:


 * Possible Reference to String Resource ID=00003: "....."
 
 | :BFF74E0F B803000000 mov eax, 00000003 //Возвращаемое значение
 :BFF74E14 EB05 jmp BFF74E1B //Переход на возврат
 
 * Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
 |:BFF74DEB(C), :BFF74DFC(C), :BFF74E0D(C)
 |
 
 * Possible Reference to String Resource ID=00006: "..."
 

Да - лучше сохранить старый KERNEL32, так как некоторые программы могут не оценить ваш юмор, и решить, что несколько CD и ни одного винчестера - это слишком. (комментарий Bad_guy: не рассчитывайте теперь на проверку винчестера scandisk'ом и на прочие винчестерные утилиты) А вообще идеально было бы изменить функцию коренным образом. Скажем сделать CD дисками все, начиная с T. Тогда можно было бы подключать subst'ом каталоги, которые были бы CD, а винчестеры остануться винчестерами. Но это уже задание на дом. Удачи!




Не закрывающееся окно


Приходит как-то Билли Гейтс в Массачусетский технологический и начинает вешать на уши лапшу про то, как у них там в ГигаСофте круто и какие у них программы пишутся.
А ему в ответ:
- Alt+F4!!!

Например вы отключили Ctrl+Alt+Delete, сделали неактивной кнопку закрытия окна, удалили саму команду "Закрыть" в системном меню ("модификация системного меню") - всё это мы уже знаем как делать, но... глупый ламерюга может попросту нажать Alt+F4... вот это у нас ещё не учтено! Так как же запретить закрытие окна?

Делать это будем так: вызываем событие OnCloseQuery для формы и пишем туда два слова!!!


 CanClose:=false;
 

Посмотрите внимательнее на параметры, переданные в вызванном нами событии. Там вы и увидите то самое "CanClose", которое мы использовали. Всё довольно таки легко: если этот параметр установить в false пользователь не сможет закрыть окно, в противном случае - сможет. Ну вот теперь мы добились того, что "ждал от нас юзверь"... так не будем и впредь разочаровывать его!

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




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

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


 // Естественно, вместо D:\gigi.txt — твой файл.
 // Из конференции Expert_FAQ
 
 var
   Form1: TForm1;
   // через этот поток мы будем работать с файлом.
   // Для нескольких файлов — несколько потоков.
   fs: TFileStream;
 
 implementation
 {$R *.dfm}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   // вешаем ограничение. Теперь никто не будет трогать файл
   fs:=TFileStream.Create('D:\gigi.txt', fmOpenRead, fmShareDenyNone);
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   //Снимаем ограничение.
   fs.Free;
 end;
 




Средства противодействия крэкеру

Доктор ставит хакеру диагноз:
- Итак, дорогой, вам осталось жить 30 дней.
- Извините, доктор, а где можно скачать crack?

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

До недавнего времени исследование функционирования программы, задаваемой ее исполняемым кодом (и ничем более) называлось "вскрытием" (cracking) и являлось уделом хакеров, и, естественно, не могло не быть связано с нарушением авторских прав или каким-либо другим нанесением ущерба компьютерной системе. С появлением в последнее время вредного программного обеспечения (badware) ситуация, очевидно, изменилась. Многие вирусологи теперь только и заняты тем, что изучают алгоритмы все новых и новых вирусов - и эта работа для них из безусловно творческой превратилась в рутинную. Известно, что при обезвреживании знаменитого вируса Морриса самая важная часть работ легла на плечи специалистов по дизассемблированию, причем выполнить они ее должны были в кратчайшее время - когда вирус еще распространялся, и не было известно, что он не содержит функции разрушения. Именно дизассемблирование могло дать тогда ответ на три главных вопроса: что это такое, чем это грозит и как с этим бороться [2].

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

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

Хотя обе эти задачи принципиально разрешимы, можно высказать сомнение в получении сколь-нибудь достоверных результатов при использовании автоматических методов. Более того, даже имея стопроцентную уверенность в отсутствии ненадежного (untrusted) кода в исходном тексте программы, нельзя гарантировать отсутствие ошибок или троянских коней в программе, которая будет его интерпретировать (для исполняемого кода это происходит на уровне микрокода) или во внешних вызываемых функциях (в частности, операционной системы). Этот аспект рассматривался К.Томпсоном в [5]: "Никакой уровень верификации или исследований исходного текста не защитит вас от исполнения ненадежного кода... По мере того, как уровень языка программирования снижается, находить такие ошибки становится все труднее и труднее. Хорошо продуманную "ошибку" в микрокоде найти почти невозможно".

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

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

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

Помимо этих двух основных программных продуктов можно предложить:

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

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

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

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

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

Для системы MS-DOS описаны [3, 4] конкретные приемы защиты от исследования, базирующиеся на описанных принципах :

1) от дизассемблера и дискомпилятора
а) модификация кода программы - приводит к тому, что дизас семблер не может достоверно распознать инструкции и/или данные:
- зашифровка критичного кода и расшифровка его самой систе мой защиты перед передачей управления на него;
- модификация кода непосредственно самой программой;
б) скрытие команд передачи управления - приводит к тому, что дизассемблер не может построить граф передачи управления:
- косвенная передача управления;
- использование нестандартных способов передачи управления (JMP через RET, RET и CALL через JMP);
- модификация адреса перехода в коде программы;
2) от отладчика
а) выявление изменений операционной среды - приводит к тому, что программа отказывается правильно работать:
- проверка количества свободной памяти, векторов прерываний и т.п.;
- проверка временных характеристик программы;
б) подавление изменения операционной среды - программа либо са ма еще раз перенастраивает среду, либо вообще не может рабо тать в возмущенной среде:
- расшифровка кода в зависимости от эталонного состояния среды;
- использование отладочных прерываний (INT 1 и INT 3) для собственных нужд;
- использование абсолютной адресации;
- назначение стека программы непосредственно в область ис польняемого кода;
- самомодификация программы в зависимости от эталонных вре менных характеристик;
в) противодействие установке контрольных точек - отладчик или не может установить контрольную точку, или программа рас познает ее:
- подсчет контрольных сумм участков кода программы;
- чередование команд запрета и разрешения прерываний;
г) нарушение интерфейса с пользователем - приводит к тому, что пользователь не может пронаблюдать за ходом выполнения программы:
- блокировка клавиатуры;
- искажения при выводе на терминал;
3) от следящей системы за прерываниями (помимо аналогичных 2а, 2б методов):
- вызов нужных функций через прерывания более низкого уров ня, нестандартные прерывания или точки входа в них, ис пользования аппаратуры напрямую;
4) от семантического анализатора:
- использование функций, внешне похожих на критичные, со вершенно бесполезных на самом деле;

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

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

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

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

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

Именно такие средства в сочетании с автоматизированной системой семантического анализа предполагается использовать для исследования программ в рамках антивирусной лаборатории (АВЛ) [1].

Литература.

  • Зегжда Д.П., Матвеев В.А., Молотков С.В., Тихомиров Ю.В., под редакцией Шмакова Э. М. Защита информации в компьютерных системах. Теоретические аспекты защиты от вирусов. - СПб, СПбГТУ, 1993.
  • Моисеенко И. Суета вокруг Роберта или Моррис-сын и все, все, все. // КомпьютерПресс, 1991, N 8-9.
  • Расторгуев С.П., Дмитриевский Н.Н. Искусство защиты и "раздевания" программ. - М., 1991.
  • Спесивцев А.В. и др. Защита информации в персональных ЭВМ. М., Радио и связь, 1992.
  • Thompson K. Reflection on trusting trust. // CACM, 1984, v. 27, N 8.



Как сделать анимацию немерцающей

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


 var
   bm: TBitMap;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   bm := TBitMap.Create;
   bm.Width := Form1.ClientWidth;
   bm.Height := Form1.ClientHeight;
   with bm.Canvas do
   begin
     Font.name := 'Arial';
     Font.Size := 50;
     Font.Color := clBlue;
   end;
   Timer1.Interval := 100;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 var
   s: string;
   Hour, Min, Sec, MSec: Word;
 begin
   DecodeTime(Time, Hour, Min, Sec, MSec);
   with bm.Canvas do
   begin
     Brush.Style := bsSolid;
     Brush.Color := clWhite;
     FillRect(ClipRect);
     s := TimeToStr(Time);
     TextOut((bm.Width - TextWidth(s)) div 2,
     (bm.Height - TextHeight(s)) div 2, s);
     Pen.Mode := pmMask;
     Pen.Width := 20;
     Pen.Color := clLime;
     Brush.Style := bsClear;
     Rectangle(bm.Width div 2 - (MSec * bm.Width) div 5000,
     bm.Height div 2 - (MSec * bm.Height) div 5000,
     bm.Width div 2 + (MSec * bm.Width) div 5000,
     bm.Height div 2 + (MSec * bm.Height) div 5000);
   end;
   Form1.Canvas.Draw(0, 0, bm);
 end;
 




Как не администратору под NT получить доступ к реестру


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

Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя вместо TRegistry.OpenKey - TRegistry.OpenKeyReadOnly

В справке про TRegistry указано неверно, что ключ открывается всегда с параметром KEY_ALL_ACCESS. В случае если открывать через TRegistry.OpenKeyReadOnly он откроется с параметром KEY_READ




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


 procedure WMQueryOpen(var Msg: TWMQueryOpen);
   message WM_QUERYOPEN;
 
 // ... и ее реализация
 procedure TMainForm.WMQueryOpen(var Msg: TWMQueryOpen);
 begin
   Msg.Result := 0;
 end;
 
 




Не работающий SQL OR

Автор: Chris Hall, Randall Nelson

Я заполнил таблицу 10 записями и сделал SQL с "OR" (в свойстве "select * from", где acreage=5.5 или acreage=6). Это работает. Затем я возвратился и поместил вторичный индекс в поле acreage - и это НЕ СРАБОТАЛО.

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




Не получается вставить в таблицу записи со строками на русском языке

В Database Desktop поставьте правильный Language Driver у таблицы, например, Pdox ANSI Cyrr.

Это простой вопрос в том случае, если база уже создана на диске. Если мы создаем базу динамически из программы, то как потом поставить русский язык без Database Desktop'а?

Оказывается это не так просто. Я перерыл весь инет и так и не нашел. В итоге пришлось потрудится и получилась следующая функция:


 { Устанавливает русский LANGDRIVER для таблицы BDE (Paradox или dBASE)}
 { Таблица должна уже существовать на диске
   Если вы создаете таблицу динамически,
   не забудьте вызвать Table.CreateTable }
 
  procedure SetTableRussianLanguage(Table: TTable);
  var
    Props: CURProps;
    hDb: hDBIDb;
    TableDesc: CRTblDesc;
    OptDesc: FLDDesc;
    OptData: array [0..250] of Char;
    S: string;
  const   // Define propertly table type & codepage from list below
    LDName = 'ancyrr';   // Paradox ANSI Cyrillic 
    // LDName = 'cyrr';  // Paradox Cyrr 866
    // LDName = 'DB866ru0'; // dBASE RUS cp866 
 
  begin
  // Get handle (if table still not opened)
    Table.Open;
    // Get the table properties to determine table type...
    Check(DbiGetCursorProps(Table.Handle, Props));
 
    // Blank out the structure...
    FillChar(TableDesc, sizeof(TableDesc), 0);
    FillChar(OptDesc, SizeOf(OptDesc), #0);
    // Get the database handle from the table's cursor handle...
 
    Check( DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE,
           hDBIObj(hDb)));
 
    { If table name contain cyrillic or other native character,
       convert name to OEM }
 
    SetLength(S, Length(Table.TableName));
    CharToOEM(PChar(Table.TableName), @S[1]);
 
    // Put the table name in the table descriptor...
    StrPCopy(TableDesc.szTblName, S{Table.TableName});
    // Put the table type in the table descriptor...
    StrPCopy(TableDesc.szTblType, Props.szTableType);
    // Set the Pack option in the table descriptor to TRUE...
 
    StrCopy(OptDesc.szName, 'LANGDRIVER');
    OptDesc.iLen:=Length(LDName)+1;
    TableDesc.iOptParams:=1;
    TableDesc.pfldOptParams:=@OptDesc;
    TableDesc.pOptData:=@OptData;
    StrPCopy(OptData, LDName);
 
    // Close the table so the restructure can complete...
    Table.Close;
    // Call DbiDoRestructure...
    Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
  end;
 




Доступ к нетипизированному файлу

Вы можете организовать доступ к файлу "без определенного типа" следующим образом:


 var
   MyFile : file;
 begin
   assign(MyFile,Filename);
   reset(MyFile,1);
   {для записи}
   Blockwrite(MyFile,item,sizeof(item));
   {для чтения}
   BlockRead(MyFile,item,sizeof(item));
   close(MyFile);
 end;
 

Имейте в виду, что для чтения/записи нетипизированного файла необходимо использовать функции blockread и blockwrite, т.к. для использования нормальных функций Read/Write компилятору необходимо знать формат файла.




Предотвращение изменения вертикальных размеров окна

Вы должны перехватывать сообщение WM_GETMINMAXINFO:

Поместите это в декларацию класса формы:


 procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
 message WM_GETMINMAXINFO;
 

и в секции реализации:


 procedure TMyForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
 begin
   { --------------------------------------------------------------------}
   { Поместите ваши величины вместо                                      }
   { MIN_WIDTH, MIN_HEIGHT, MAX_WIDTH, MAX_HEIGHT                        }
   {                                                                     }
   { Для возможности только горизонтального изменение размера,           }
   { поместите значение свойства формы 'Height' в MIN_HEIGHT, MAX_HEIGHT }
   { --------------------------------------------------------------------}
   Msg.MinMaxInfo^.ptMinTrackSize := Point(MIN_WIDTH, MIN_HEIGHT);
   Msg.MinMaxInfo^.ptMaxTrackSize := Point(MAX_WIDTH, MAX_HEIGHT);
   inherited;
 end;
 




Не работает fsStayOnTop

Автор: Fred S.

Почему, если присвоить свойству FormStyle значение fsStayOnTop, форма так и не остается на самом верху?

Просто добавьте application.RestoreTopMosts в обработчик события формы OnPaint. Это ошибка.

Могли бы вы рассказать об этом чуть-чуть поподробнее? Delphi где-то в неправильном месте осуществляет вызов NormalizeTopMosts?

Borland говорит что это Windows, но это случается когда StayonTop-форма НЕ является главной формой. (Некоторые английские программисты чтобы получить эту отговорку потратили несколько сотен долларов, звоня в американскую службу помощи по телефону 1-800).




Как получить результирующим полем разницу между хранимой датой и текущей датой

Автор: Nomadic

В дополнение к высказываниям "настоящие" программисты считают, что в 1 км - 1024 м, в сутках 3 байта...

SELECT CAST((поле_с_датой -"NOW") AS INTEGER) FROM MyBase

Получишь результат в днях.




Предохранение от автодобавления записи

Автор: Bill Curtis (Borland International)

Мне необходимо как-то предотвратить автоматическое добавление записей в таблицу. Может быть предусмотреть какую-то хитрость для создания новой записи в табличной сетке?

Попробуй это (я правда оставил некоторый мусор после испытаний кодов клавиш). Для DBGridkeydown используй:


 begin
   s := 'ASCII код клавиши ' + IntToStr(Ord(key)) + ' десятичное';
   { showmessage(s); }
   s :=IntToStr(Ord(key));
 end;
 

И затем в TTable сделайте следующее:


 begin
   if s<>'45' then
     raise Eabort.create('');
   s:='';
 end;
 

Естественно, "s" должна быть объявлена глобально.




Как подавить реакцию Windows на CTRL+ALT+DEL, ALT+TAB, CTRL+ESC


Программист общается с человеком:
- Во прогресс! Пять лет назад сидел на "Синклере", теперь сижу на Пентиуме, а что будет еще через пять лет? Просто фигею!
- А что будет? Пересядешь ты через пять лет еще на какую-то фигню. Только когда будешь пересаживаться, посмотри в зеркало на свою задницу, на отпечатки клавиш. Вот тогда офигеешь!

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


 // Включение режима
 SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
 // Выключение режима
 SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
 

Кстати, SystemParametersInfo имеет еще кучу полезных ключей SPI_****, подробности см. в win32.hlp




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



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



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


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