Статьи по Delphi (019)…

Работа с последовательными портами 2.

Правда, по большей части это про DOS, а Windows посвящена только одна глава. Проверьте это.

unit Comm;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Forms;
type
  TCommEvent = procedure(Sender: TObject; Data: Char) of object;
  TCommErrEvent = procedure(Sender: TObject; Error: Integer) of object;
  TComm = class(TComponent)
  private
    Wnd: HWND;
    DCB: TDCB;
    CommID: Integer;
    Buf: array[0..2048] of char;
    NumChars: Integer;
    FOnCommErr: TCommErrEvent;
    FOnCommRecvd: TCommEvent;
    procedure CommWndProc(var Message: TMessage);
  public
    function Send(data: Char): Boolean;
    function Connect: Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor destroy; override;
  published
    property OnCommErr: TCommErrEvent read FOnCommErr write FOnCommErr;
    property OnCommRecvd: TCommEvent read FOnCommRecvd write FOnCommRecvd;
  end;
procedure Register;
implementation
constructor TComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Wnd := AllocateHwnd(CommWndProc);
end;
procedure TComm.CommWndProc(var Message: TMessage);
var
  Error, count: Integer;
  Stat: TComStat;
begin
  if Message.Msg = WM_COMMNOTIFY then
  begin
    Message.Result := 0;
    GetCommEventMask(CommId, $3FFF);
    NumChars := ReadComm(CommID, @Buf, 2048);
    Error := GetCommError(CommId, Stat);
    if Error = 0 then
    begin
      if Assigned(FOnCommRecvd) then
      begin
        for count := 0 to NumChars - 1 do
          FOnCommRecvd(Self, Buf[count]);
      end;
    end
    else
    begin
      if Assigned(FOnCommErr) then
      begin
        FOnCommErr(Self, Error);
      end;
    end;
  end;
end;
function TComm.Send(data: Char): Boolean;
var
  Error: Integer;
begin
  Error := TransmitCommChar(CommId, data);
  if Error < 0 then
    Result := False
  else
    Result := True;
end;
function TComm.Connect: Boolean;
var
  Config: array[0..20] of Char;
begin
  CommId := OpenComm('COM2', 2048, 2048);
  StrCopy(Config, 'com2:96,n,8,1'); {Здесь меняем настройки порта}
  BuildCommDCB(Config, DCB);
  DCB.ID := CommId;
  SetCommState(DCB);
  EnableCommNotification(CommID, Wnd, 1, -1);
  SetCommEventMask(CommId, ev_RXChar);
  Result := True;
end;
destructor TComm.destroy;
begin
  CloseComm(CommID);
  DeallocateHwnd(Wnd);
  inherited destroy;
end;
procedure Register;
begin
  RegisterComponents('Samples', [TComm]);
end;
end.

Как работать со всеми ячейками таблицы в WebBrowsere.

Пример показывает как добавить содержимое каждой ячейки в TMemo:

procedure TForm1.Button1Click(Sender: TObject); 
var
  i, j: integer; 
  ovTable: OleVariant;
begin 
  // Use first table
  ovTable := WebBrowser1.OleObject.Document.all.tags('TABLE').item(0);
 
  for i := 0 to (ovTable.Rows.Length - 1) do
  begin
    for j := 0 to (ovTable.Rows.Item(i).Cells.Length - 1) do
    begin
      Memo1.Lines.Add(ovTable.Rows.Item(i).Cells.Item(j).InnerText;
    end;
  end;
end;

Не работает функция Writeln.

Для того, чтобы Delphi "увидела" функцию Writeln, включите WinCrt в список используемых модулей.

Вывод надписи поверх всех окон.

Автор: Vit WEB-сайт: http://forum.vingrad.ru

procedure WriteDC(s: string);
var
  c: TCanvas;
begin
  c := TCanvas.Create;
  c.Brush.Color := clBlue;
  c.Font.color := clYellow;
  c.Font.name := 'Fixedsys';
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  c.TextOut(screen.Width - c.TextWidth(s) - 2, screen.Height - 43, s);
  c.free;
end;

Пишем свой текст в Меню.

Когда играешь во встроенную в Windows игру freecell, то справа в меню постоянно пишется сколько осталось карт. Давайте посмотрим, как это делается.

Перво наперво положим компонент главного меню на форму. Теперь установим свойство OwnerDraw в true. Далее создайте, то что Вы хотите вырисовывать в меню и создайте OnDrawItem. И добавьте в него следующую строку:

ACanvas.TextOut(1, ARect.Top + 1, 'I''m in the MainMenuDrawbar'); 

Не забудьте, если Вы используете изменяющуюся переменную, то измените её в другой функции и всё что надо будет сделать - это вызвать API функцию DrawMenuBar.

Если Вы используете Delphi 2,3 пользуйтесь сообщениями WM_MESUREITEM и WM_DRAWITEM, чтобы сделать данный эффект.

Сохранение и чтение из потока данных объекта.

Для чтения и записи на диск большого количества записей данных объекта я использовал TFileStream и TMemoryStream. Ниже я привел пример, сохраняющий на диске c помощью потока содержание контейнера DataArray, насчитывающего несколько тысяч записей объектов:

DataStream := TFileStream.Create('vccmem.dat', fmCreate);
MakeDate := FormatDateTime('mmmm d, yyyy',date);
DataStream.Write(MakeDate, SizeOf(MakeDate));
RCount := DataArray.Size;
DataStream.Write(RCount,SizeOf(RCount));
for q := 1 to DataArray.Size do
begin
  Application.ProcessMessages;
  ARecord := DataArray[q] as TNameRecord;
  DataStream.Write(ARecord.id, SizeOf(ARecord.id));
  DataStream.Write(ARecord.first_name, SizeOf(ARecord.first_name));
  DataStream.Write(ARecord.last_name, SizeOf(ARecord.last_name));
  DataStream.Write(ARecord.title, SizeOf(ARecord.title));
  DataStream.Write(ARecord.address, SizeOf(ARecord.address));
  DataStream.Write(ARecord.city, SizeOf(ARecord.city));
  DataStream.Write(ARecord.state, SizeOf(ARecord.state));
  DataStream.Write(ARecord.zip, SizeOf(ARecord.zip));
  DataStream.Write(ARecord.phone, SizeOf(ARecord.phone));
  DataStream.Write(ARecord.fax, SizeOf(ARecord.fax));
  DataStream.Write(ARecord.e_mail, SizeOf(ARecord.e_mail));
end;
DataStream.Destroy;

А вот код, но на этот раз загружающий данные в память при запуске приложения и создающие контейнер данных с именем NameArray:

DataStream := TMemoryStream.Create;
DataStream.LoadFromFile('vccmem.dat');
DataStream.Read(MakeDate, SizeOf(MakeDate));
DataStream.Read(RCount, SizeOf(RCount));
for q := 1 to RCount do
begin
  NameRecord := TNameRecord.Create;
  DataStream.Read(NameRecord.id, SizeOf(NameRecord.id));
  DataStream.Read(NameRecord.first_name,
    SizeOf(NameRecord.first_name));
  DataStream.Read(NameRecord.last_name,
    SizeOf(NameRecord.last_name));
  DataStream.Read(NameRecord.title, SizeOf(NameRecord.title));
  DataStream.Read(NameRecord.address, SizeOf(NameRecord.address));
  DataStream.Read(NameRecord.city, SizeOf(NameRecord.city));
  DataStream.Read(NameRecord.state, SizeOf(NameRecord.state));
  DataStream.Read(NameRecord.zip, SizeOf(NameRecord.zip));
  DataStream.Read(NameRecord.phone, SizeOf(NameRecord.phone));
  DataStream.Read(NameRecord.fax, SizeOf(NameRecord.fax));
  DataStream.Read(NameRecord.e_mail, SizeOf(NameRecord.e_mail));
  NameArray.Insert(NameRecord);
end;

Пишем ScreenSaver в Delphi.

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

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

Типичный код для этих процедур показан ниже.

Вы должны быть уверены, что Ваша форма создана со стилем fsStayOnTop. Вы так же должны быть уверены, что только один экземпляр Вашей программы будет запущен в системе. И в заключении Вам необходимо включить директиву компилятора {$D "Programname Screensaver"} в Ваш проект (*.dpr).

После того, как Вы скомпилируете программу, измените расширение файла на SCR и скопируйте его в Вашу системную папку \WINDOWS\SYSTEM .

var
  crs : TPoint; {первоначально расположение курсора мышки}
procedure TScrForm.FormShow(Sender: TObject);
{starts the screensaver}
begin
  WindowState := wsMaximized; {окошко будет на полный экран}
  GetCursorPos(crs); {получаем позицию курсора}
  Application.OnMessage := DeactivateScrSaver; {проверяем мышку/клавиатуру}
  ShowCursor(false); {скрываем курсор}
  {начинаем отображение скринсейвера...}
  //
end; {процедура TScrForm.FormShow}
procedure TScrForm.FormHide(Sender: TObject);
{возвращаем управление пользователю}
begin
  Application.OnMessage := nil; {запрещаем сообщения}
  {останавливаем скринсейвер...}
  //
  ShowCursor(true); {возвращаем курсор назад}
end; {procedure TScrForm.FormHide}
procedure TScrForm.DeactivateScrSaver(var Msg : TMsg; var Handled : boolean);
{определение движения мышки или нажатия на клавиатуре}
var
  done: boolean;
begin
  if Msg.message = WM_MOUSEMOVE then {сдвинулась мышка}
    done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
    (Abs(HIWORD(Msg.lParam) - crs.y) > 5)
  else {key / mouse нажаты?}
    done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
    (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or
    (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or
    (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or
    (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN);
  if done then
    Close;
end; {procedure TScrForm.DeactivateScrSaver}

Написание программ на чистом API.

program SmallPrg;
uses
  Windows, Messages;
const
  WinName = 'MainWClass';
function MainWndProc(Window: HWnd; AMessage, WParam, LParam: Longint): Longint; stdcall;
begin
  //подпрограмма обработки сообщений
  case AMessage of
    WM_DESTROY:
    begin
      PostQuitMessage(0);
      Result := 0;
      Exit;
    end;
    else
      Result := DefWindowProc(Window, AMessage, WParam, LParam);
  end;
end;
function InitApplication: Boolean;
var
  wcx: TWndClass;
begin
  //Заполняем структуру TWndClass
  // перерисовываем, если размер изменяется
  wcx.style := CS_HREDRAW or CS_VREDRAW;
  // адрес оконной процедуры
  wcx.lpfnWndProc := @MainWndProc;
  wcx.cbClsExtra := 0;
  wcx.cbWndExtra := 0;
  // handle to instance
  wcx.hInstance := hInstance;
  // загружаем стандандартную иконку
  wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
  // загружаем стандартный курсор
  wcx.hCursor := LoadCursor(0, IDC_ARROW);
  // делаем светло-серый фон
  wcx.hbrBackground := COLOR_WINDOW;
  // пока нет главного меню
  wcx.lpszMenuName := nil;
  // имя класса окна
  wcx.lpszClassName := PChar(WinName);
  // Регистрируем наш класс окна.
  Result := RegisterClass(wcx) <> 0;
end;
function InitInstance: HWND;
begin
  // Создаем главное окно.
  Result := CreateWindow(
  // имя класса окна
  PChar(WinName),
  // заголовок
  'Small program',
  // стандартный стиль окна
  WS_OVERLAPPEDWINDOW,
  // стандартные горизонтальное, вертикальное положение, ширина и высота
  Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT),
  0,//нет родительского окна
  0,//нет меню
  hInstance, // handle to application instance
  nil); // no window-creation data
end;
var
  hwndMain: HWND;
  AMessage: msg;
begin
  if (not InitApplication) then
    MessageBox(0, 'Ошибка регистрации окна', nil, mb_Ok)
  else
  begin
    hwndMain := InitInstance;
    if (hwndMain = 0) then
      MessageBox(0, 'Ошибка создания окна', nil, mb_Ok)
    else
    begin
      // Показываем окно и посылаем сообщение WM_PAINT оконной процедуре
      ShowWindow(hwndMain, CmdShow);
      UpdateWindow(hwndMain);
      while (GetMessage(AMessage, 0, 0, 0)) do
      begin
        TranslateMessage(AMessage);
        DispatchMessage(AMessage);
      end;
    end;
  end;
end.

Написание программ на чистом API 2.

Для этого нам необходимо:

// 1. Зарегистрировать класс окна для окна главной формы.
function InitApplication: Boolean;
var
  wcx: TWndClass;
begin
//Заполняем структуру TWndClass
    // перерисовываем, если размер изменяется
    wcx.style := CS_HREDRAW or CS_VREDRAW;
    // адрес оконной процедуры
    wcx.lpfnWndProc := @MainWndProc;
    wcx.cbClsExtra := 0;
    wcx.cbWndExtra := 0;
    // handle to instance
    wcx.hInstance := hInstance;
    // загружаем стандандартную иконку
    wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
    // загружаем стандартный курсор
    wcx.hCursor := LoadCursor(0, IDC_ARROW);
    // делаем светло-серый фон
    wcx.hbrBackground := COLOR_WINDOW;
    // пока нет главного меню
    wcx.lpszMenuName :=  nil;
    // имя класса окна
    wcx.lpszClassName := PChar(WinName);
    // Регистрируем наш класс окна.
    Result := RegisterClass(wcx) <> 0;
end;
// 2. Написать подпрограмму обработки оконных сообщений.
function MainWndProc(Window: HWnd; AMessage, WParam,
                    LParam: Longint): Longint; stdcall; export;
begin
  //подпрограмма обработки сообщений
  case AMessage of
    WM_DESTROY: begin
      PostQuitMessage(0);
      Exit;
    end;
    else
       Result := DefWindowProc(Window, AMessage, WParam, LParam);
  end;
end;
// 3. Создать главное окно приложения.
function InitInstance: HWND;
begin
  // Создаем главное окно.
  Result := CreateWindow(
   // имя класса окна
   PChar(WinName),
   // заголовок
   'Small program',
   // стандартный стиль окна
   WS_OVERLAPPEDWINDOW,
   // стандартные горизонтальное, вертикальное положение, ширина и высота
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   0,//нет родительского окна
   0,//нет меню
   hInstance, // handle to application instance
   nil);      // no window-creation data
end;
// 4. Написать тело программы.
var
  hwndMain: HWND;
  AMessage: msg;
begin
    if (not InitApplication) then
    begin
      MessageBox(0, 'Ошибка регистрации окна', nil, mb_Ok);
      Exit;
    end;
    hwndMain := InitInstance;
    if (hwndMain = 0) then
    begin
      MessageBox(0, 'Ошибка создания окна', nil, mb_Ok);
      Exit;
    end
    else
    begin
      // Показываем окно и посылаем сообщение WM_PAINT оконной процедуре
      ShowWindow(hwndMain, CmdShow);
      UpdateWindow(hwndMain);
    end;
    while (GetMessage(AMessage, 0, 0, 0)) do
    begin
      //Запускаем цикл обработки сообщений
      TranslateMessage(AMessage);
      DispatchMessage(AMessage);
    end;
    Halt(AMessage.wParam);
end.
// 5. Запустить программу на исполнение. ;)

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

program SmallPrg;
uses Windows,  Messages;
const
  WinName = 'MainWClass';
function MainWndProc(Window: HWnd; AMessage, WParam,
                    LParam: Longint): Longint; stdcall; export;
begin
  //подпрограмма обработки сообщений
  case AMessage of
    WM_DESTROY: begin
      PostQuitMessage(0);
      Exit;
    end;
    else
       Result := DefWindowProc(Window, AMessage, WParam, LParam);
  end;
end;
function InitApplication: Boolean;
var
  wcx: TWndClass;
begin
//Заполняем структуру TWndClass
    // перерисовываем, если размер изменяется
    wcx.style := CS_HREDRAW or CS_VREDRAW;
    // адрес оконной процедуры
    wcx.lpfnWndProc := @MainWndProc;
    wcx.cbClsExtra := 0;
    wcx.cbWndExtra := 0;
    // handle to instance
    wcx.hInstance := hInstance;
    // загружаем стандандартную иконку
    wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
    // загружаем стандартный курсор
    wcx.hCursor := LoadCursor(0, IDC_ARROW);
    // делаем светло-серый фон
    wcx.hbrBackground := COLOR_WINDOW;
    // пока нет главного меню
    wcx.lpszMenuName :=  nil;
    // имя класса окна
    wcx.lpszClassName := PChar(WinName);
    // Регистрируем наш класс окна.
    Result := RegisterClass(wcx) <> 0;
end;
function InitInstance: HWND;
begin
  // Создаем главное окно.
  Result := CreateWindow(
   // имя класса окна
   PChar(WinName),
   // заголовок
   'Small program',
   // стандартный стиль окна
   WS_OVERLAPPEDWINDOW,
   // стандартные горизонтальное, вертикальное положение, ширина и высота
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   Integer(CW_USEDEFAULT),
   0,//нет родительского окна
   0,//нет меню
   hInstance, // handle to application instance
   nil);      // no window-creation data
end;
var
  hwndMain: HWND;
  AMessage: msg;
begin
    if (not InitApplication) then
    begin
      MessageBox(0, 'Ошибка регистрации окна', nil, mb_Ok);
      Exit;
    end;
    hwndMain := InitInstance;
    if (hwndMain = 0) then
    begin
      MessageBox(0, 'Ошибка создания окна', nil, mb_Ok);
      Exit;
    end
    else
    begin
      // Показываем окно и посылаем сообщение WM_PAINT оконной процедуре
      ShowWindow(hwndMain, CmdShow);
      UpdateWindow(hwndMain);
    end;
    while (GetMessage(AMessage, 0, 0, 0)) do
    begin
      //Запускаем цикл обработки сообщений
      TranslateMessage(AMessage);
      DispatchMessage(AMessage);
    end;
    Halt(AMessage.wParam);
end.

Писать в порт принтера.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

procedure Out32(portadresse: Word; wert: Byte);
 var
   val: Byte;
 begin
   val := Byte(wert);
   asm
     push dx
     mov dx,portadresse
     mov al,val
     out dx,al
     pop dx
   end;
 end;
 function Inp32(portadresse: Word): Byte;
 var
   val: Byte;
 begin
   asm
     push dx
     mov dx,portadresse
     in al,dx
     mov val,al
     pop dx
   end;
   Inp32 := Byte(val) and $00ff;
 end;
 // Example/Beispiel: 
  Out32($378, 0)  {= Dataport all 8 Bit Low}
   Out32($378, (Inp32($378) or 1); {Dataport Bit 1 High}
   Out32($378, (Inp32($378) and 254);  {Datap. Bit 1, Low}

Как писать Win32API приложения на Delphi.

Главная пробема, возникающая при написании WinAPI приложений - это неудобство ручного создания всех окон приложения. Требуется вызывать функцию CreateWindow для каждого (в том числе и дочернго) окна программы, а затем еще и менять шрифт в некоторых из них. Лучшим на мой взгляд выходом из этой ситуации является использование ресурсов диалоговых окон (dialog box resources) для соэдания всех окон приложения. В этой статье я расскажу как это делается в Delphi на примере простоо приложения с одним главным и двумя (модальными) окнами.

Шаг 1. Создание ресурсов диалоговых окон

Для создания ресурсов я использовал редактор ресурсов из состава Borland C++ 5.02, и поэтому все скриншоты сделаны с него. В Borland Resource Workshop 4.5 все почти аналогично. Создаем главное окно, вот его код:

500 DIALOGEX 0, 0, 240, 117
EXSTYLE WS_EX_DLGMODALFRAME | WS_EX_APPWINDOW | WS_EX_CLIENTEDGE
STYLE DS_MODALFRAME | DS_3DLOOK | DS_CENTER | WS_OVERLAPPED | WS_VISIBLE | WS_CAPTION | 
WS_SYSMENU | WS_MINIMIZEBOX
class "WndClass1"
CAPTION "Главное окно приложения"
MENU 300
FONT 8, "MS Sans Serif", 400, 0
LANGUAGE LANG_RUSSIAN , 0
{
CONTROL "OK", IDOK, "BUTTON", BS_DEFPUSHBUTTON | BS_CENTER | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
19, 94, 50, 14, WS_EX_CLIENTEDGE
CONTROL "Cancel", IDCANCEL, "BUTTON", BS_PUSHBUTTON | BS_CENTER | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
96, 94, 50, 14, WS_EX_CLIENTEDGE
CONTROL "Help", IDHELP, "BUTTON", BS_PUSHBUTTON | BS_CENTER | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
172, 94, 50, 14, WS_EX_CLIENTEDGE
CONTROL "Группа", -1, "button", BS_GROUPBOX | BS_RIGHT | WS_CHILD | WS_VISIBLE | WS_GROUP, 
20, 9, 100, 76
CONTROL "Кнопка 1", 105, "button", BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
28, 21, 60, 12
CONTROL "Кнопка 2", 106, "button", BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
28, 37, 60, 12
CONTROL "Кнопка 3", 107, "button", BS_AUTORADIOBUTTON | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 
28, 53, 60, 12
CONTROL "ListBox1", 108, "listbox", LBS_NOTIFY | LBS_SORT | LBS_NOINTEGRALHEIGHT | WS_CHILD | 
WS_VISIBLE | WS_BORDER | WS_TABSTOP, 
132, 13, 92, 72
}

Обратите внимание на поле CLASS. В нем должно стоять то же значение, что и в поле lpszClassName записи TWndClassEx основной программы. В редакторе ресурсов значение этого поля можно изменить в окне свойств ресурса. В Borland C++ оно выглядит так:

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

Шаг 2. Основная программа

Текст программы в нашем случае несколько отличается от текста, например, winmin. Регистрация оконного класса:

wc.cbSize:=sizeof(wc);
wc.style:=cs_hredraw or cs_vredraw;
wc.lpfnWndProc:=@WindowProc;
wc.cbClsExtra:=0;
wc.cbWndExtra:=DLGWINDOWEXTRA;
wc.hInstance:=HInstance;
wc.hIcon:=LoadIcon(hInstance, 'MAINICON');
wc.hCursor:=LoadCursor(0,idc_arrow);
wc.hbrBackground:=COLOR_BTNFACE+1;
wc.lpszMenuName:=nil;
wc.lpszClassName:='WndClass1';
RegisterClassEx(wc);

Обратите внимание, что в поле cbWindowExtra стоит константа DLGWINDOWEXTRA, если бы её там не было, нам не удалось бы создать главное окно, основанное на ресурсе Dialog Box. Кроме того, в поле lpszClassName стоит то же значение, что и в соответствующем поле описания ресурса окна.

Итак, класс создан и зарегистрирован, теперь создаем главное окно из ресурса:

MainWnd:=CreateDialog(hInstance, '#500', 0, nil);

Напоминаю, что '#500' значит имя ресурса окна. Не забудьте подключить откомпилированный файл сценария ресурса к программе при помощи директивы {$r ...}.

Шаг 3. Оконная функция

Оконная функция ничем не отличается от обычной:

function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam;
         Lparam: Lparam): Lresult; stdcall;
var
  nCode, ctrlID, size: word;
  pt: TPoint;
  s: string;
begin
  case msg of
  wm_command:
  begin
    nCode:=hiWord(wParam);
    ctrlID:=loWord(wParam);
    case ctrlID of
      IDHELP:
      begin
        DialogBox(hInstance,'#501',wnd,@DialogFunc);
      end;
      IDOK:
      begin
        DialogBoxParam(hInstance,'#503',wnd,@DialogFunc2, Integer(pd));
        s := 'Login: '+pd^.login;
        s := s + ' ' + 'Pass: '+pd^.pass;
        ListBox_AddString(lb, s);
      end;
      IDCANCEL:
      begin
        DestroyWindow(wnd);
      end;
    end;
  end;
  wm_destroy :
  begin
    Dispose(pd);
    postquitmessage(0); exit;
    Result:=0;
  end;
  else
    Result := DefWindowProc(wnd, msg, wparam, lparam);
  end;
end;

Шаг 4. Цикл сбора сообщений

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

while GetMessage(Mesg, 0, 0, 0) do
begin
  if mainWnd<>0 then
    if IsDialogMessage(mainWnd,Mesg) then
      continue;
  TranslateMessage(Mesg);
  DispatchMessage(Mesg);
end;

После нажатия кнопки "ОК" появляется еще одно окно. Если в нем ввести текст и нажать "ОК", этот текст будет добавлен в Listbox.

Что нужно давать WSAAsyncSelect в качестве параметра handle.

Что нужно давать WSAAsyncSelect в качестве параметра handle, если тот запускается и используется в dll (init), и никакой формы (у которой можно было бы взять этот handle) в этой dll не создается?

const
  WM_ASYNCSELECT = WM_USER + 0;
type
  TNetConnectionsManager = class(TObject)
  protected
    FWndHandle: HWND;
    procedure WndProc(var MsgRec: TMessage);
    ...
  end;
constructor TNetConnectionsManager.Create
begin
  inherited Create;
  FWndHandle := AllocateHWnd(WndProc);
  ...
end;
destructor TNetConnectionsManager.Destroy;
begin
  ...
    if FWndHandle <> 0 then
    DeallocateHWnd(FWndHandle);
  inherited Destroy;
end;
procedure TNetConnectionsManeger.WndProc(var MsgRec: TMessage);
begin
  with MsgRec do
    if Msg = WM_ASYNCSELECT then
      WMAsyncSelect(MsgRec)
    else
      DefWindowProc(FWndHandle, Msg, wParam, lParam);
end;

Но рекомендую посмотреть WinSock2, в котором можно:

WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE );
WSAWaitForMultipleEvents( ... );
WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents );

То есть, обойтись без окон и без очереди сообщений windows, а заодно иметь возможность работать и с IPX/SPX, и с netbios.

Использование функции wsprintf.

Оформил: DeeCo

Автор: Виктор Кода.

Часто необходимо вывести (к примеру, даже в окошко с MB_OK) какое-то значение, будь то код ошибки типа HRESULT или результат работы какой-либо функции. Простейшее решение - использовать IntToStr() из модуля sysutils.pas. Однако в этом случае размер минимальной программы на Delphi увеличится с 16 до 41 кб, что лично меня очень неудовлетворяет. Хочется получить реальное преимущество в размерах, раз уж не используется VCL. Есть и другое объяснение - хотя мы и живём в эпоху быстрых процессоров и ёмких HDD, следить за качеством кода программ и его размерами обязывает культура программирования. В конце-концов это просто неразумно - ради одной функции тащить весь код из sysutils.pas и sysconst.pas. Складывается глупейшая ситуация - ради преобразования чисел в строку приходится мириться с тем, что к готовому exe-модулю подключаются многочисленные resourcestring и хлам в виде кучи ненужного кода.

function wsprintf(Output: PChar; Format: PChar): Integer; stdcall;

WINUSERAPI int WINAPIV wsprintfA(LPSTR, LPCSTR, ...);

Я всё-таки нашёл способ приспособить wsprintf() для своих нужд. Выход - описать её самостоятельно в своей программе так:

function wsprintf(lpOut: LPSTR; lpFmt: LPCTSTR; p: Pointer): Integer;
  stdcall; external 'user32.dll' name 'wsprintfA';

var
  szMessage: PChar;
  GetMem(szMessage, 256); // Определяем размер строки в памяти
  wsprintf(szMessage, 'Number %d', Pointer(899034));
  MessageBox(0, szMessage, 'Сообщение', MB_OK);

Полную документацию по функции wsprintf() можно найти в справке Delphi. Добавлю, что для корректности можно приводить передаваемые значения не к типу Pointer, а к Pinteger - для типа Integer, PUINT - для целых беззнаковых и т. д.

Примеры форматирования строк с использованием API-функции wvsprintf.

Автор: Внук WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Примеры форматирования строк с использованием API-функции wvsprintf
Примеры показывают приемы использования функции wvsprintf в Delphi для
форматирования строк. Эта функция входит в состав Windows API
(реализована в user32.dll), поэтому не требует подключения модуля
SysUtils по сравнению с аналогичной функцией Format.
Зависимости: Windows
Автор:       Внук, Zhigalin@poria.ru, ICQ:60571446, Самара
Copyright:   Внук
Дата:        29 мая 2002 г.
***************************************************** }
// Пример использования функции wvsprintf с двумя параметрами разного типа
function WinFormat(out TargetString: AnsiString): Boolean;
const
  FormatStr = 'String Parameter:"%s", Number Parameter:%05d';
var
  StrParam: AnsiString;
  NumberParam, FormatResult: Integer;
  ParamArray: array[0..1] of Pointer;
begin
  NumberParam := 105; // Задаем значение первого параметра
  StrParam := 'Hello'; // Задаем значение второго параметра
  SetLength(TargetString, 50); // Должно быть достаточно места для результата.
  // Без этой строки работать не будет
  ParamArray[0] := @StrParam[1];
  ParamArray[1] := Pointer(NumberParam);
  FormatResult := wvsprintf(PChar(TargetString), FormatStr, PChar(@ParamArray));
  if FormatResult < Length(FormatStr) then // В случае ошибки значение функции
    // меньше длины шаблонной строки
  begin
    TargetString := '';
    Result := False;
  end
  else
    result := True;
end;
// Пример использования функции wvsprintf с одним параметром
function SimpleWinFormat(out TargetString: AnsiString): Boolean;
const
  FormatStr = 'Number Parameter:%05d';
var
  NumberParam, FormatResult: Integer;
begin
  NumberParam := 112;
  SetLength(TargetString, 50); // Должно быть достаточно места для результата.
  // Без этой строки работать не будет
  FormatResult := wvsprintf(PChar(TargetString), FormatStr,
    PChar(@NumberParam));
  if FormatResult < Length(FormatStr) then // В случае ошибки значение функции
    // меньше длины шаблонной строки
  begin
    TargetString := '';
    Result := False;
  end
  else
    result := True;
end;

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

uses Dialogs, ...;
...
var
  S: AnsiString;
  ...
begin
  ...
    if WinFormat(S) then
    ShowMessage(S)
  else
    ShowMessage('An error has been occured!');
  if SimpleWinFormat(S) then
    ShowMessage(S)
  else
    ShowMessage('An error has been occured!');
  ...
end;
...

Как импортировать данные из Excel в StringGrid.

uses
  ComObj;
function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean;
const
  xlCellTypeLastCell = $0000000B;
var
  XLApp, Sheet: OLEVariant;
  RangeMatrix: Variant;
  x, y, k, r: Integer;
begin
  Result := False;
  // Create Excel-OLE Object
  XLApp := CreateOleObject('Excel.Application');
  try
    // Hide Excel
    XLApp.Visible := False;
    // Open the Workbook
    XLApp.Workbooks.Open(AXLSFile);
    // Sheet := XLApp.Workbooks[1].WorkSheets[1];
    Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1];
    // In order to know the dimension of the WorkSheet, i.e the number of rows
    // and the number of columns, we activate the last non-empty cell of it
    Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;
    // Get the value of the last row
    x := XLApp.ActiveCell.Row;
    // Get the value of the last column
    y := XLApp.ActiveCell.Column;
    // Set Stringgrid's row &col dimensions.
    AGrid.RowCount := x;
    AGrid.ColCount := y;
    // Assign the Variant associated with the WorkSheet to the Delphi Variant
    RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;
    //  Define the loop for filling in the TStringGrid
    k := 1;
    repeat
      for r := 1 to y do
        AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R];
      Inc(k, 1);
      AGrid.RowCount := k + 1;
    until k > x;
    // Unassign the Delphi Variant Matrix
    RangeMatrix := Unassigned;
  finally
    // Quit Excel
    if not VarIsEmpty(XLApp) then
    begin
      // XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
      Result := True;
    end;
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Xls_To_StringGrid(StringGrid1, 'C:\Table1.xls') then
    ShowMessage('Table has been exported!');
end;

Обмен информацией в формате XML.

Для загрузки и анализа документа в Delphi рассмотрим следующий код.

procedure LoadOnixDoc(const FileName: string);
var
  XML: variant;
  Node, mainNode, childNodes: variant;
  i: integer;
  TreeNode: TTreeNode;
  procedure LoadItems(TreeNode: TTreeNode; Node: variant);
  var
    i: integer;
  begin
    TreeNode := TV.Items.AddChild(TreeNode, Node.nodeName);
    TreeNode.ImageIndex := TreeNode.Level;
    TreeNode.SelectedIndex := TreeNode.ImageIndex;
    if Node.nodeName = '#text' then
    begin
      TreeNode.Text := Node.nodeValue;
      TV.SetNodeBoldState(TreeNode, true);
    end;
    for i := 0 to Node.childNodes.length - 1 do
      LoadItems(TreeNode, Node.childNodes.item[i]);
  end;
begin
  XML := CreateOleObject('Microsoft.XMLDOM');
  XML.load(FileName);
  if XML.parseError.reason <> '' then
  begin
    ShowMessage(XML.parseError.reason);
  end
  else
  begin
    mainNode := XML.documentElement;
    childNodes := mainNode.childNodes;
    LoadItems(nil, mainNode);
    TreeNode := TV.Items[1];
    while Assigned(TreeNode) do
    begin
      TreeNode.Expand(false);
      TreeNode := TreeNode.GetNextSibling;
    end;
    if Assigned(TV.Items[0]) then
      TV.Items[0].Expand(false);
  end;
end;

Пример документа XML Onix.

<?xml version="1.0" encoding="windows-1251"?>
<!DOCTYPE ONIXMessage SYSTEM "onix-international.dtd">
<ONIXMessage release="1.1">
	<FrоmСоmраnу>ТД Библио-Глобус</FrоmСоmраnу>
	<FromPerson>Kirillov Alexey kirillov@biblio-globus.u</FromPerson>
	<ToCompany>EDItEUR</ToCompany>
	<ToPerson>EDItEUR chief manager</ToPerson>
	<MessageNumber>1</MessageNumber>
	<SentDate>23.12.00</SentDate>
	<DefaultLanguageOfText>rus</DefaultLanguageOfText>
	<Product>
	 <RecordReference>247825</RecordReference>
	 <NotificationType>3</NotificationType>
	 <ISBN>966-7393-05-4</ISBN>
	 <ProductForm>BB</ProductForm>
	 <DistinctiveTitle>SQL энциклопедия пользователя</DistinсtivеТitlе>
	 <Contributor>
	 	<ContributorSequenceNumber>0</ContributorSequenceNumber>
		<ContributorRole>A01</ContributorRole>
		<РеrsоnNаmе>Х. Ладани</РеrsоnNаmе>
		<РеrsоnNаmеInvеrtеd>Ладани, Х.</PersonNameInverted>
		<ВiоgrарhiсаlNоtе>Книга раскрывает темы, которые часто
		 не описываются или достаточно кратко представлены в
		 руководствах пользователя
		 - подзапросы, структуры данных, представления,
		 производительность, целостность и защита данных.
		</BiographicalNote>
	</Contributor>
	<NumberOfPages>624</NumberOfPages>
	<ImрrintNаmе>ДиаСофт</ImрrintNаmе>
	<MediaFile>
		<MediaFileTypeCode>04</MediaFileTypeCode>
		<MediaFileFormatCode>03</MediaFileFormatCode>
		<MediaFileLinkTypeCode>06</MediaFileLinkTypeCode>
		<MediaFileLink>
		http://shop.biblio-globus.ru/photos1/05/58983.jpg
		</MediaFileLink>
	</MediaFile>
	<SupplyDetail>
		<SupplierName></SupplierName>
		<AvailabilityCode></AvailabilityCode>
		<Price>
			<PriceTypeCode>01</PriceTypeCode>
			<PriceAmount>425</PriceAmount>
			<CurrencyCode>RUB</CurrencyCode>
		</Price>
	</SupplyDetail>
	</Product>
</ONIXMessage>

Для работы Вам понадобятся файлы DTD: ONIX INTERNATIONAL DTD

Динамическое создание меню по XML-файлу.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  The following procedure allows you to build a menu from an XML file. 
  Special feature: You only need to specify the Name of the procedure which then 
  will be attached to a OnClick handler. 
  Note that the procedure must be declared as public. 
}
 { 
  Mit folgender Prozedur kann man aus einem XML-File ein Menu 
  erstellen lassen (einfach im OnCreate aufrufen). 
  Besonderes Feature: Im XML-File gebt ihr nur den Namen der Prozedur an, 
  die dem OnClick-Ereignis zugewiesen werden soll. 
  Die einzige Einschrankung besteht darin, dass diese Prozedur 
  published sein muss. 
  Bindet einfach diese Prozedur in euer Hauptformular ein: 
}
 procedure TMainForm.CreateMenuFromXMLFile;
   function Get_Int(S: string): Integer;
   begin
     Result := 0;
     try
       Result := StrToInt(S);
     except
     end;
   end;
   procedure AddRecursive(Parent: TMenuItem; Item: IXMLNode);
   var
     I: Integer;
     Node: TMenuItem;
     Child: IXMLNode;
     Address: TMethod;
   begin
     Node := TMenuItem.Create(Parent);
     if (Uppercase(Item.Attributes['CAPTION']) <> 'SEPERATOR') then
     begin
       Node.Caption := Item.Attributes['CAPTION'];
       if (Uppercase(Item.Attributes['ID']) <> 'NONE') then
       begin
         Address.Code := MethodAddress(Item.Attributes['ID']);
         Address.Data := Self;
         if (Item.ChildNodes.Count - 1 < 0) then
           Node.OnClick := TNotifyEvent(Address);
       end;
       if (Uppercase(Item.Attributes['SHORTCUT']) <> 'NONE') then
         Node.ShortCut := TextToShortCut(Item.Attributes['SHORTCUT']);
       Node.Checked := (Item.Attributes['CHECKED'] = '1');
     end
     else
       Node.Caption := '-';
     Node.Visible := (Item.Attributes['VISIBLE'] = '1');
     if Parent <> nil then
       Parent.Add(Node)
     else
       MainMenu.Items.Add(Node);
     for I := 0 to Item.ChildNodes.Count - 1 do
     begin
       Child := item.ChildNodes[i];
       if (Child.NodeName = 'ENTRY') then
         AddRecursive(Node, Child);
     end;
   end;
 var
   Root: IXMLMENUType;
   Parent: TMenuItem;
   I: Integer;
   Child: IXMLNode;
 begin
   XMLDocument.FileName := ExtractFilePath(Application.ExeName) + XMLFile;
   if not FileExists(XMLDocument.FileName) then
   begin
     MessageDlg('Menu-XML-Document nicht gefunden!', mtError, [mbOK], 0);
     Halt;
   end;
   XMLDocument.Active := True;
   Screen.Cursor := crHourglass;
   try
     Root := GetXMLMenu(XMLDocument);
     Parent := nil;
     for I := 0 to Root.ChildNodes.Count - 1 do
     begin
       Child := Root.ChildNodes[i];
       if (Child.NodeName = 'ENTRY') then
         AddRecursive(Parent, Child);
     end;
   finally
     Screen.Cursor := crDefault;
   end;
 end;
 {---------------------------------------------------------- 
  You also need the encapsulation of the XML-File. 
  ( Save it as unit and add it to your program. 
   Created with Delphi6 -> New -> XML Data Binding Wizard ) 
-----------------------------------------------------------}
 {---------------------------------------------------------- 
  Naturlich braucht man auch die Kapselung des XML-Files 
  (Als Unit speichern und ins Programm einbinden. 
  Die Datei wurde mit Delphi 6 -> Neu -> XML-Datenbindung erstellt): 
-----------------------------------------------------------}
 {***************************************************}
 {                                                   }
 {              Delphi XML-Datenbindung              }
 {                                                   }
 {         Erzeugt am: 27.06.2002 13:25:01           }
 {                                                   }
 {***************************************************}
 unit XMLMenuTranslation;
 interface
 uses xmldom, XMLDoc, XMLIntf;
 type
   { Forward-Deklarationen }
   IXMLMENUType  = interface;
   IXMLENTRYType = interface;
   { IXMLMENUType }
   IXMLMENUType = interface(IXMLNode)
     ['{8F36F5E2-834F-41D9-918F-9B1A441C9074}']
     { Zugriff auf Eigenschaften }
     function Get_ENTRY: IXMLENTRYType;
     { Methoden & Eigenschaften }
     property ENTRY: IXMLENTRYType read Get_ENTRY;
   end;
   { IXMLENTRYType }
   IXMLENTRYType = interface(IXMLNode)
     ['{AD85CD05-725E-40F8-A8D7-D6EC05FD4360}']
     { Zugriff auf Eigenschaften }
     function Get_CAPTION: WideString;
     function Get_VISIBLE: Integer;
     function Get_ID: Integer;
     function Get_ENTRY: IXMLENTRYType;
     procedure Set_CAPTION(Value: WideString);
     procedure Set_VISIBLE(Value: Integer);
     procedure Set_ID(Value: Integer);
     { Methoden & Eigenschaften }
     property Caption: WideString read Get_CAPTION write Set_CAPTION;
     property Visible: Integer read Get_VISIBLE write Set_VISIBLE;
     property ID: Integer read Get_ID write Set_ID;
     property ENTRY: IXMLENTRYType read Get_ENTRY;
   end;
   { Forward-Deklarationen }
   TXMLMENUType  = class;
   TXMLENTRYType = class;
   { TXMLMENUType }
   TXMLMENUType = class(TXMLNode, IXMLMENUType)
   protected
     { IXMLMENUType }
     function Get_ENTRY: IXMLENTRYType;
   public
     procedure AfterConstruction; override;
   end;
   { TXMLENTRYType }
   TXMLENTRYType = class(TXMLNode, IXMLENTRYType)
   protected
     { IXMLENTRYType }
     function Get_CAPTION: WideString;
     function Get_VISIBLE: Integer;
     function Get_ID: Integer;
     function Get_ENTRY: IXMLENTRYType;
     procedure Set_CAPTION(Value: WideString);
     procedure Set_VISIBLE(Value: Integer);
     procedure Set_ID(Value: Integer);
   public
     procedure AfterConstruction; override;
   end;
   { Globale Funktionen }
 function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
 function LoadMENU(const FileName: WideString): IXMLMENUType;
 function NewMENU: IXMLMENUType;
 implementation
 { Globale Funktionen }
 function GetXMLMENU(Doc: IXMLDocument): IXMLMENUType;
 begin
   Result := Doc.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;
 function LoadMENU(const FileName: WideString): IXMLMENUType;
 begin
   Result := LoadXMLDocument(FileName).GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;
 function NewMENU: IXMLMENUType;
 begin
   Result := NewXMLDocument.GetDocBinding('MENU', TXMLMENUType) as IXMLMENUType;
 end;
 { TXMLMENUType }
 procedure TXMLMENUType.AfterConstruction;
 begin
   RegisterChildNode('ENTRY', TXMLENTRYType);
   inherited;
 end;
 function TXMLMENUType.Get_ENTRY: IXMLENTRYType;
 begin
   Result := ChildNodes['ENTRY'] as IXMLENTRYType;
 end;
 { TXMLENTRYType }
 procedure TXMLENTRYType.AfterConstruction;
 begin
   RegisterChildNode('ENTRY', TXMLENTRYType);
   inherited;
 end;
 function TXMLENTRYType.Get_CAPTION: WideString;
 begin
   Result := ChildNodes['CAPTION'].Text;
 end;
 procedure TXMLENTRYType.Set_CAPTION(Value: WideString);
 begin
   ChildNodes['CAPTION'].NodeValue := Value;
 end;
 function TXMLENTRYType.Get_VISIBLE: Integer;
 begin
   Result := ChildNodes['VISIBLE'].NodeValue;
 end;
 procedure TXMLENTRYType.Set_VISIBLE(Value: Integer);
 begin
   ChildNodes['VISIBLE'].NodeValue := Value;
 end;
 function TXMLENTRYType.Get_ID: Integer;
 begin
   Result := ChildNodes['ID'].NodeValue;
 end;
 procedure TXMLENTRYType.Set_ID(Value: Integer);
 begin
   ChildNodes['ID'].NodeValue := Value;
 end;
 function TXMLENTRYType.Get_ENTRY: IXMLENTRYType;
 begin
   Result := ChildNodes['ENTRY'] as IXMLENTRYType;
 end;
 end.
 {--------------------------------------------------------------------- 
  Finally, I'll show you an example for the XML-File. 
  The Procedure Name is assigned to the ID which then will be called. 
---------------------------------------------------------------------}
 {--------------------------------------------------------------------- 
  Als Beispiel fur das XML-File hier noch eines aus 
  einem meiner Programme. 
  In ID steht der Name der Prozedur, die man als OnClick aufrufen will
   - denkt auch daran, dass diese Prozedur unbedingt als published
   deklariert sein muss, sonst liefert MethodAddress() Nil zuruck.
 ----------------------------------------------------------------------}
 { 
<?xml version="1.0" encoding="ISO-8859-1"?> 
<MENU> 
    <ENTRY CAPTION="Datei" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Beenden" VISIBLE="1" ID="CloseProgram" SHORTCUT="Strg+X" CHECKED="0"></ENTRY> 
    </ENTRY> 
    <ENTRY CAPTION="Anzeige" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Toolbar" VISIBLE="1" ID="ShowToolbar"  SHORTCUT="None" CHECKED="1"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Optionen" VISIBLE="1" ID="ShowOptionen"  SHORTCUT="Strg+O" CHECKED="0"></ENTRY> 
    </ENTRY> 
    <ENTRY CAPTION="News" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="Refresh" VISIBLE="1" ID="RefreshAll"  SHORTCUT="F5" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Administration" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="neue Nachricht hinzufugen" VISIBLE="1" ID="NewMarkedNews" SHORTCUT="Strg+N" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="markierte Nachricht bearbeiten" VISIBLE="1" ID="EditMarkedNews" SHORTCUT="Strg+E" CHECKED="0"></ENTRY> 
     <ENTRY CAPTION="markierte Nachricht loschen" VISIBLE="1" ID="DeleteMarkedNews" SHORTCUT="None" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Film hinzufugen" VISIBLE="1" ID="AddMPG" SHORTCUT="None" CHECKED="0"></ENTRY> 
     <ENTRY CAPTION="markierten Film loschen" VISIBLE="1" ID="DeleteMPG" SHORTCUT="None" CHECKED="0"></ENTRY> 
    </ENTRY> 
    </ENTRY> 
    <ENTRY CAPTION="Hilfe" VISIBLE="1" ID="None" SHORTCUT="None" CHECKED="0"> 
    <ENTRY CAPTION="LogView" VISIBLE="1" ID="ShowLog" SHORTCUT="Strg+L" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="eMail schreiben" VISIBLE="1" ID="WriteEMail" SHORTCUT="None" CHECKED="0"></ENTRY> 
    <ENTRY CAPTION="Seperator" VISIBLE="1"></ENTRY> 
    <ENTRY CAPTION="Uber" VISIBLE="1" ID="About" SHORTCUT="None" CHECKED="0"></ENTRY> 
    </ENTRY> 
</MENU> 
}

Парсер подавляющего большинства нотаций XML.

Автор: Delirium WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Парсер подавляющего большинства нотаций XML.
Для задачи десериализации мне потребовался парсер.
Основное преимущество - никак не связан с операционной системой
(в отличие от TXMLDocument), ну и разумеется - простота :)
Зависимости: SysUtils, StrUtils
Автор:       Delirium, VideoDVD@hotmail.com, ICQ:118395746, Москва
Copyright:   Delirium (Master BRAIN) 2003
Дата:        16 сентября 2003 г.
***************************************************** }
unit BNFXMLParser;
interface
uses SysUtils, StrUtils;
type
  PXMLNode = ^TXMLNode;
  TXMLValues = (TextNode, XMLNode);
  TXMLNode = record
    Name: string;
    Attributes: array of record
      Name: string;
      Value: string;
    end;
    SubNodes: array of record
      RecType: TXMLValues;
      case TXMLValues of
        TextNode: (Text: PString);
        XMLNode: (XML: PXMLNode);
    end;
    Parent: PXMLNode;
  end;
function BNFXMLTree(var Value: string): PXMLNode;
implementation
function fnTEG(var Node: PXMLNode; var Value: string): boolean; forward;
function fnVAL(var Node: PXMLNode; var Value: string): boolean; forward;
function fnATT(var Node: PXMLNode; var Value: string): boolean; forward;
function fnXML(var Node: PXMLNode; var Value: string): boolean;
var
  i: integer;
begin
  if (Pos('<', Value) > 0)
    and (Pos('>', Value) > Pos('<', Value))
    and (Pos('<', Value) <> Pos('</', Value)) then
  begin
    // Оганизую узел
    if Node = nil then
    begin
      New(Node);
      Node.Parent := nil;
    end
    else
    begin
      i := length(Node.SubNodes);
      Setlength(Node.SubNodes, i + 1);
      New(Node.SubNodes[i].XML);
      Node.SubNodes[i].RecType := XMLNode;
      Node.SubNodes[i].XML.Parent := Node;
      Node := Node.SubNodes[i].XML;
    end;
    Result := fnTEG(Node, Value);
  end // '<'
  else
    Result := True;
end;
function fnTEG(var Node: PXMLNode; var Value: string): boolean;
var
  i, i1, i2, i3: integer;
  S: string;
begin
  Result := False;
  i1 := Pos('<', Value);
  if i1 > 0 then
  begin
    i2 := PosEx('/>', Value, i1);
    i3 := PosEx('>', Value, i1);
    if (i2 > 0) and (i2 < i3) then
    begin // <abc/>
      // Value
      S := Copy(Value, i1 + 1, (i2 - i1) - 1);
      Delete(Value, i1, (i2 - i1) + 2);
      // TEXT, этот текст пренадлежит предку
      if Node.Parent <> nil then
      begin // Добавляюсь к предку
        i := length(Node.Parent.SubNodes);
        Setlength(Node.Parent.SubNodes, i + 1);
        New(Node.Parent.SubNodes[i].Text);
        Node.Parent.SubNodes[i].RecType := TextNode;
        Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) - 1);
      end;
      Delete(Value, 1, Pos('<', Value) - 1);
      //
      if fnVAL(Node, S) then
      begin // Вложенных тегов не бывает
        Node := Node.Parent;
        Result := fnXML(Node, Value);
      end;
    end
    else
    begin // <abc>...</abc>
      // Value
      S := Copy(Value, i1 + 1, (i3 - i1) - 1);
      Delete(Value, i1, (i3 - i1) + 1);
      // TEXT
      i := length(Node.SubNodes);
      Setlength(Node.SubNodes, i + 1);
      New(Node.SubNodes[i].Text);
      Node.SubNodes[i].RecType := TextNode;
      Node.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) - 1);
      Delete(Value, 1, Pos('<', Value) - 1);
      //
      if fnVAL(Node, S) then
      begin // Val
        // Проверяю закрытие тега, удаляю хвост и передаю управление предку
        if Pos('</' + AnsiLowerCase(Node.Name) + '>', AnsiLowerCase(Value)) = 1
          then
        begin
          Delete(Value, 1, Length('</' + Node.Name + '>'));
          // TEXT принадлежащий предку
          if Node.Parent <> nil then
          begin // Добавляюсь к предку
            i := length(Node.Parent.SubNodes);
            Setlength(Node.Parent.SubNodes, i + 1);
            New(Node.Parent.SubNodes[i].Text);
            Node.Parent.SubNodes[i].RecType := TextNode;
            Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value) -
              1);
          end;
          Delete(Value, 1, Pos('<', Value) - 1);
          Node := Node.Parent;
          Result := fnXML(Node, Value);
        end
        else
        begin
          // Обрабатываю вложенные теги, на выходе мой узел
          if fnXML(Node, Value) then
          begin
            // закрываю его
            if Pos('</' + AnsiLowerCase(Node.Name) + '>', AnsiLowerCase(Value))
              = 1 then
            begin
              Delete(Value, 1, Length('</' + Node.Name + '>'));
              // TEXT принадлежащий предку
              if Node.Parent <> nil then
              begin // Добавляюсь к предку
                i := length(Node.Parent.SubNodes);
                Setlength(Node.Parent.SubNodes, i + 1);
                New(Node.Parent.SubNodes[i].Text);
                Node.Parent.SubNodes[i].RecType := TextNode;
                Node.Parent.SubNodes[i].Text^ := Copy(Value, 1, Pos('<', Value)
                  - 1);
              end;
              Delete(Value, 1, Pos('<', Value) - 1);
            end;
            // Остальной XML - предку
            if Node.Parent <> nil then
              Node := Node.Parent;
            Result := fnXML(Node, Value);
          end;
        end;
      end; // Val
    end; // <abc>...</abc>
  end; // i1
end;
function fnVAL(var Node: PXMLNode; var Value: string): boolean;
begin
  Value := AnsiReplaceStr(Value, '''', '"');
  if (Pos(' ', Value) > 0)
    and (Pos('="', Value) > Pos(' ', Value)) then
  begin
    Node.Name := Trim(Copy(Value, 1, Pos(' ', Value) - 1)); // Название тега Name
    Delete(Value, 1, Pos(' ', Value));
    Result := fnATT(Node, Value);
  end // ' ' и ('="'
  else
  begin
    // Название тега Name
    Value := Trim(Value);
    if Pos(' ', Value) > 0 then
      Node.Name := Copy(Value, 1, Pos(' ', Value) - 1)
    else
      Node.Name := Value;
    Value := '';
    Result := True;
  end;
end;
function fnATT(var Node: PXMLNode; var Value: string): boolean;
begin
  Result := True;
  Value := Trim(Value);
  if Pos('="', Value) > 0 then
  begin
    Result := False;
    SetLength(Node.Attributes, Length(Node.Attributes) + 1);
    // Название атрибута
    Node.Attributes[Length(Node.Attributes) - 1].Name := Trim(Copy(Value, 1,
      Pos('="', Value) - 1));
    Delete(Value, 1, Pos('="', Value) + 1);
    if Pos('"', Value) > 0 then
    begin
      // Значение атрибута
      Node.Attributes[Length(Node.Attributes) - 1].Value := Copy(Value, 1,
        Pos('"', Value) - 1);
      Delete(Value, 1, Pos('"', Value));
      if Length(Value) > 0 then
        Result := fnATT(Node, Value)
      else
        Result := True;
    end;
  end;
end;
function BNFXMLTree(var Value: string): PXMLNode;
begin
  Result := nil;
  fnXML(Result, Value);
end;
end.

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

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  Node: PXMLNode;
  i: integer;
begin
  S := '<A> aaa1 ' + #13 +
    ' aaa2 aaa3 ' + #13 +
    ' <B>bbb ' + #13 +
    ' <C>ccc</C> ' + #13 +
    ' </B> ' + #13 +
    ' <D>ddd ' + #13 +
    ' <E eee="EEE"/> ' + #13 +
    ' </D> ' + #13 +
    '</A> ';
  Node := BNFXMLTree(S);
  for i := 0 to Length(Node.SubNodes) - 1 do
    case Node.SubNodes[i].RecType of
      TextNode: ShowMessage('Text = ' + Node.SubNodes[i].Text^);
      XMLNode: ShowMessage('XML Node name = ' + Node.SubNodes[i].XML.Name);
    end;
end;

Разбор XML.

Автор: Delirium WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Разбор XML
Данный прасер не такой универсальный, как предыдущий,
за то - почти в 1000 раз эффективнее!
Зависимости: Windows, Forms, SysUtils, StrUtils
Автор:       Delirium, VideoDVD@hotmail.com, ICQ:118395746, Москва
Copyright:   Delirium (Master BRAIN) 2003
Дата:        22 октября 2003 г.
***************************************************** }
unit BNFXMLParser2;
interface
uses Windows, Forms, SysUtils, StrUtils;
type
  PXMLNode = ^TXMLNode;
  PXMLTree = ^TXMLTree;
  TXMLAttr = record
    NameIndex, NameSize: integer;
    TextIndex, TextSize: integer;
  end;
  TXMLNode = record
    NameIndex, NameSize: integer;
    Attributes: array of TXMLAttr;
    TextIndex, TextSize: integer;
    SubNodes: array of PXMLNode;
    Parent: PXMLNode;
    Data: PString;
  end;
  TXMLTree = record
    Data: PString;
    TextSize: integer;
    NodesCount: integer;
    Nodes: array of PXMLNode;
  end;
function BNFXMLTree(Value: string): PXMLTree;
function GetXMLNodeName(Node: PXMLNode): string;
function GetXMLNodeText(Node: PXMLNode): string;
function GetXMLNodeAttr(AttrName: string; Node: PXMLNode): string;
implementation
function BNFXMLTree(Value: string): PXMLTree;
var
  LPos, k, State, CurAttr: integer;
  i: integer;
  CurNode: PXMLNode;
begin
  New(Result);
  Result^.TextSize := Pos('<', Value) - 1;
  New(Result^.Data);
  Result^.Data^ := Value;
  k := 0;
  State := 0;
  CurNode := nil;
  CurAttr := -1;
  for LPos := Result.TextSize + 1 to Length(Value) do
    case State of
      0: case Value[LPos] of
          '<':
            begin
              i := length(Result.Nodes);
              Setlength(Result.Nodes, i + 1);
              New(Result.Nodes[i]);
              Inc(k);
              if k mod 10 = 0 then
              begin
                Application.ProcessMessages;
                if k mod 100 = 0 then
                  SleepEx(1, True);
              end;
              CurNode := Result.Nodes[i];
              CurNode^.NameIndex := 0;
              CurNode^.NameSize := 0;
              CurNode^.TextIndex := 0;
              CurNode^.Parent := nil;
              CurNode^.Data := Result^.Data;
              State := 1;
            end;
        end;
      1: case Value[LPos] of
          ' ': ;
          '>': State := 9;
          '/': State := 10;
        else
          begin
            CurNode^.NameIndex := LPos;
            CurNode^.NameSize := 1;
            State := 2;
          end;
        end;
      2: case Value[LPos] of
          ' ': State := 3;
          '>': State := 9;
          '/': State := 10;
        else
          Inc(CurNode^.NameSize);
        end;
      3: case Value[LPos] of
          ' ': ;
          '>': State := 9;
          '/': State := 10;
        else
          begin
            i := length(CurNode^.Attributes);
            Setlength(CurNode^.Attributes, i + 1);
            CurNode^.Attributes[i].NameIndex := LPos;
            CurNode^.Attributes[i].NameSize := 1;
            CurAttr := i;
            State := 4;
          end;
        end;
      4: case Value[LPos] of
          '=': State := 5;
        else
          Inc(CurNode^.Attributes[CurAttr].NameSize);
        end;
      5: case Value[LPos] of
          '''': State := 6;
          '"': State := 7;
        end;
      6: case Value[LPos] of
          '''':
            begin
              CurNode^.Attributes[CurAttr].TextIndex := LPos;
              CurNode^.Attributes[CurAttr].TextSize := 0;
              State := 8;
            end;
        else
          begin
            CurNode^.Attributes[CurAttr].TextIndex := LPos;
            CurNode^.Attributes[CurAttr].TextSize := 1;
            State := 61;
          end;
        end;
      7: case Value[LPos] of
          '"':
            begin
              CurNode^.Attributes[CurAttr].TextIndex := LPos;
              CurNode^.Attributes[CurAttr].TextSize := 0;
              State := 8;
            end;
        else
          begin
            CurNode^.Attributes[CurAttr].TextIndex := LPos;
            CurNode^.Attributes[CurAttr].TextSize := 1;
            State := 71;
          end;
        end;
      61: case Value[LPos] of
          '''': State := 8;
        else
          Inc(CurNode^.Attributes[CurAttr].TextSize);
        end;
      71: case Value[LPos] of
          '"': State := 8;
        else
          Inc(CurNode^.Attributes[CurAttr].TextSize);
        end;
      8: case Value[LPos] of
          ' ': State := 3;
          '>': State := 9;
          '/': State := 10;
        end;
      9: case Value[LPos] of
          '>': ;
        else
          begin
            CurNode^.TextIndex := LPos;
            CurNode^.TextSize := 1;
            State := 11;
          end;
        end;
      10: case Value[LPos] of
          '>':
            begin
              CurNode := CurNode^.Parent;
              if CurNode = nil then
                State := 0
              else
                State := 9;
            end;
        end;
      11: case Value[LPos] of
          '<': State := 12;
        else
          Inc(CurNode^.TextSize);
        end;
      12: case Value[LPos] of
          '/': State := 10;
        else
          begin
            i := length(CurNode^.SubNodes);
            Setlength(CurNode^.SubNodes, i + 1);
            New(CurNode^.SubNodes[i]);
            Inc(k);
            if k mod 10 = 0 then
            begin
              Application.ProcessMessages;
              if k mod 100 = 0 then
                SleepEx(1, True);
            end;
            CurNode^.SubNodes[i]^.Parent := CurNode;
            CurNode^.SubNodes[i]^.Data := Result^.Data;
            CurNode^.SubNodes[i].NameIndex := LPos;
            CurNode^.SubNodes[i].NameSize := 1;
            CurNode^.SubNodes[i].TextIndex := 0;
            CurNode := CurNode^.SubNodes[i];
            State := 2;
          end;
        end;
    end;
  Result^.NodesCount := k;
end;
function GetXMLNodeName(Node: PXMLNode): string;
begin
  Result := Copy(Node^.Data^, Node^.NameIndex, Node^.NameSize);
end;
function GetXMLNodeText(Node: PXMLNode): string;
begin
  Result := Copy(Node^.Data^, Node^.TextIndex, Node^.TextSize);
end;
function GetXMLNodeAttr(AttrName: string; Node: PXMLNode): string;
var
  i: integer;
begin
  Result := '';
  if Length(Node^.Attributes) = 0 then
    exit;
  i := 0;
  while (i < Length(Node^.Attributes))
    and (AnsiLowerCase(AttrName) <> AnsiLowerCase(Trim(Copy(Node^.Data^,
      Node^.Attributes[i].NameIndex, Node^.Attributes[i].NameSize)))) do
    Inc(i);
  Result := Copy(Node^.Data^, Node^.Attributes[i].TextIndex,
    Node^.Attributes[i].TextSize);
end;
end.

XML сериализация объекта Delphi.

Оформил: DeeCo

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

{ пишет строку в выходящий поток. Исп-ся при сериализации }
procedure WriteOutStream(Value: string);
begin
  OutStream.Write(Pchar(Value)[0], Length(Value));
end;
{ Добавляет открывающий тег с заданным именем }
procedure addOpenTag(const Value: string);
begin
  WriteOutStream(CR + DupStr(TAB, Level) + '<' + Value + '>');
  inc(Level);
end;
{ Добавляет закрывающий тег с заданным именем }
procedure addCloseTag(const Value: string; addBreak: boolean = false);
begin
  dec(Level);
  if addBreak then
    WriteOutStream(CR + DupStr(TAB, Level));
  WriteOutStream('</' + Value + '>');
end;
{ Добавляет значение в результирующую строку }
procedure addValue(const Value: string);
begin
  WriteOutStream(Value);
end;

procedure TglXMLSerializer.SerializeInternal(Component: TObject; Level: integer
  = 1);
var
  PropInfo: PPropInfo;
  TypeInf, PropTypeInf: PTypeInfo;
  TypeData: PTypeData;
  i, j: integer;
  AName, PropName, sPropValue: string;
  PropList: PPropList;
  NumProps: word;
  PropObject: TObject;
begin
  { Playing with RTTI }
  TypeInf := Component.ClassInfo;
  AName := TypeInf^.Name;
  TypeData := GetTypeData(TypeInf);
  NumProps := TypeData^.PropCount;
  GetMem(PropList, NumProps * sizeof(pointer));
  try
    { Получаем список строк }
    GetPropInfos(TypeInf, PropList);
    for i := 0 to NumProps - 1 do
    begin
      PropName := PropList^[i]^.Name;
      PropTypeInf := PropList^[i]^.PropType^;
      PropInfo := PropList^[i];
      case PropTypeInf^.Kind of
        tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
          tkWChar, tkLString, tkWString, tkVariant:
          begin
            { Получение значения свойства }
            sPropValue := GetPropValue(Component, PropName, true);
            { Перевод в XML }
            addOpenTag(PropName);
            addValue(sPropValue); { Добавляем значение свойства в результат }
            addCloseTag(PropName);
          end;

tkClass: { Для классовых типов рекурсивная обработка }
begin
  addOpenTag(PropName);
  PropObject := GetObjectProp(Component, PropInfo);
  if Assigned(PropObject) then
  begin
    { Для дочерних свойств-классов - рекурсивный вызов }
    if (PropObject is TPersistent) then
      Result := Result + SerializeInternal(PropObject, Level);
    { Индивидуальный подход к некоторым классам }
    if (PropObject is TStrings) then { Текстовые списки }
    begin
      WriteOutStream(TStrings(PropObject).CommaText);
    end
    else if (PropObject is TCollection) then { Коллекции }
    begin
      Result := Result + SerializeInternal(PropObject, Level);
      for j := 0 to (PropObject as TCollection).Count - 1 do
      begin
        addOpenTag(TCollection(PropObject).Items[j].ClassName);
        SerializeInternal(TCollection(PropObject).Items[j], Level);
        addCloseTag(TCollection(PropObject).Items[j].ClassName, true);
      end
    end;
    { Здесь можно добавить обработку остальных классов: TTreeNodes, TListItems }
  end;
  addCloseTag(PropName, true);
end;

procedure Serialize(Component: TObject; Stream: TStream);
...
  WriteOutStream(PChar(CR + '<' + Component.ClassName + '>'));
SerializeInternal(Component);
WriteOutStream(PChar(CR + '</' + Component.ClassName + '>'));

XML сериализация объектов - Заключение.

Оформил: DeeCo

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

Применимость.

Производительность.

Документ: формат ONIX XML размером 10 мб.

Расширяемость.

TPerson = class;
TMyXMLMessage = class(TPersistent)
published
  property LanguageOfText: WideString;
  property ToPerson: TPerson;
end;
TPerson = class(TPersistent)
published
  property FirstName: WideString;
  property LastName: WideString;
end;

<TMyXMLMessage>
<LanguageOfText>english</LanguageOfText>
	<ToPerson>
		<FirstName>Osama</FirstName>
		<LastName>Unknoun</LastName>
	</ToPerson>
</TMyXMLMessage>

<TMyXMLMessage LanguageOfText="english">
	<ToPerson FirstName="Osama" LastName="Unknoun"/>
</TMyXMLMessage>

Компонент для XML сериализации.

Объединяя сказанное о сериализации, десериализации объектов и создании DTD соберем полноценный компонент для XML сериализации.

Компонент конвертирует компонент в XML и обратно в соответствии с published-интерфейсом класса компонента.

XML формируется в виде пар тегов с вложенными в них значениями. Атрибуты у тегов отсутствуют.

Тег верхнего уровня соответствует классу объекта. Вложенные теги соответствуют именам свойств. Для элементов коллекций контейнерный тег соответствует имени класса.

Вложенность тегов не ограничена и полностью повторяет published интерфейс класса заданного объекта.

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

Интерфейс:

procedure Serialize(Component: TObject; Stream: TStream); 

procedure DeSerialize(Component: TObject; Stream: TStream); 

property GenerateFormattedXML; // создавать форматированный XML код 
property ExcludeEmptyValues;   // пропускать пустые значения свойств 
property ExcludeDefaultValues; // пропускать значения по умолчанию 
property OnGetXMLHeader;       // позволяет указать свой XML заголовок 

Ограничения:

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

Наследники класса TStrings не могут иметь published свойств.

Процедурные типы не обрабатываются.

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

Предусловия:

Объект для (де)сериализации должен быть создан до вызова процедуры.

Дополнительно:

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

unit glXMLSerializer;
{
Globus Delphi VCL Extensions Library ' GLOBUS LIB '
Copyright (c) 2001 Chudin A.V, chudin@yandex.ru
glXMLSerializer Unit 08.2001 component TglXMLSerializer
}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, comctrls, TypInfo;
type
  TOnGetXMLHeader = procedure Ошибка! Недопустимый объект гиперссылки.
  (Sender: TObject; var Value: string) of object;
  XMLSerializerException = class(Exception)
end;
  TglXMLSerializer = class(TComponent)
  private
    { Private declarations }
    Buffer: PChar;
    BufferLength: DWORD;
    TokenPtr: PChar;
    OutStream: TStream;
    FOnGetXMLHeader: TOnGetXMLHeader;
    FGenerateFormattedXML: boolean;
    FExcludeEmptyValues: boolean;
    FExcludeDefaultValues: boolean;
    FReplaceReservedSymbols: boolean;
    procedure check(Expr: boolean; const message: string);
    procedure WriteOutStream(Value: string);
  protected
    procedure SerializeInternal(Component: TObject; Level: integer = 1);
    procedure DeSerializeInternal(Component: TObject; const ComponentTagName:
    string; ParentBlockEnd: PChar = nil);
    procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;
    Stream: TStream; const ComponentTagName: string);
    procedure SetPropertyValue(Component: TObject; PropInfo: PPropInfo;
    Value, ValueEnd: PChar; ParentBlockEnd: PChar);
  public
    tickCounter, tickCount: DWORD;
    constructor Create(AOwner: TComponent); override;
    { Сериализация объекта в XML }
    procedure Serialize(Component: TObject; Stream: TStream);
    { Загрузка XML в объект }
    procedure DeSerialize(Component: TObject; Stream: TStream);
    { Генерация DTD }
    procedure GenerateDTD(Component: TObject; Stream: TStream);
  published
    property GenerateFormattedXML: boolean
    read FGenerateFormattedXML write FGenerateFormattedXML default true;
    property ExcludeEmptyValues: boolean
    read FExcludeEmptyValues write FExcludeEmptyValues;
    property ExcludeDefaultValues: boolean
    read FExcludeDefaultValues write FExcludeDefaultValues;
    property ReplaceReservedSymbols: boolean
    read FReplaceReservedSymbols write FReplaceReservedSymbols;
    property OnGetXMLHeader: TOnGetXMLHeader
    read FOnGetXMLHeader write FOnGetXMLHeader;
end;
procedure register;
implementation
uses dsgnintf, glUtils;
const
  ORDINAL_TYPES = [tkInteger, tkChar, tkEnumeration, tkSet];
  TAB: string = #9;
  CR: string = #13#10;
procedure register;
begin
  RegisterComponents('Gl Components', [TglXMLSerializer]);
end;
constructor TglXMLSerializer.Create(AOwner: TComponent);
begin
  inherited;
  //...defaults
  FGenerateFormattedXML := true;
end;
{ пишет строку в выходящий поток. Исп-ся при сериализации }
procedure TglXMLSerializer.WriteOutStream(Value: string);
begin
  OutStream.write(Pchar(Value)[0], Length(Value));
end;
{
Конвертирует компонент в XML-код в соответствии
с published интерфейсом класса объекта.
Вход:
Component - компонент для конвертации
Выход:
текст XML в поток Stream
}
procedure TglXMLSerializer.Serialize(Component: TObject; Stream: TStream);
var
  Result: string;
begin
  TAB := IIF(GenerateFormattedXML, #9, '');
  CR := IIF(GenerateFormattedXML, #13#10, '');
  Result := '';
  { Получение XML заголовка }
  if Assigned(OnGetXMLHeader) then
    OnGetXMLHeader(self, Result);
  OutStream := Stream;
  WriteOutStream( PChar(CR + '<' + Component.ClassName + '>') );
  SerializeInternal(Component);
  WriteOutStream( PChar(CR + '</' ? + Component.ClassNameend;
  {
  Внутренняя процедура конвертации объекта в XML
  Вызывается из:
  Serialize()
  Вход:
  Component - компонент для конвертации
  Level - уровень вложенности тега для форматирования результата
  Выход:
  строка XML в выходной поток через метод WriteOutStream()
  }
  procedure TglXMLSerializer.SerializeInternal(Component: TObject; Level: integer = 1);
  var
    PropInfo: PPropInfo;
    TypeInf, PropTypeInf: PTypeInfo;
    TypeData: PTypeData;
    i, j: integer;
    AName, PropName, sPropValue: string;
    PropList: PPropList;
    NumProps: word;
    PropObject: TObject;
    { Добавляет открывающий тег с заданным именем }
    procedure addOpenTag(const Value: string);
    begin
      WriteOutStream(CR + DupStr(TAB, Level) + '<' + Value + '>');
      inc(Level);
    end;
    { Добавляет закрывающий тег с заданным именем }
    procedure addCloseTag(const Value: string; addBreak: boolean = false);
    begin
      dec(Level);
      if addBreak then
        WriteOutStream(CR + DupStr(TAB, Level));
      WriteOutStream('</' ? + Valueend;
      { Добавляет значение в результирующую строку }
      procedure addValue(const Value: string);
      begin
        WriteOutStream(Value);
      end;
  begin
    // Result := '';
    { Playing with RTTI }
    TypeInf := Component.ClassInfo;
    AName := TypeInf^.name;
    TypeData := GetTypeData(TypeInf);
    NumProps := TypeData^.PropCount;
    GetMem(PropList, NumProps*sizeof(pointer));
    try
      { Получаем список свойств }
      GetPropInfos(TypeInf, PropList);
      for i := 0 to NumProps-1 do
      begin
        PropName := PropList^[i]^.name;
        PropTypeInf := PropList^[i]^.PropType^;
        PropInfo := PropList^[i];
        { Хочет ли свойство, чтобы его сохранили ? }
        if not IsStoredProp(Component, PropInfo) then
          continue;
        case PropTypeInf^.Kind of
          tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
          tkWChar, tkLString, tkWString, tkVariant:
          begin
            { Получение значения свойства }
            sPropValue := GetPropValue(Component, PropName, true);
            { Проверяем на пустое значение и значение по умолчанию }
            if ExcludeEmptyValues and (sPropValue = '') then
              continue;
            if ExcludeDefaultValues and (PropTypeInf^.Kind in ORDINAL_TYPES)
            and (sPropValue = IntToStr(PropInfo.default)) then
              continue;
            { Замена спецсимволов }
            if FReplaceReservedSymbols then
            begin
              sPropValue := StringReplace(sPropValue, '<', '%lt;', [rfReplaceAll]);
              sPropValue := StringReplace(sPropValue, '>', '%gt;', [rfReplaceAll]);
              sPropValue := StringReplace(sPropValue, '&', '%', [rfReplaceAll]);
            end;
            { Перевод в XML }
            addOpenTag(PropName);
            addValue(sPropValue); { Добавляем значение свойства в результат }
            addCloseTag(PropName);
          end;
          tkClass: { Для классовых типов рекурсивная обработка }
          begin
            addOpenTag(PropName);
            PropObject := GetObjectProp(Component, PropInfo);
            if Assigned(PropObject)then
            begin
              { Для дочерних свойств-классов - рекурсивный вызов }
              if (PropObject is TPersistent) then
                SerializeInternal(PropObject, Level);
              { Индивидуальный подход к некоторым классам }
              if (PropObject is TStrings) then { Текстовые списки }
              begin
                WriteOutStream(TStrings(PropObject).CommaText);
              end
              else
              if (PropObject is TCollection) then { Коллекции }
              begin
                SerializeInternal(PropObject, Level);
                for j := 0 to (PropObject as TCollection).Count-1 do
                begin { Контейнерный тег по имени класса }
                  addOpenTag(TCollection(PropObject).Items[j].ClassName);
                  SerializeInternal(TCollection(PropObject).Items[j], Level);
                  addCloseTag(TCollection(PropObject).Items[j].ClassName, true);
                end
              end;
              { Здесь можно добавить обработку остальных классов: TTreeNodes, TListItems }
            end;
          { После обработки свойств закрываем тег объекта }
          addCloseTag(PropName, true);
        end;
      end;
    end;
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;
{
Загружает в компонент данные из потока с XML-кодом.
Вход:
Component - компонент для конвертации
Stream - источник загрузки XML
Предусловия:
Объект Component должен быть создан до вызова процедуры
}
procedure TglXMLSerializer.DeSerialize(Component: TObject; Stream: TStream);
begin
  GetMem(Buffer, Stream.Size);
  try
    { Получаем данные из потока }
    Stream.read(Buffer[0], Stream.Size + 1);
    { Устанавливаем текущий указатель чтения данных }
    TokenPtr := Buffer;
    BufferLength := Stream.Size-1;
    { Вызываем загрузчик }
    DeSerializeInternal(Component, Component.ClassName);
  finally
    FreeMem(Buffer);
  end;
end;
{
Рекурсивная процедура загрузки объекта их текстового буфера с XML
Вызывается из:
Serialize()
Вход:
Component - компонент для конвертации
ComponentTagName - имя XML тега объекта
ParentBlockEnd - указатель на конец XML описания родительского тега
}
procedure TglXMLSerializer.DeSerializeInternal(Component: TObject;
const ComponentTagName: string; ParentBlockEnd: PChar = nil);
var
  BlockStart, BlockEnd, TagStart, TagEnd: PChar;
  TagName, TagValue, TagValueEnd: PChar;
  TypeInf: PTypeInfo;
  TypeData: PTypeData;
  PropIndex: integer;
  AName: string;
  PropList: PPropList;
  NumProps: word;
  { Поиск у объекта свойства с заданным именем }
  function FindProperty(TagName: PChar): integer;
  var
    i: integer;
  begin
    Result := -1;
    for i := 0 to NumProps-1 do
      if CompareStr(PropList^[i]^.name, TagName) = 0 then
      begin
        Result := i;
        break;
      end;
  end;
  procedure SkipSpaces(var TagEnd: PChar);
  begin
    while TagEnd[0] <= #33 do
      inc(TagEnd);
  end;
  function StrPos2(const Str1, Str2: PChar; Str2Len: DWORD): PChar; assembler;
  asm
    PUSH EDI
    PUSH ESI
    PUSH EBX
    or EAX,EAX // Str1
    JE @@2 // если строка Str1 пуста - на выход
    or EDX,EDX // Str2
    JE @@2 // если строка Str2 пуста - на выход
    MOV EBX,EAX
    MOV EDI,EDX // установим смещение для SCASB - подстрока Str2
    xor AL,AL // обнулим AL
    push ECX // длина строки
    MOV ECX,0FFFFFFFFH // счетчик с запасом
    REPNE SCASB // ищем конец подстроки Str2
    not ECX // инвертируем ECX - получаем длину строки+1
    DEC ECX // в ECX - длина искомой подстроки Str2
    JE @@2 // при нулевой длине - все на выход
    MOV ESI,ECX // сохраняем длину подстроки в ESI
    pop ECX
    SUB ECX,ESI // ECX == разница длин строк : Str1 - Str2
    JBE @@2 // если длина подсроки больше длине строки - выход
    MOV EDI,EBX // EDI - начало строки Str1
    LEA EBX,[ESI-1] // EBX - длина сравнения строк
    @@1: MOV ESI,EDX // ESI - смещение строки Str2
    LODSB // загужаем первый символ подстроки в AL
    REPNE SCASB // ищем этот символ в строке EDI
    JNE @@2 // если символ не обнаружен - на выход
    MOV EAX,ECX // сохраним разницу длин строк
    PUSH EDI // запомним текущее смещение поиска
    MOV ECX,EBX
    REPE CMPSB // побайтно сравниваем строки
    POP EDI
    MOV ECX,EAX
    JNE @@1 // если строки различны - ищем следующее совпадение первого символа
    LEA EAX,[EDI-1]
    JMP @@3
    @@2: xor EAX,EAX
    @@3: POP EBX
    POP ESI
    POP EDI
  end;
begin
  { Playing with RTTI }
  TypeInf := Component.ClassInfo;
  AName := TypeInf^.name;
  TypeData := GetTypeData(TypeInf);
  NumProps := TypeData^.PropCount;
  GetMem(PropList, NumProps*sizeof(pointer));
  try
    GetPropInfos(TypeInf, PropList);
    { ищем открывающий тег }
    BlockStart := StrPos2(TokenPtr, PChar('<' + ComponentTagName + '>'), BufferLength);
    check(BlockStart <> nil, 'Открывающий тег не найден: ' + '<' + ComponentTagName + '>');
    inc(BlockStart, length(ComponentTagName) + 2);
    { ищем закрывающий тег }
    BlockEnd := StrPos2(BlockStart, PChar('</' ? + ComponentTagName nil,
    'Закрывающий тег не найден: ' + '<' + ComponentTagName + '>');
    { проверка на вхождение закр. тега в родительский тег }
    check((ParentBlockEnd = nil)or(BlockEnd { XML парсер }
    while TagEnd do
    begin
      { быстрый поиск угловых скобок }
      asm
        mov CL, '<'
        mov EDX, Pointer(TagEnd)
        dec EDX
        @@1: inc EDX
        mov AL, byte[EDX]
        cmp AL, CL
        jne @@1
        mov TagStart, EDX
        mov CL, '>'
        @@2: inc EDX
        mov AL, byte[EDX]
        cmp AL, CL
        jne @@2
        mov TagEnd, EDX
      end;
      GetMem(TagName, TagEnd - TagStart + 1);
      try
        { TagName - имя тега }
        StrLCopy(TagName, TagStart + 1, TagEnd - TagStart - 1);
        { TagEnd - закрывающий тег }
        { поиск свойства, соответствующего тегу }
        TagEnd := StrPos2(TagEnd, PChar('</' ? + TagName
        PropIndex := FindProperty(TagName);
        check(PropIndex <> -1, 'TglXMLSerializer.DeSerializeInternal: Uncknown property: ' +
        TagName);
        SetPropertyValue(Component, PropList^[PropIndex], TagValue, TagValueEnd, BlockEnd);
        inc(TagEnd, length('</' ? + TagNamefinally
        FreeMem(TagName);
      end;
    end;
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;
{
Процедура инициализации свойства объекта
Вызывается из:
DeSerializeInternal()
Вход:
Component - инициализируемый объект
PropInfo - информация о типе для устанавливаемого свойства
Value - значение свойства
ParentBlockEnd - указатель на конец XML описания родительского тега
Используется для рекурсии
}
procedure TglXMLSerializer.SetPropertyValue(Component: TObject;
PropInfo: PPropInfo; Value, ValueEnd: PChar; ParentBlockEnd: PChar);
var
  PropTypeInf: PTypeInfo;
  PropObject: TObject;
  CollectionItem: TCollectionItem;
  sValue: string;
  charTmp: char;
begin
  PropTypeInf := PropInfo.PropType^;
  case PropTypeInf^.Kind of
    tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
    tkWChar, tkLString, tkWString, tkVariant:
    begin
      { имитируем zero terminated string }
      charTmp := ValueEnd[0];
      ValueEnd[0] := #0;
      sValue := StrPas(Value);
      ValueEnd[0] := charTmp;
      { Замена спецсимволов. Актуально только для XML,
      сохраненного с помощью этого компонента }
      if FReplaceReservedSymbols then
      begin
        sValue := StringReplace(sValue, '%lt;', '<', [rfReplaceAll]);
        sValue := StringReplace(sValue, '%gt;', '>', [rfReplaceAll]);
        sValue := StringReplace(sValue, '%', '&', [rfReplaceAll]);
      end;
      { Для корректного преобразования парсером tkSet нужны угловые скобки }
      if PropTypeInf^.Kind = tkSet then
        sValue := '[' + sValue + ']';
      SetPropValue(Component, PropInfo^.name, sValue);
    end;
    tkClass:
    begin
      PropObject := GetObjectProp(Component, PropInfo);
      if Assigned(PropObject)then
      begin
        { Индивидуальный подход к некоторым классам }
        if (PropObject is TStrings) then { Текстовые списки }
        begin
          charTmp := ValueEnd[0];
          ValueEnd[0] := #0;
          sValue := StrPas(Value);
          ValueEnd[0] := charTmp;
          TStrings(PropObject).CommaText := sValue;
        end
        else
        if (PropObject is TCollection) then { Коллекции }
        begin
          while true do { Заранее не известно число элементов в коллекции }
          begin
            CollectionItem := (PropObject as TCollection).Add;
            try
              DeSerializeInternal(CollectionItem, CollectionItem.ClassName,
              ParentBlockEnd);
            except { Исключение, если очередной элемент не найден }
              CollectionItem.Free;
              break;
            end;
          end;
        end
        else { Для остальных классов - рекурсивная обработка }
          DeSerializeInternal(PropObject, PropInfo^.name, ParentBlockEnd);
      end;
    end;
  end;
end;
{
Процедура генерации DTD для заданного объекта в
соответствии с published интерфейсом его класса.
Вход:
Component - объект
Выход:
текст DTD в поток Stream
}
procedure TglXMLSerializer.GenerateDTD(Component: TObject; Stream: TStream);
var
  DTDList: TStringList;
begin
  DTDList := TStringList.Create;
  try
    GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);
  finally
    DTDList.Free;
  end;
end;
{
Внутренняя рекурсивная процедура генерации DTD для заданного объекта.
Вход:
Component - объект
DTDList - список уже определенных элементов DTD
для предотвращения повторений.
Выход:
текст DTD в поток Stream
}
procedure TglXMLSerializer.GenerateDTDInternal(Component: TObject; DTDList:
TStrings; Stream: TStream; const ComponentTagName: string);
var
  PropInfo: PPropInfo;
  TypeInf, PropTypeInf: PTypeInfo;
  TypeData: PTypeData;
  i: integer;
  AName, PropName, TagContent: string;
  PropList: PPropList;
  NumProps: word;
  PropObject: TObject;
const
  PCDATA = '#PCDATA';
  procedure addElement(const ElementName: string; Data: string);
  var
    s: string;
  begin
    if DTDList.IndexOf(ElementName) <> -1 then
      exit;
    DTDList.Add(ElementName);
    s := 'then Data := PCDATA;
    s := s + '(' + Data + ')>'#13#10;
    Stream.Write(PChar(s)[0], length(s));
  end;
begin
  { Playing with RTTI }
  TypeInf := Component.ClassInfo;
  AName := TypeInf^.name;
  TypeData := GetTypeData(TypeInf);
  NumProps := TypeData^.PropCount;
  GetMem(PropList, NumProps*sizeof(pointer));
  try
    { Получаем список свойств }
    GetPropInfos(TypeInf, PropList);
    TagContent := '';
    for i := 0 to NumProps-1 do
    begin
      PropName := PropList^[i]^.name;
      PropTypeInf := PropList^[i]^.PropType^;
      PropInfo := PropList^[i];
      { Пропустить не поддерживаемые типы }
      if not (PropTypeInf^.Kind in [tkDynArray, tkArray,
      tkRecord, tkInterface, tkMethod]) then
      begin
        if TagContent <> '' then
          TagContent := TagContent + '|';
        TagContent := TagContent + PropName;
      end;
      case PropTypeInf^.Kind of
        tkInteger, tkChar, tkFloat, tkString,
        tkWChar, tkLString, tkWString, tkVariant, tkEnumeration, tkSet:
        begin
          { Перевод в DTD. Для данных типов модель содержания - #PCDATA }
          addElement(PropName, PCDATA);
        end;
        { код был бы полезен при использовании атрибутов
        tkEnumeration:
        begin
        TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^);
        s := '';
        for j := TypeData^.MinValue to TypeData^.MaxValue do
        begin
        if s <> '' then s := s + '|';
        s := s + GetEnumName(PropTypeInf, j);
        end;
        addElement(PropName, s);
        end;
        }
        tkClass: { Для классовых типов рекурсивная обработка }
        begin
          PropObject := GetObjectProp(Component, PropInfo);
          if Assigned(PropObject)then
          begin
            { Для дочерних свойств-классов - рекурсивный вызов }
            if (PropObject is TPersistent) then
              GenerateDTDInternal(PropObject, DTDList, Stream, PropName);
          end;
        end;
      end;
    end;
    { Индивидуальный подход к некоторым классам }
    { Для коллекций необходимо включить в модель содержания тип элемента }
    if (Component is TCollection) then
    begin
      if TagContent <> '' then
        TagContent := TagContent + '|';
      TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';
    end;
    { Добавляем модель содержания для элемента }
    addElement(ComponentTagName, TagContent);
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;
procedure TglXMLSerializer.check(Expr: boolean; const message: string);
begin
  if not Expr then
    raise XMLSerializerException.Create ('XMLSerializerException'#13#10#13#10 + message);
end;
end.
//(PShortString(@(GetTypeData(GetTypeData (PropTypeInf)^.BaseType^).NameList)))
//tickCount := GetTickCount();
//inc(tickCounter, GetTickCount() - tickCount);

Использование XML в среде Delphi.

Оформил: DeeCo

Автор: А.Календарев.

Последнее время много внимания уделяется построение систем электронного бизнеса, или как их еще назыают - B2B (business to business). Учитывая рекомендации по построению обменных потоковых систем координирующего интернет-технологий органа - WWW Consortium: акцент сделан в сторону XML-технологий и построение систем обмена XML-документами.

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

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

Во всех системах обмен, как правило, строится по одинаковой схеме, с использованием HTTP запросов. В качестве протокола защиты информации применяется протокол SSL (но это отдельная тема).

Один из возможных вариантов обработки XML сообщения является построение BIN/CGI (ISAPI)-приложений или COM (серверных) компонент, формирующих или обрабатывающих XML-документы.

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

Один из наиболее эффективных вариантов реализации - использование существующего XML-парсера, поддерживающего DOM модель. Такой парсер является дистрибутивной поставкой Win`98 или составной частью IE 4,7 и выше (для Win`95) и представляет COM сервер, находящийся в библиотеке msxml.dll.

Модель компонентных объектов (COM) - представляет инкапсулированные данные и методы в единую сущность и способ доступа к ним через систему интерфейсов. Средствами Delphi достаточно просто осуществить доступ к классам COM-объекта (в одном COM-сервере может быть включено несколько классов). Доступ к объектам осуществляется путем инициализации экземпляра класса через систему интерфейсов. Описание интерфейсов осуществляется языком определения интерфейсов (IDL), которое возможно осуществить средствами среды автоматически.

Средствами Delphi осуществляется импорт из COM-сервера msxml.dll, строится файлы описания интерфейса IDL и файл бинарноого описания типов библиотеки - TLB. Данная операция осуществляется через системное меню: Project | Type Library Import… (рис 1). Далее появляется диалоговое окно (рис 2), в котором необходимо выбрать COM-объект (в нашем случае объект зарегистрирован под именем "Microsoft.XMLDom (Version 2.0)" ) и создать TLB-файл (кнопка Create Unit). Используя TLB-файл, среда генерирует "паскалевский" файл описания COM-сервера - MSXML_TLB.pas.

Рис 1	Рис 2

В файле MSXML_TLB.pas описаны все интерфейсы, константы и соклассы COM-сервера.

Для доступа к объектам COM-элемента, необходимо в директиве USES добавить имя файла описания библиотеки (MSXML_TLB.pas). Ниже представлена простейшая программа, использующая DOM стандартный анализатор msxml.dll, которая загружает XML-документ и отображает его в элементе текстового поля Memo1.

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OleServer, MSXML_TLB, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: Tobject);
var
  coDoc: CoDOMDocument;
  / * объявление сокласса объекта DOMDocument;
  * /
  var
  Doc: IXMLDOMDocument;
  / * класс, согласованный с интерфейсом IDOMDocument;
  * /
begin
  Doc := coDoc.Create;
  / * создание экземпляра объекта DOMDocument;
  * /
    Doc.load('data.xml');
  / * вызов метода Load экземпляра объекта DOMDocument;
  * /
    Memo1.Text := Doc.xml;
  / * доступ к свойстве xml экземпляра объекта DOMDocument;
  * /
end;
end.

Каждый XML документ представляется в виде набора множества объектов (классов), с помощью которых возможен доступ к отдельным элементам (полям объекта). DOM - интерфейс описывает доступ как к простым объектам типа DOMString или CharacterData, так и к частям или отдельным элементам XML документа: DOMFragmentElement, DOMNode, DOMElement.

Ниже приведены самые важные свойства и методы объектов XMLDOMDocument, XMLDOMNode, XMLDOMNodeList. Необходимо отметить, что представленные ниже методы и функции объектов DOM модели (Document Object Model) используются Microsoft XML-анализатором msxml.dll и несколько шире, чем утвержденная W3C Консорциумом DOM модель.

Более полное описание интерфейса DOM объектов можно найти на www.msdn.microsoft.com/xml.

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

При построении B2B или корпоративной ERP системы, при организации информационного обмена XML-документами между предприятиями или филиалами пр-я, используются эффективно себя зарекомендовавшая система передачи информации на основе имеющихся WEB серверов по HTTP протоколам.

С одной стороны, приложение выступает в качестве клиента, которое в режиме POST выдает HTTP запрос, с другой стороны, находится WEB сервер, на стороне которого осуществляется обработка запроса и выдача ответа. В качестве обмена используются XML-документы.

Например, в простой корпоративной ERP системе бухгалтерской программе (АСУ Бухучет) необходимо сформировать некий запрос на выписку накладной и передать его в филиал, который имеет склад (АСУ Склад). АРМ Аналогичная постановка задачи при создании В2В системы, когда Предприятие А запрашивает наличие продукции (делает заказ на приобретение) у Поставщика В.

Предприятие А и его программа выступает в качестве клиента. Склад обслуживает Поставщик В, у которого находится складской комплекс БД на SQL сервере. Обмен осуществляется через корпоративный WEB сервер Поставщика В.

Ниже представлен следующий типовой алгоритм обмена:

Каждый XML документ, подобно HTML документу, должен состоять из заголовка сообщения (информация заключенная тагами ) и тела сообщения (для запроса эта информация обрамленная тагами для ответа на запрос ). Для того, чтобы XML документ был правильно сформирован, необходимо его две составные части "Заголовок" и "Запрос" обрамить тегами, например <xmlDoc>. Вид типового документа представлен ниже:

Заголовок (Рис 4), в отличие HTML документа, должен содержать разного рода служебную информацию, в том числе информацию о типе передаваемого документа и процессе его обработки. В информационную обработку поступает тело документа, т.е. содержательная часть обрамленная тагами . Следует отметить, что структуру заголовков должна быть единой для всех типов документов.

Для запущенного сервером Процесса, алгоритм обработки предпочтительно (но не обязательно) строить следующим образом:

Как уже пояснялось, при создание XML-документа используется его представление в виде DOM модели. Ниже приведен пример части текста Delphi программы создания заголовка xml сообщения.

procedure TThread1.HeaderCreate(Sender: Tobject);
var
  coDoc        : CoDomDocument ;              // объявление сокласса, необходим для создания 
  Doc          : DomDocument ;                // объекта XMLDomDocument
  r            : IXMLDOMElement;              // объявление объектов DOMElement
  Node         : IXMLDOMElement;              //                                  
  txt          : IXMLDOMText;                 //                     DOMText
  attr         : IXMLDOMAttribute;            //                     DOMAttribute
begin
  Doc:=coDoc.Create;                          // создание документа DOM
  Doc.Set_async(false);                       // установка синхронного режима обрабработки
  Doc.LoadXML('<Header/>');                   // начальная инициация DOM документа 
  r:=Doc.Get_documentElement;                 // получение адреса корневого элемента
  Node := Doc.createElement ( 'Sender');        // создание DOMElement (таг <Sender>) 
  txt := Doc.createTextNode( 'ООО "Тайфун"');   // создание техстового узла 'ООО "Тайфун"'
  Node.appendChild(txt);                        //  присвоение узлу <Sender> значение 
                                                // техстового узла 'ООО "Тайфун"'
  r.appendChild(Node);                          // добавление элемента <Sender> в корень
                                                // документа как дочернего
  Node := Doc.createElement ( 'From');          // аналогичные операции для тага <From>
  
  txt := Doc.createTextNode( 'http://tayfun.ru/xml/default.asp');
  Node.appendChild(txt);
  r.appendChild(Node);
  Node := Doc.createElement ( 'To');             // аналогичные операции для тага <To>
  txt := Doc.createTextNode( 'http://irbis.ru');
  Node.appendChild(txt);
  r.appendChild(Node);
  
  Node := Doc.createElement ( 'TypeDocument');           // создание DOMElement (<TypeDocument Id>) 
  Att := Doc.createAttribute ( 'Id ', ' Order');         // создание узла XMLDOMAttribute
  Node.appendChild(Att);                                 //    <TypeDocument Id="Order"/>
  r.appendChild(Node);
end;

Следует отметить, что объявление переменной coDoc : CoDomDocument и Doc : DomDocument , а также ее создание методом Create ( Doc:=coDoc.Create;) осуществляется один раз. Объявление переменной находится в секции описания глобальных переменных, а не в локальной процедуре, как было продемонстрировано для наглядности в данном примере (т.е. одна глобальная переменная типа DomDocument на один программный модуль).

Результатом работы вышеприведенной программы будет созданный заголовок <Header>, приминительно к нашему примеру xml-документа: изображен на рис. 7.

Основное приемущество передачи информации в виде XML-документов в том, что существует возможно формировать сообщение, используя независимые структуры таблиц в СУБД как на принимаемой, так и на передаваемой стороне. Используя наш пример, пусть требуется передать информацию об инвойсах Предприятия А, из СУБД имеющий структуру, изображенную на рис. 6.

Для формирования xml-документа, содержащего инвойс первоначально строится SQL-запрос (запрос А) с информацией о самом инвойсе:

    SELECT * FROM Invoice_General
    WHERE InvoiceNum = :num                      // :num  - параметр, который задает номер инвойса. 

И далее строится SQL-запрос (запрос В) информация о товарах, описываемых в инвойсе (детальная спецификация):

    SELECT Goods,Qulity,Price, HZ_cod 
    FROM Goods 
    WHERE InvoiceNum = :num                      // :num - параметр, который задает номер инвойса. 

Ниже представлена часть программы, формирующей тело xml-документа:

procedure TThread1.DataBodyCreate(Sender: Tobject);
var
  //coDoc      : CoDomDocument ;              // объявление сокласса и объекта XMLDomDocument 
  //Doc        : DomDocument ;                // должно быть глобальным, для всего модуля. 
  
  r            : IXMLDOMElement;              // объявление объектов DOMElement
  Node, Node2  : IXMLDOMElement;              //                     DOMElement;
  Node3, Node4 : IXMLDOMElement;              //                                  
  txt          : IXMLDOMText;                 //                     DOMText
  str          : String;
// InvoiceNumber: integer;  - глобальная переменная - имеет значение 987654 
// queryA, queryB : String;  - глобальная переменная, имеет значение, соответсвующее запросу
// queryA - запрос А генеральная информацией об инвойсе
// queryB - запрос B информация о товарах, описываемых в  инвойсе (см. текст)
begin
  Query.Close;                                     // закрывает запрос для доступа
  Query.Text := queryA;                            // см. по тексту "запрос А"
 Query.Params[0].AsInteger := InvoiceNumber;       // присваивание значения параметров
 Query.ExecSQL;                                    // выполнение запроса
 Query.Open;                                       // открытие доступа к данным запроса 
  r:=Doc.Get_documentElement;                      // получение адреса корневого элемента
  Node2 := Doc.createElement ( ' Request ');       // создание DOMElement (таг <Request>) 
  Node := Doc.createElement ( 'Invoice');          // создание DOMElement (таг <Invoice >) 
  r.appendChild(Node2);                            // добавление элемента <Request> в корень
  Node2. appendChild(Node);                        // добавление элемента <Invoice> в <Request> 
  
  Node3 := Doc.createElement ( 'Depurture') ;      // создание DOMElement (таг <Depurture>)  
  Node. appendChild(Node3);                        // добавление элемента <Depurture> в <Invoice>
  str:= Query.FieldByName('Depurture').AsString;   // обращение к полю 'Depurture' запроса
  txt := Doc.createTextNode( str);                 // создание техстового узла = значению поля  
  Node.appendChild(txt);                           //  присвоение узлу <Invoice> значение 
                                                   // техстового узла, переменной str 
// аналогичные операции для тага <Destination>, <DataSend>, <DataDepurture>, <Currency>
// <DestinationCompany> (поле DB  "Consignee" )
  Node := Doc.createElement ( 'Destination');                  
  str:= Query.FieldByName('Consignee ').AsString;    // имя поля БД может и не совпадать с именем 
  txt := Doc.createTextNode( str);                   // тага, в этом приемущество использования 
  Node.appendChild(txt);                             // DOM интерфейса перед СУБД, имеющим 
                                                     // поддержку XML-интерфейса, типа ORACLE 8i 
...                                                  // или Ms SQL 2000
                                                     // формирование запроса на спецификацию по товарам 
 Query.Close;                                        // закрывает запрос для доступа
 Query.Text := qиегуВ;                               // см. по тексту "запрос В", информац. О товарах
 Query.Params[0].AsInteger := InvoiceNumber;         // присваивание значения параметров
 Query2.ExecSQL;                                     // выполнение запроса
 Query.Open;                                         // открытие доступа к данным запроса 
Node3 := Doc.createElement ( ' Imems') ;             // создание DOMElement (таг <Imems>)            
Node. appendChild(Node3);                            // добавление элемента <Imems> в <Invoice>
while not Eof.Query do begin                         // цикл по всем строкам запроса
   Node4 := Doc.createElement ( 'Imem');
   Node3.appendChild(Node4);                         // добавление элемента <Imem> в <Imems>
  
  str:= Query.FieldByName('Price').AsString;         // формирование данных для тага <Price>
  txt := Doc.createTextNode( str); 
  Node.appendChild(txt); 
  ...
// аналогичные операции для тагов <HZ_Cod>, <Quality>, <GoodName>
  end;
end;

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

Для формирования запроса используется метод Open объекта IXMLHttpRequest:

procedure Open(const bstrMethod, -тип метода = "POST"
  bstrUrl, -Url адрес сервера
  varAsync, -режим связи асинхронный / синхронный = true
  bstrUser, -имя пользователя для аутентификации
  bstrPassword) - пароль

Как было отмечено ранее, обработка HTTP запроса может осуществляться либо CGI-приложениями, либо Java-сервлетами. Возможен и вариант написания ASP-страниц. Но в этом случае передача данных возможна только методом "GET" через строку запроса. Хотя, обработка HTTP запроса ASP-страниц работает более эффективнее, чем CGI-приложением. Однако, на мой взгляд, без разницы, как обрабатывать, а важнее решить вопрос - как построить программму обработки, а не какими средствами.

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

procedure Tthread1.DataParser(Sender: Tobject);
var
  r,FNode          : IXMLDOMElement;                       // объявление объектов DOMElement
  Str,Filename     : String;
  parm             : String;
CoDocXML, CoDocXSL, CoDocResult      : CoDomDocument ;     // объявление сокласса и
XMLDoc, XSLDoc, ResultDoc            : DomDocument ;       // объекта XMLDomDocument 
// HttpStr : String; - глобальная переменная, содержащая строку HTTP запроса
Begin
  XMLDoc:=coDocXML.Create;                 // создание документа XMLDoc
  XMLDoc.Set_async(false);                 // установка синхронного режима обрабработки
  XMLDoc.LoadXML(HttpStr);                 // загрузка DOM документа из строки HttpStr
  r:=Doc.Get_documentElement;                        // получение адреса корневого элемента
  FNode:= r.SelectSingleNode("//TypeDocument");      // получение значения элемента <TypeDocument>
  FileName:= FNode.GetAttibute("id");                // получение значения аттрибута id="Order"
  FileName:= FileName+".xsl";                        // и формирование имени файла Order.xsl
  XSLDoc:=coDocXSL.Create;                           // создание документа XSLDoc
  XSLDoc.Set_async(false);                           // установка синхронного режима обрабработки
  XSLDoc.LoadXML(FileName);                          // загрузка DOM документа из файла Order.xsl
  ResultDoc:=coDocResult.Create;                     // создание документа XMLDoc
  ResultDoc.Set_async(false);                        // установка синхронного режима обрабработки
  ResultDoc.validateOnParse := true;                 // установка проверки разбора
 
  XMLDoc.transformNodeToObject(XSLDoc, ResultDoc);   // разбор XMLDoc по XSL-шаблону
	 
 Str:= ResultDoc.text;                               // переменной Str присваивается текстовое значение 
                                                     // результирующего документа.
 FNode:= r.SelectSingleNode("//InvoiceNumber");      // поиск элемента <InvoiceNumber>
 parm:= FNode.text;                                  //  и получение значения элемента
 Query.Close;                                        // закрывает запрос для доступа
 Query.Text := Str; 
 Query.Params[0].AsString := parm;                   // присваивание значения параметра
 Query.ExecSQL;                                      // выполнение запроса
end;

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

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

<!-- файл Order.xsl  -->
<xsl:stylesheet xmlns:xsl="http://www.w3.org/TR/WD-xsl">
  <xsl:template match="/">
  <!--  применяем шаблон ко всему документу, начиная с корневого элемента "/"        -->
  <HTML>
  <xsl:for-each select="//header">
     <!-- формирование запроса для записи данных                          -->
     <!-- в таблицу регистрации приходящих сообщений TABREG       -->
     INSERT into TABREG ( FROM, TO, TYPEDOC,body) VALUES( ' 
      <xsl:value-of select="from" />' ,' 
      <xsl:value-of select="to" />','<xsl:value-of select="TypeDocument/@id" />' ) 
  </xsl:for-each>
<!-- формирование запроса для записи данных в таблицу GOODS -->
<!--  информация о товарах -->
   <xsl:for-each select="//item">
      INSERT into GOODS ( invoiceNumber, name, price, quality) VALUES( ' :num',
     '<xsl:value-of select="name" />' , '<xsl:value-of select="price" />', 
     '<xsl:value-of select="quality" /> 
  ' ) 
  </xsl:for-each>
  </HTML>
  </xsl:template>
</xsl:stylesheet>

Поясняя вышеприведенный пример, надо отметить, что использование пары тагов <HTML> и </HTML> носит формальный характер, т.к. после разбора в результирующем XML-документе формально должен присутствовать хотябы один узел. Метод ResultDoc.text присваивает текстовае значение полученного в ходе разбора XML-документа ResultDoc. В этом случае значением является все то, что обрамлено пары тегов <HTML> и </HTML>, т.е. сформированный нами SQL-запрос.

Другой особенностью написания программы надо отметить возможность использования SQL-параметра :num. Использование параметра позволяет упростить текст xsl-шаблона. Определение значение соответствующих элементов узлов XML-документа определякется первоночально выбора по имени соответствующего узла, например:

FNode := r.SelectSingleNode("
  //InvoiceNumber");   // поиск элемента >InvoiceNumber> и далее использование свойства text:
  parm := FNode.text; //  и получение значения элемента >InvoiceNumber>

Абревиатура XSL происходит от eXtensible Stylesheet Language - язык форматирования таблиц стилей (XML данных). Как понятно из заголовка eXtensible Stylesheet Language (XSL) используется для форматирования XML данных. По определению W3C XSL состоит из двух частей:

При помощи XSLT мы можем отобрать нужные нам данные из XML файла, и оформить их в виде для предоставления пользователю. Например, в нашем случае мы преобразовали XML данные в виде SQL запроса. Классическое применение XSL - это, как правило форматирование данных в виде HTML страниц или более редкое представление в виде RTF файлов.

XSL файл описывает шаблон (template), согласно которому будет совершаться преобразование XML данных. Возращаясь к xsl-шаблонам, в XSLT можно выделить следующие элементы (директивы):

XSL-директивы описание xsl:apply-templates Директива, указывающая на применение соответствующих шаблонов аттрибуту select="имя шаблона" xsl:attribute создает дерево аттрибутов и добавляет его в выходной элемент, пареметр name="имя аттрибута", namespace - URI на пространство имен (преффикс пространства имен) xsl:call-template вызывает шаблон, аттрибуту name=" URI на шаблон" xsl:choose xsl:when xsl:otherwise осуществление выбора по условию xsl:when expr="вычисление выражения на script ", language="language-name" test= "вычисляемое выражение" xsl:comment генерирует комментарий в выходной документ xsl:copy xsl:copy-of копирует текущей узел в выходной источник или вставляет фрагмент документа в узел, где аттрибут select="имя узла источника" xsl:element создает выходной элемент по имени, аттрибут name="имя элемента", namespace="uri сслылка на пространство имен" xsl:for-each повторно применяет шаблон ко всем узлам списка узлов, аттрибут select задает список узлов xsl:if проверка условия, задается аттрибутом test в виде выражения xsl:include включает внешний шаблон, аттрибут href = "URI reference" xsl:output специфицирует выходной результат, аттрибут method может иметь значения "xml", "html" или "text" xsl:param специфицирует значение параметров, аттрибут name="имя параметра", select = "значание" xsl:processing-instruction создает инструкцию обработки, аттрибут name="имя процесс инструкции" xsl:sort сортирует множество узлов, аттрибуты select = "имя узла", data-type = тип данных {"text" | "number" | Qname}, order = направление сортировки {"ascending" | "descending"} xsl:stylesheet определяет документ xsl-шаблонов, является корневым элементом для XSLT xsl:template определяет xsl-шаблон, аттрибут name= " URI преффикс на имя шиблона", match= "указание на узел, к которому применяется шаблон" xsl:text генерирует текст в выходной поток, аттрибут disable-output-escaping = "yes" или "no", указывает на возможность генерации символов ESC xsl:value-of вставляет значение выбранного узла как текст, аттрибут select= "указатель на узел" из которого берут значение xsl:variable специфицирует значение границ переменных, аттрибут name = "имя переменной", select = "вычисление значения переменной" xsl:with-param применяет параметр к шаблону, аттрибут name ="имя параметра", select = выражение для вычисления текущего контекста, значениие по умолчанию "."

В заключение, необходимо отметить, что использование стандартного XML-парсера msxml.dll является не единственным средством разбора и создания XML-документов. Например, для создание XML документов эффективно использовать компоненты TPageProduser и ТТаь1еРгоdиsег. Но, данная статья лишь подчеркивает широту и возможность применения на практике DOM модели .

Автор будет очень благодарен за отзывы об актуальности темы, общем содержании, стиле изложения, а также всем остальным комментариям, которые помогут в дальнейшем улучшить качество написания сборника статей и выпуску книги, освещающую тему практической стороны использования XML-документов в электронной коммерции. Более подробную информацию о практической стороне применения электронных документов можно почерпнуть на авторском сайте www.eDocs.al.ru Также на авторском сайте планируется разместить исходные тексты и примеры.

Крестики - нолики с коброй.

Известно расшифровывается как Common Object Request Broker Architecture, и представляет собой объектно-ориентированную архитектуру связи между клиентом и сервером. Приложения на основе CORBA состоят из двух частей: CORBA-сервер и CORBA-клиент. И сервер и клиент могут быть реализованы на любом языке и запущены на любой платформе. CORBA представляет собой независимую от языка программирования и операционной системы технологию. Это возможно, так как все параметры и типы, возвращаемые методами транспортируются через сеть в специально универсальном формате. А вот для того чтобы сервер и клиент понимали друг друга необходимо определить интерфейс CORBA-сервера, при этом необходимо учитывать независимость от операционной системы и языка на котором происходит разработка приложения. Для этой цели и был разработан интерфейс общения клиента и сервера Interface Definition Language (IDL). Используя IDL, можно определять специфические объекты с присущими им методами и свойствами. Данные методы подобны функциям, которые могут быть вызваны клиентом, и которые могут быть реализованы сервером. В Delphi например для реализации подобного интерфейса прийдеться компилировать специализированный IDL-файл. Вообще же преобразование из стандартного внутреннего стандарта языка программирования в подобный переносимый формат обозначают как marshalling. Обратный процесс преобразования из универсального формата в стандарт понятный программе называется unmarshalling.

Особенности установки VisiBroker

В стандартный набор Delphi 6 Enterprise входит поддержка CORBA в двух вариантах. Во время инсталляции Delphi необходимо выбрать поддержку VisiBroker 3.3 или VisiBroker 4. Это связано с тем, что VisiBroker 3.3 и VisiBroker 4 не могут быть установлены одновременно. В противном случаи, возможны проблемы при работе с Delphi 6. В более ранней версии VisiBroker 3.3 существует полезная возможность динамического вызова интерфейса. В VisiBroker 4 это функциональная особенность не поддерживается. Несмотря на это VisiBroker 4 представляет собой более совершенную реализацию стандарта CORBA, поэтому вопросы, связанные с предыдущей версией VisiBroker 3.3 рассматриваться не будут.

TicTacToe

А теперь рассмотрим возможности технологии CORBA в Delphi, с использованием VisiBroker 4, на примере практического создания небольшой программы. Ниже представлена конструкция IDL известной всем игры в "крестики-нолики", которая имеет гордое английское название TicTacToe. Модуль TTT с интерфейсом TicTacToe реализуется CORBA сервером, и CORBA клиент может соединяться с сервером во время игры.

module TTT
{
  interface TicTacToe
  {
    typedef long TGame;
    typedef long TPlace; // 0,1..9
    enum TPlayer
    {
      user,
      computer,
      none
    };
    exception PlaceTaken
    {
      TPlayer TakenBy;
    };
    TGame NewGame();
    void MakeMove(in TGame Game, in TPlayer player, in TPlace Place)
    raises(PlaceTaken);
    TPlace NextMove(in TGame Game, in TPlayer player);
    TPlayer IsWinner(in TGame Game);
    TPlayer GetValue(in TGame Game, in TPlace Place);
  };
};

Модуль TTT имеет интерфейс TicTacToe. Это интерфейс содержит определения ряда типов (видимы только внутри области интерфейса), определение исключения и определения ряда методов. Обратите внимание, что метод MakeMove может вызывать исключение PlaceTaken. Исключение PlaceTaken - фактически структура, которая также будет обработана.

IDL2Pas Wizard

Для использования IDL файла, его необходимо скомпилировать для Server Skeletons и Client Stubs. Для этого используется файл IDL2Pas, который является частью VisiBroker for Delphi. Но более простой путь, использовать мастера CORBA Server Application и CORBA Client Найти их можно в File | New | Other, закладка Corba.

При выборе мастера CORBA Server Application появится окно и вы можете добавить туда IDL.

Закладка Options содержит ряд специфических установок, который будут выполнены в командной строке IDL2Pas. Обратите внимание на опцию "Overwrite Implementation Units", она не установлена по умолчанию. Кстати, при повторной компиляции данную опцию необходима снять - иначе созданная до этого IDL-файл будет перекомпилировать.

Установки закладки Options мастера IDL2Pas хранятся в секции [idl2pas] файла defproj.dof, находящегося в директории Delphi6\bin, и все выбранные установки будут использованы при следующей загрузки мастера IDL2Pas.

CORBA Server Skeleton

После того как вы нажмете на кнопку ОК в CORBA Server Application Wizard, будут сгенерировано несколько файлов: TTT.IDL будет использован для генерации файла TTT_c.pas (client stubs и helpers), TTT_i.pas будет содержать определения интерфейса, TTT_impl.pas будет использован для реализации интерфейса и TTT_s.pas содержащий server skeletons. Далее можно будет только модифицировать файл TTT_impl.pas, тогда как другие могут быть сгенерированы заново с помощью IDL2Pas.

Interface Definitions (TTT_i.pas)

Файл интерфейса ТТТ TTT_i.pas содержит определение интерфейса TicTacToe. Причиной использования в определениях типов префикса TicTacToe_ является использование этих типов внутри интерфейса. Если мы определяем их вне интерфейса TicTacToe, то транслироваться они буду без префикса TicTacToe_.

unit TTT_i;
interface
uses CORBA;
type
  TicTacToe_TPlayer = (user, computer, none);
type
  TicTacToe = interface;
  TicTacToe_TGame = Integer;
  TicTacToe_TPlace = Integer;
  TicTacToe = interface ['{50B30FC5-4B18-94AB-1D5F-4148BB7467B4}']
    function NewGame: TTT_i.TicTacToe_TGame;
    procedure MakeMove (const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer;
    const Place: TTT_i.TicTacToe_TPlace);
    function NextMove (const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer):
    TTT_i.TicTacToe_TPlace;
    function IsWinner (const Game: TTT_i.TicTacToe_TGame):
    TTT_i.TicTacToe_TPlayer;
    function GetValue (const Game: TTT_i.TicTacToe_TGame;
    const Place: TTT_i.TicTacToe_TPlace):
    TTT_i.TicTacToe_TPlayer;
end;

Можно заметить, что здесь не видны определения исключения. Оно появится в файле Client Stub TTT_c.pas.

Client Stubs and Helpers (TTT_c.pas)

Файл TTT_s.pas содержит не только Client Stubs, но и классы helper. Конечно, лучше было бы если Client Stubs был включен в TTT_c.pas, а классы helper в TTT_h.pas. Но раз все обстоит не так, придется включить файл TTT_c.pas в предложение uses нашего файла Server Skeleton TTT_s.pas.

unit TTT_c;
interface
uses CORBA, TTT_i;
type
  TTicTacToeHelper = class;
  TTicTacToeStub = class;
  TTicTacToe_TGameHelper = class;
  TTicTacToe_TPlaceHelper = class;
  TTicTacToe_TPlayerHelper = class;
  ETicTacToe_PlaceTaken = class;
  TTicTacToeHelper = class
    class procedure Insert (var _A: CORBA.Any; const _Value: TTT_i.TicTacToe);
    class function Extract(var _A: CORBA.Any): TTT_i.TicTacToe;
    class function TypeCode: CORBA.TypeCode;
    class function RepositoryId: string;
    class function read (const _Input: CORBA.InputStream): TTT_i.TicTacToe;
    class procedure write(const _Output: CORBA.OutputStream; const _Value:
    TTT_i.TicTacToe);
    class function Narrow(const _Obj: CORBA.CORBAObject; _IsA: Boolean = False):
    TTT_i.TicTacToe;
    class function Bind(const _InstanceName: string = ''; _HostName: string = ''):
    TTT_i.TicTacToe; overload;
    class function Bind(_Options: BindOptions; const _InstanceName: string = '';
    _HostName: string = ''): TTT_i.TicTacToe; overload;
  end;
  TTicTacToeStub = class(CORBA.TCORBAObject, TTT_i.TicTacToe)
  public
    function NewGame: TTT_i.TicTacToe_TGame; virtual;
    procedure MakeMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer;
    const Place: TTT_i.TicTacToe_TPlace); virtual;
    function NextMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer):
    TTT_i.TicTacToe_TPlace; virtual;
    function IsWinner(const Game: TTT_i.TicTacToe_TGame):
    TTT_i.TicTacToe_TPlayer; virtual;
    function GetValue(const Game: TTT_i.TicTacToe_TGame;
    const Place: TTT_i.TicTacToe_TPlace):
    TTT_i.TicTacToe_TPlayer; virtual;
  end;
  TTicTacToe_TGameHelper = class
    class procedure Insert (var _A: CORBA.Any; const _Value: TTT_i.TicTacToe_TGame);
    class function Extract(const _A: CORBA.Any): TTT_i.TicTacToe_TGame;
    class function TypeCode: CORBA.TypeCode;
    class function RepositoryId: string;
    class function read (const _Input: CORBA.InputStream): TTT_i.TicTacToe_TGame;
    class procedure write(const _Output: CORBA.OutputStream; const _Value:
    TTT_i.TicTacToe_TGame);
  end;
  TTicTacToe_TPlaceHelper = class
    class procedure Insert (var _A: CORBA.Any; const _Value: TTT_i.TicTacToe_TPlace);
    class function Extract(const _A: CORBA.Any): TTT_i.TicTacToe_TPlace;
    class function TypeCode: CORBA.TypeCode;
    class function RepositoryId: string;
    class function read (const _Input: CORBA.InputStream): TTT_i.TicTacToe_TPlace;
    class procedure write(const _Output: CORBA.OutputStream; const _Value:
    TTT_i.TicTacToe_TPlace);
  end;
  TTicTacToe_TPlayerHelper = class
    class procedure Insert (var _A: CORBA.Any; const _Value: TTT_i.TicTacToe_TPlayer);
    class function Extract(const _A: CORBA.Any): TTT_i.TicTacToe_TPlayer;
    class function TypeCode: CORBA.TypeCode;
    class function RepositoryId: string;
    class function read (const _Input: CORBA.InputStream): TTT_i.TicTacToe_TPlayer;
    class procedure write(const _Output: CORBA.OutputStream; const _Value:
    TTT_i.TicTacToe_TPlayer);
  end;
  ETicTacToe_PlaceTaken = class(UserException)
  private
    FTakenBy: TTT_i.TicTacToe_TPlayer;
  protected
    function _get_TakenBy: TTT_i.TicTacToe_TPlayer; virtual;
  public
    property TakenBy: TTT_i.TicTacToe_TPlayer read _get_TakenBy;
    constructor Create; overload;
    constructor Create(const TakenBy: TTT_i.TicTacToe_TPlayer); overload;
    procedure Copy(const _Input: InputStream); override;
    procedure WriteExceptionInfo(var _Output: OutputStream); override;
  end;

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

Server Skeletons (TTT_s.pas)

Класс TticTacToeSkeleton единственный класс, который мы используем для создания экземпляра CORBA Server TicTacToe, принимающего в качестве аргументов имя InstanceName и экземпляр интерфейса TicTacToe .

unit TTT_s;
interface
uses CORBA, TTT_i, TTT_c;
type
  TTicTacToeSkeleton = class;
  TTicTacToeSkeleton = class(CORBA.TCorbaObject, TTT_i.TicTacToe)
  private
    FImplementation: TicTacToe;
  public
    constructor Create(const InstanceName: string; const Impl: TicTacToe);
    destructor Destroy; override;
    function GetImplementation: TicTacToe;
    function NewGame: TTT_i.TicTacToe_TGame;
    procedure MakeMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer;
    const Place: TTT_i.TicTacToe_TPlace);
    function NextMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer):
    TTT_i.TicTacToe_TPlace;
    function IsWinner(const Game: TTT_i.TicTacToe_TGame):
    TTT_i.TicTacToe_TPlayer;
    function GetValue(const Game: TTT_i.TicTacToe_TGame;
    const Place: TTT_i.TicTacToe_TPlace):
    TTT_i.TicTacToe_TPlayer;
  published
    procedure _NewGame(const _Input: CORBA.InputStream; _Cookie: Pointer);
    procedure _MakeMove(const _Input: CORBA.InputStream; _Cookie: Pointer);
    procedure _NextMove(const _Input: CORBA.InputStream; _Cookie: Pointer);
    procedure _IsWinner(const _Input: CORBA.InputStream; _Cookie: Pointer);
    procedure _GetValue(const _Input: CORBA.InputStream; _Cookie: Pointer);
end;

Implementation (TTT_impl.pas)

Файл TTT_impl.pas, единственный файл который редактируется и в который вставляется код реализации CORBA сервера. Тут использован модуль Magic, который использовался для ITicTacToe web service в Delphi 6.

unit TTT_impl;
interface
uses
  SysUtils, CORBA, TTT_i, TTT_c,
  Magic; // implementation of Magic.TTicTacToe
type
  TTicTacToe = class(TInterfacedObject, TTT_i.TicTacToe)
  protected
    TTT: Magic.TTicTacToe;
  public
    constructor Create;
    function NewGame:TTT_i.TicTacToe_TGame;
    procedure MakeMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer;
    const Place: TTT_i.TicTacToe_TPlace);
    function NextMove(const Game: TTT_i.TicTacToe_TGame;
    const player: TTT_i.TicTacToe_TPlayer):
    TTT_i.TicTacToe_TPlace;
    function IsWinner(const Game: TTT_i.TicTacToe_TGame):
    TTT_i.TicTacToe_TPlayer;
    function GetValue(const Game: TTT_i.TicTacToe_TGame;
    const Place: TTT_i.TicTacToe_TPlace):
    TTT_i.TicTacToe_TPlayer;
end;
implementation
constructor TTicTacToe.Create;
begin
  inherited;
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  TTT := Magic.TTicTacToe.Create;
end;
function TTicTacToe.NewGame: TTT_i.TicTacToe_TGame;
begin
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  Result := TTT.NewGame
end;
procedure TTicTacToe.MakeMove(const Game: TTT_i.TicTacToe_TGame;
const player: TTT_i.TicTacToe_TPlayer;
const Place: TTT_i.TicTacToe_TPlace);
begin
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  TTT.MakeMove(Game, Ord(Player), Place);
end;
function TTicTacToe.NextMove(const Game: TTT_i.TicTacToe_TGame;
const player: TTT_i.TicTacToe_TPlayer):
TTT_i.TicTacToe_TPlace;
begin
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  Result := TTT.NextMove(Game, Ord(Player))
end;
function TTicTacToe.IsWinner(const Game: TTT_i.TicTacToe_TGame):
TTT_i.TicTacToe_TPlayer;
begin
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  Result := TTT_i.TicTacToe_TPlayer(TTT.IsWinner(Game))
end;
function TTicTacToe.GetValue(const Game: TTT_i.TicTacToe_TGame;
const Place: TTT_i.TicTacToe_TPlace):
TTT_i.TicTacToe_TPlayer;
begin
  { *************************** }
  { *** User code goes here *** }
  { *************************** }
  Result := TTT_i.TicTacToe_TPlayer(TTT.GetValue(Game, Place))
end;
initialization
end.

Теперь мы имеем на руках практически все части для создания приложения с использованием технологии CORBA . Пусть даже это и игрушка.

CORBA Server Application

Помимо сгенерированных файлов должен же быть и сам проект с главным модулем формы. Сохранив проект как TTTServer.dpr а модуль главной формы как GameUnit. Если заменить фактический ТТТ на объект skeleton типа TicTacToe, код модуля будет выглядеть следующим образом. Тут следует обратить внимание на использование четырех модулей в предложении uses секции interface:

unit GameUnit;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Corba, TTT_i, TTT_c, TTT_s, TTT_impl;
type
  TForm1 = class(TForm)
  private
    { private declarations }
  protected
    { protected declarations }
    TTT: TicTacToe; // skeleton object
    procedure InitCorba;
  public
    { public declarations }
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.InitCorba;
begin
  CorbaInitialize;
  TTT := TTicTacToeSkeleton.Create('TTT', TTicTacToe.Create);
  BOA.ObjIsReady(TTT as _Object)
end;
end.

Вызов InitCorba будем производить из обработчика события OnCreate формы:

procedure TForm1.FormCreate(Sender: TObject);
begin
  InitCorba;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  TTT := nil;
end;

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

program TTTCServer;
{$APPTYPE CONSOLE}
uses
  SysUtils, CORBA, TTT_c, TTT_i, TTT_s, TTT_impl;
var
  TTT: TicTacToe; // skeleton object
begin
  writeln('CorbaInitialize');
  CorbaInitialize;
  writeln('TTicTacToe.Create');
  TTT := TTicTacToeSkeleton.Create('TTT', TTicTacToe.Create);
  writeln('BOA.ObjIsReady');
  BOA.ObjIsReady(TTT as _Object);
  writeln('BOA.ImplIsReady');
  BOA.ImplIsReady
end.

Теперь можно приступать к созданию CORBA-клиента.

CORBA Client Application

Для создания CORBA-клента так же можно использовать CORBA Wizard. Проделываем тоже самое что мы делали для формирования сервера CORBA. Только не следует создавать снова TTT_impl.pas. Кроме уже описанных выше файлов, в наличие есть и файл главной формы и файл проекта. Сохраним их как MainForm.pas и TTTClient.dpr. Модуль MainForm.pas содержит подсказки, чтобы показать вам как создать экземпляр CORBA сервера:

unit MainForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Corba;
type
  TForm1 = class(TForm)
  private
    { private declarations }
  protected
    { protected declarations }
    // declare your Corba interface variables like this
    // Acct : Account;
    procedure InitCorba;
  public
    { public declarations }
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.InitCorba;
begin
  CorbaInitialize;
  // Bind to the Corba server like this
  // Acct := TAccountHelper.bind;
end;
end.

Здесь нужно вызвать метод InitCorba из обработчика OnCreate формы. Надо включить в предложение uses модуля MainForm модули TTT_c, TTT_i и TTT_impl, без которых не будут доступны классы helpers. Непосредственно же объявление переменной типа интерфейса CORBA, может выглядеть следующим образом:

private
  TicTacToe: TicTacToe;

Фактическое связывание интерфейса TicTacToe с CORBA сервером реализуется следующим образом:

TicTacToe := TTicTacToeHelper.bind;

Теперь можно использовать TicTacToe как обыкновенный класс, включающий поддержку Code Insight.

Action!

Внизу представлен небольшой компонент, основанный на оригинальном компоненте игры TicTacToe. Результирующий код, реализован в MagicTTT.pas - содержит в предложении uses модули TTT_i, TTT_c and TTT_impl и создает экземпляр интерфейса TicTacToe:

unit MagicTTT;
interface
uses
  SysUtils, Classes, Controls, StdCtrls, Dialogs, TTT_c, TTT_i, TTT_impl;
const
  NoneID = 0;
  UserID = 1;
  CompID = 2;
const
  chrUser = 'X';
  chrComp = '@';
const
  FirstPlace = 1;
  LastPlace = 9;
type
  TPlace = FirstPlace..LastPlace;
type
  TTTTControl = class(TWinControl)
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  private
    TicTacToe: TicTacToe;
  private { 9 game buttons }
    Game: Integer;
    Button: array[TPlace] of TButton;
    procedure ButtonClick(Sender: TObject);
    procedure ComputerMove;
    procedure UserMove(Move: TPlace);
  private { start button }
    TheStartButton: TButton;
    procedure StartButtonClick(Sender: TObject);
  private { game properties }
    FStartButton: Boolean;
    FUserStarts: Boolean;
    FUserChar: Char;
    FCompChar: Char;
  protected { design interface }
    procedure SetStartButton(Value: Boolean);
    procedure SetUserStarts(Value: Boolean);
    procedure SetUserChar(Value: Char);
    procedure SetCompChar(Value: Char);
    function GetCaption: string;
    procedure SetCaption(Value: string);
  published { user interface }
    property StartButton: Boolean
    read FStartButton write FStartButton default False;
    property Caption: string
    read GetCaption write SetCaption;
    property UserStarts: Boolean
    read FUserStarts write SetUserStarts default False;
    property UserChar: Char
    read FUserChar write SetUserChar default chrUser;
    property CompChar: Char
    read FCompChar write SetCompChar default chrComp;
end {TTTTControl};
procedure register;
implementation
uses Forms;
constructor TTTTControl.Create(AOwner: TComponent);
var
  ButtonIndex: TPlace;
begin
  inherited Create(AOwner);
  Game := 0;
  UserStarts := False;
  FUserChar := chrUser;
  FCompChar := chrComp;
  TheStartButton := TButton.Create(Self);
  TheStartButton.Parent := Self;
  TheStartButton.Visible := True;
  TheStartButton.Caption := 'Humor me...';
  TheStartButton.OnClick := StartButtonClick;
  CorbaInitialize;
  TicTacToe := TTicTacToeHelper.bind;
  for ButtonIndex := Low(ButtonIndex) to High(ButtonIndex) do
  begin
    Button[ButtonIndex] := TButton.Create(Self);
    Button[ButtonIndex].Parent := Self;
    Button[ButtonIndex].Caption := '';
    Button[ButtonIndex].Visible := False;
    Button[ButtonIndex].OnClick := ButtonClick;
  end;
  SetBounds(Left,Top,132,132)
end {Create};
destructor TTTTControl.Destroy;
var
  ButtonIndex: TPlace;
begin
  TheStartButton.Destroy;
  for ButtonIndex := Low(ButtonIndex) to High(ButtonIndex) do
    Button[ButtonIndex].Destroy;
  TicTacToe := nil; { explicit! }
  inherited Destroy;
end; {Destroy};
procedure TTTTControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
const
  Grid = 3;
  GridX = 2;
  GridY = 2;
var
  X,DX,W,Y,DY,H: Word;
begin
  inherited SetBounds(ALeft,ATop,AWidth,AHeight);
  TheStartButton.SetBounds(0,0,Width,Height);
  X := GridX;
  DX := (Width div (Grid * (GridX+GridX))) * (GridX+GridX);
  W := DX - GridX;
  Y := GridY;
  DY := (Height div (Grid * (GridY+GridY))) * (GridY+GridY);
  H := DY - GridY;
  Button[8].SetBounds(X, Y, W,H);
  Button[1].SetBounds(X, Y+DY, W,H);
  Button[6].SetBounds(X, Y+DY+DY, W,H);
  Inc(X,DX);
  Button[3].SetBounds(X, Y, W,H);
  Button[5].SetBounds(X, Y+DY, W,H);
  Button[7].SetBounds(X, Y+DY+DY, W,H);
  Inc(X,DX);
  Button[4].SetBounds(X, Y, W,H);
  Button[9].SetBounds(X, Y+DY, W,H);
  Button[2].SetBounds(X, Y+DY+DY, W,H)
end {SetBounds};
procedure TTTTControl.StartButtonClick(Sender: TObject);
var
  ButtonIndex: TPlace;
begin
  try
    Game := TicTacToe.NewGame;
    if Parent is TForm then
      (Parent as TForm).Caption := IntToStr(Game);
    TheStartButton.Visible := False;
    for ButtonIndex := Low(ButtonIndex) to High(ButtonIndex) do
      Button[ButtonIndex].Visible := True;
    if UserStarts then
    begin
      MessageDlg('You may start...', mtInformation, [mbOk], 0);
      Button[5].SetFocus; { hint... }
    end
    else
      ComputerMove
  except
    on E: Exception do
      MessageDlg('Sorry: '+E.message, mtError, [mbOk], 0)
  end
end {StartButtonClick};
procedure TTTTControl.ButtonClick(Sender: TObject);
var
  ButtonIndex: TPlace;
begin
  Enabled := False;
  for ButtonIndex := Low(ButtonIndex) to High(ButtonIndex) do
    if Button[ButtonIndex] = Sender as TButton then
      UserMove(ButtonIndex)
end {ButtonClick};
procedure TTTTControl.ComputerMove;
var
  Move: Integer;
begin
  Move := TicTacToe.NextMove(Game,TicTacToe_TPlayer(CompID));
  if Move = 0 then
    MessageDlg('Neither has won, the game is a draw!', mtInformation, [mbOk], 0)
  else
  begin
    TicTacToe.MakeMove(Game,TicTacToe_TPlayer(CompID),Move);
    Button[Move].Caption := CompChar;
    Button[Move].Update;
    if TicTacToe.IsWinner(Game) = TicTacToe_TPlayer(CompID) then
      MessageDlg('I have won!', mtInformation, [mbOk], 0)
    else
    begin
      Move := TicTacToe.NextMove(Game,TicTacToe_TPlayer(UserID));
      if Move = 0 then
        MessageDlg('Neither has won, the game is a draw!', mtInformation, [mbOk], 0)
      else
      if Move in [FirstPlace..LastPlace] then
      begin
        Enabled := True;
        Button[Move].SetFocus { hint... }
      end
      else
      if Parent is TForm then
        (Parent as TForm).Caption := IntToStr(Move)
    end
  end
end {ComputerMove};
procedure TTTTControl.UserMove(Move: TPlace);
begin
  if Button[Move].Caption <> '' then
    MessageDlg('This place is occupied!', mtWarning, [mbOk], 0)
  else
  begin
    Button[Move].Caption := UserChar;
    Button[Move].Update;
    TicTacToe.MakeMove(Game,TicTacToe_TPlayer(UserID),Move);
    if TicTacToe.IsWinner(Game) = TicTacToe_TPlayer(UserID) then
      MessageDlg('Congratulations, you have won!', mtInformation, [mbOk], 0)
    else
    ComputerMove
  end
end {UserMove};
procedure TTTTControl.SetUserChar(Value: Char);
begin
  if Value = FCompChar then
    MessageDlg('Character '+Value+' already in use by CompChar!', mtError, [mbOk], 0)
  else
    FUserChar := Value
end {SetUserChar};
procedure TTTTControl.SetCompChar(Value: Char);
begin
  if Value = FUserChar then
    MessageDlg('Character '+Value+' already in use by UserChar!', mtError, [mbOk], 0)
  else
    FCompChar := Value
end {SetCompChar};
procedure TTTTControl.SetUserStarts(Value: Boolean);
begin
  FUserStarts := Value;
end {SetUserStarts};
procedure TTTTControl.SetStartButton(Value: Boolean);
begin
  FStartButton := Value
end {SetStartButton};
function TTTTControl.GetCaption: string;
begin
  GetCaption := TheStartButton.Caption
end {GetCaption};
procedure TTTTControl.SetCaption(Value: string);
begin
  TheStartButton.Caption := Value
end {SetCaption};
procedure register;
begin
  RegisterComponents('DrBob42', [TTTTControl])
end {Register};
end.

Обратите внимание, что конструктор TTTControl также вызывает CorbaInitialize для того чтобы Smart Agent был запущен до того как вы фактически создаете этот компонент.

Пример компонента типа XPButton.

unit GsXPButton;
{
written by Jeff Caler,
Please use this responsibly and
freely in your applications, modify, etc,
but dont take credit for my work, i wouldnt yours,
I reserve all rights given by copyright
in the US and other countries.
No right to resell this component or it's code is given nor implied.
Enjoy it responsibly. As in, Dont take my name out and put in yours.
Thank you.
Jeff Caler
madmacs@netzero.net
GenieOS Software
http://www.genieos.co.uk
3-20-02
}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons;
type
  TGsXPButton = class(TSpeedButton)
  private
    { Private declarations }
     eColor, eSelBackColor, eSelFontColor, eSelBorderColor: TColor;
     FActive: boolean;
     FButtonDown: Boolean;
     FForm: TScrollingWinControl;
     FStyle: integer;
     FDefault: boolean;
     Procedure CMMouseEnter( Var Message: TMessage ); Message CM_MOUSEENTER;
     Procedure CMMouseLeave( Var Message: TMessage ); Message CM_MOUSELEAVE;
     procedure SetForm(const Value: TScrollingWinControl);
  protected
    { Protected declarations }
  public
    { Public declarations }
     Selected: Boolean;
     constructor Create( AOwner : TComponent ); override;
     property Form: TScrollingWinControl read FForm write SetForm;
     Procedure Paint; Override;
     procedure SetActive(const Value: boolean);
     procedure SetStyle (const Value: integer);
     procedure SetDefault(const Value: boolean);
     Procedure Style0(AOwner : TComponent);
     Procedure Style1(AOwner : TComponent);
  published
    { Published declarations }
     property Active: boolean read FActive write SetActive;
     Property Color: TColor read eColor write eColor;
     property Default: Boolean read FDefault write SetDefault;
     property Flat default True;
     Property SelBackColor: TColor read eSelBackColor write eSelBackColor;
     Property SelBorderColor: TColor read eSelBorderColor write eSelBorderColor;
     Property SelFontColor: TColor read eSelFontColor write eSelFontColor;
     Property Style: integer read FStyle write SetStyle;
  end;
type
  TGsXPOkButton = class(TGsXPButton)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
     constructor Create( AOwner : TComponent ); override;
  published
    { Published declarations }
  end;
  type
  TGsXPCancelButton = class(TGsXPButton)
  private
    { Private declarations }
   protected
    { Protected declarations }
  public
    { Public declarations }
     constructor Create( AOwner : TComponent );  override;
  published
    { Published declarations }
  end;
procedure Register;
implementation
constructor TGsXPButton.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
     ControlStyle:= ControlStyle + [csAcceptsControls];
  Font.Color := clWindowText;
  Color := clBtnFace;
  FButtonDown := FALSE;
  Flat := True;
  FForm := Owner as TScrollingWinControl;
  Selected:= False;
  Height:= 22;
  SelFontColor := clHighLight;
  SelBackColor := clHighLightText;
  SelBorderColor := $0000A9E1;
  //Top:= 4;
  Transparent:= False;
  Width:= 65;
  Active := True;
  Style := 0;
end;
procedure TGsXPButton.SetStyle(const Value: integer);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    end;
end;
Procedure TGsXPButton.CMMouseEnter( Var Message: TMessage );
Begin
//hmmm, no selected property either ehhh.
     //Flicker GONE!
     If Selected = False then
     begin
     Selected := True;
     RePaint;
     end
     else
     Selected := True;
     exit;
End;
Procedure TGsXPButton.CMMouseLeave( Var Message: TMessage );
Begin
     Selected:= False;
     FButtonDown := FALSE;
     RePaint;
     IF Selected = False then exit;
End;
procedure TGsXPButton.SetForm(const Value: TScrollingWinControl);
var
  Hold: boolean;
begin
  if Value <> FForm then
  begin
    Hold := Active;
    Active := false;
    FForm := Value;
    if Hold then
      Active := True;
  end;
end;
procedure TGsXPButton.SetActive(const Value: boolean);
begin
  FActive := Value;
end;
procedure TGsXPButton.SetDefault(const Value: boolean);
begin
FDefault := Value;
end;
function NewColor(Canvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b: integer;
begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;
  r := r + Round((255 - r) * (value / 100));
  g := g + Round((255 - g) * (value / 100));
  b := b + Round((255 - b) * (value / 100));
  Result := Windows.GetNearestColor(Canvas.Handle, RGB(r, g, b));
end;
Procedure TGsXPButton.style0(AOwner : TComponent);
var
        Gbtn: TGsXPButton;
        Right, Bottom: integer;
        Selector, txtRect, ARect, iconRect, FRect: TRect;
        FColor, FSelBackColor, FSelFontColor: TColor;
        FSelBorderColor: TColor;
        SelText: String;
        TextFormat: integer;
        x1, y1 : integer;
        i,v : integer;
        CWidth, CHeight: INTEGER;
begin
  inherited;
        Gbtn:= TGsXPButton(Self);
        FColor := eColor;
        FSelBackColor := eSelBackColor;
        FSelFontColor := eSelFontColor;
        Bottom := (Gbtn.Canvas.ClipRect.Bottom);
        Right := (Gbtn.Canvas.ClipRect.Right);
        ARect.Top := (Gbtn.Canvas.ClipRect.Top);
        ARect.Right := Right;
        ARect.Bottom := Bottom;
        Arect.Left := (Gbtn.Canvas.ClipRect.Left);
        TextFormat := DT_Left;
        SelText :=( '  ' + (Gbtn.Caption));
      If Gbtn.Active then
      Gbtn.Style := 0;
        begin
        Flat:= True;
        font.Color := font.Color;
        Color := FColor;
        Selector := Rect( ARect.Left , ARect.Top ,
        ARect.right , ARect.bottom );
        FRect:= Rect(Arect.Left+3,Arect.Top +3,
        Arect.Right -3, Arect.Bottom -3);
        //capture the image rect and layout image and text
        //Heavy on the math...
if not Glyph.Empty then begin
       if Layout = blGlyphLeft then begin
          SelText:= SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        iconRect.Left := (ARect.Right - CWidth) div 2;
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        x1:= (iconRect.Right);
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end
        else
        if Layout = blGlyphRight then begin
        Seltext := SelText + '  ';
        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        TxtRect:= (Gbtn.Canvas.ClipRect);
        TxtRect.Left := (ARect.Right - CWidth) div 2;
        TxtRect.Top := (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        IconRect.Left := (TxtRect.Right);
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end
        else
        if Layout = blGlyphTop then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height);
        TxtRect:= (Gbtn.Canvas.ClipRect);
        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (iconRect.Bottom + 2);
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        end
        else
        if Layout = blGlyphBottom then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height);
        TxtRect:= (Gbtn.Canvas.ClipRect);
        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (txtRect.Bottom + 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end;
        end
        else
        if Glyph.Empty Then
        begin
        SelText := SelText;
        x1:= (Arect.Right - Canvas.TextWidth(SelText))div 2;
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end;
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FColor;
      Canvas.FillRect(ARect);
IF GBtn.Default THEN
  IF not Selected then
    If not Gbtn.MouseCapture then
  begin
        v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 2);
      if v > 96 then v := 96;
      Canvas.Brush.Color := NewColor(Canvas, $00FF8080, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.RoundRect(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom , 5, 5);
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);
           //draw the text
        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
              if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              Gbtn.Glyph.FreeImage;
              end;
      end;
   end;
   If Gbtn.Selected then
        if not gbtn.MouseCapture then
      begin
 //gradient begin
                  v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 3);
      if v > 96 then v := 96;
      Canvas.Brush.Color := NewColor(Canvas, $0000A9E1, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.RoundRect(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom , 5, 5);
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);
       Canvas.Font.color := FSelFontColor;
        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
                      if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              Gbtn.Glyph.FreeImage;
              end;
     end;
 end;
        //draw the  outline
        Canvas.Brush.Style := bsClear;
        Canvas.Pen.color := $00984E00;
        Canvas.RoundRect(ARect.Left,
                ARect.top, ARect.right,
                ARect.bottom, 5, 5);
        //override the button canvas
        Canvas.Brush.Style := bsSolid;
        Canvas.Brush.Color:= FColor;
        Canvas.FillRect(Frect);
        //over ride the text
                 DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
                if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              gbtn.Glyph.FreeImage;
                end;
    end;
end;
Procedure TGsXPButton.Style1(AOwner : TComponent);
var
        Gbtn: TGsXPButton;
        Right, Bottom: integer;
        Selector, txtRect, ARect, iconRect, FRect: TRect;
        FColor, FSelBackColor, FSelFontColor: TColor;
        FSelBorderColor: TColor;
        SelText: String;
        TextFormat: integer;
        x1, y1 : integer;
        i,v : integer;
        CWidth, CHeight: INTEGER;
begin
  inherited;
//let the games begin
        Gbtn:= TGsXPButton(Self);
        FColor := eColor;
        FSelBackColor := eSelBackColor;
        FSelFontColor := eSelFontColor;
        Bottom := (Gbtn.Canvas.ClipRect.Bottom);
        Right := (Gbtn.Canvas.ClipRect.Right);
        ARect.Top := (Gbtn.Canvas.ClipRect.Top);
        ARect.Right := Right;
        ARect.Bottom := Bottom;
        Arect.Left := (Gbtn.Canvas.ClipRect.Left);
        TextFormat := DT_Left;
        SelText :=( '  ' + (Gbtn.Caption));
      If Gbtn.Active then
      Gbtn.Style := 1;
        begin
        Flat:= True;
        font.Color := font.Color;
        Color := FColor;
        Selector := Rect( ARect.Left , ARect.Top ,
        ARect.right , ARect.bottom );
        FRect:= Rect(Arect.Left+3,Arect.Top +3,
        Arect.Right -3, Arect.Bottom -3);
        //capture the image rect and layout image and text
        //Heavy on the math...
if not Glyph.Empty then begin
       if Layout = blGlyphLeft then begin
          SelText:= SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        iconRect.Left := (ARect.Right - CWidth) div 2;
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        x1:= (iconRect.Right);
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end
        else
        if Layout = blGlyphRight then begin
        Seltext := SelText + '  ';
        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        TxtRect:= (Gbtn.Canvas.ClipRect);
        TxtRect.Left := (ARect.Right - CWidth) div 2;
        TxtRect.Top := (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        IconRect.Left := (TxtRect.Right);
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end
        else
        if Layout = blGlyphTop then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height) div 2;
        TxtRect:= (Gbtn.Canvas.ClipRect);
        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (ARect.Bottom div 2) - (CHeight) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (iconRect.Bottom + 2);
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        end
        else
        if Layout = blGlyphBottom then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        TxtRect:= (Gbtn.Canvas.ClipRect);
        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (txtRect.Bottom + 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end;
        end
        else
        if Glyph.Empty Then
        begin
        SelText := SelText;
        x1:= (Arect.Right - Canvas.TextWidth(SelText))div 2;
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end;
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FColor;
      Canvas.FillRect(ARect);
IF GBtn.Default THEN
  IF not Selected then
    If not Gbtn.MouseCapture then
  begin
        v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 2);
      if v > 96 then v := 96;
      Canvas.Brush.Color := NewColor(Canvas, $00FF8080, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.Rectangle(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom );
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);
           //draw the text
        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
      end;
   end;
   If Gbtn.Selected then
        if not gbtn.MouseCapture then
      begin
 //gradient begin
                  v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 3);
      if v > 96 then v := 96;
      Canvas.Brush.Color := NewColor(Canvas, $0000A9E1, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.Rectangle(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom );
      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);
       Canvas.Font.color := FSelFontColor;
        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
     end;
 end;
        //draw the  outline
        Canvas.Brush.Style := bsClear;
        Canvas.Pen.color := $00984E00;
        Canvas.Rectangle(ARect.Left,
                ARect.top, ARect.right,
                ARect.bottom);
        //override the button canvas
        Canvas.Brush.Style := bsSolid;
        Canvas.Brush.Color:= FColor;
        Canvas.FillRect(Frect);
        //over ride the text
                 DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
                if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              gbtn.Glyph.FreeImage;
                end;
    end;
end;
Procedure TGsXPButton.Paint;
var
        Gbtn: TGsXPButton;
begin
//this grabs all the speedbuttons properties
        inherited;
//protect our design environment
  if not (csDesigning in ComponentState) then
  begin
        Gbtn:= TGsXPButton(Self);
If Gbtn.Active then
    If Gbtn.Style = 0 then
    begin
    Style0(Self);
    end
    else
    If Gbtn.Style = 1 then
    begin
     Style1(Self);
    end;
   end;
end;
//Begin Ok Button
  //inherits from the GSXPButton. only caption changed
  //same for cancel button.
  //make mods to main button, changes are inherited.
constructor TGsXPOkButton.Create( AOwner : TComponent );
begin
  // Don't forget to call the ancestor's constructor
  inherited Create( AOwner );
  Caption := '&OK';
end;
//Begin Cancel Button
constructor TGsXPCancelButton.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
  Caption := '&Cancel';
end;
procedure Register;
begin
  RegisterComponents('GenieOSTools', [TGsXPButton, TGsXPOKButton, TGsXPCancelButton]);
end;
end.

Включить Drop Shadow Effect окна в XP.

type 
  TForm1 = class(TForm) 
  protected 
    procedure CreateParams(var Params: TCreateParams); override; 
  end; 
var 
  Form1: TForm1; 
implementation 
{$R *.dfm} 
procedure TForm1.CreateParams(var Params: TCreateParams); 
const 
  CS_DROPSHADOW = $00020000; 
begin 
  inherited; 
  Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; 
end;

Использовать визуальный стиль XP для своего приложения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  To benefit from the new look and feel (Visual Styles) for the Windows XP 
  environment, you must include a Manifest in your application. 
  (Either as resource or as file in the same directory where your application 
  resides) 
  The manifest is a XML document. It will allow Windows XP to decide which 
  version of the comctl32.dll to use when binding. 
  The XML document contains information about the application you are 
  writing as well as information concerning the version of the comctl32.dll to use. 
  The following instruction shows how to 
   * create the manifest document 
   * create the XP resource file 
   * include the file in your application 
  The steps 1-4 show how to create the files. 
  You can also download the manifest and resource file from the 
  Demo-download. 
}
 { 
  Damit eine Anwendung das neue Look-and-Feel (Visual Styles) von Windows XP 
  annimmt, muss eine Manifest Datei in der Applikation enthalten sein. 
  (Entweder als Ressource oder im gleichen Verzeichnis, wo sich die Applikation 
  befindet) 
  Das Manifest ist ein XML Dokument. 
  Wenn Windows dieses in einer EXE Datei vorfindet, wird automatisch die Version 6 
  von comctl32.dll geladen und die Controls erscheinen im XP Design. 
  Die Folgende Anleitung zeigt, wie man 
  * das manifest Dokument erstellt 
  * die Ressourcen Datei erstellt 
  * die Ressource in die Anwendung einbindet. 
  Das Manifest und die Ressourcen Datei konnen auch uber das "Demo-Download" heruntergeladen 
  werden. Dann konnen die Schritte 1-4 ausgelassen werden. 
}
 {1) 
  Copy this sample manifest and paste it into notepad or any text editor. 
  Kopiere das Beispiel Manifest und fuge es in einen Texteditor ein (z.B Notepad}
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
 <assemblyIdentity
     version="1.0.0.0"
     processorArchitecture="X86"
     name="CompanyName.ProductName.MyProgram"
     type="win32"
 />
 <description>Your Application Description</description>
 <dependency>
     <dependentAssembly>
         <assemblyIdentity
             type="win32"
             name="Microsoft.Windows.Common-Controls"
             version="6.0.0.0"
             processorArchitecture="X86"
             publicKeyToken="6595b64144ccf1df"
             language="*"
         />
     </dependentAssembly>
 </dependency>
 </assembly>
 {2) 
  To customize to fit your application, replace "name" from assemblyIdentity and the 
  "description" string with your own data. Then save the file as WinXP.manifest 
  Andere im Manifest den "name" von assemblyIdentity und die 
  "description" mit eigenen Angaben. Speichere das Manifest als WinXP.manifest}
 {3) 
  Create another file which contains instructions to include the 
  WinXP.manifest (XML) document. 
  The contents of the WinXP.rc looks like this: 
  Erstelle eine weitere Datei, welche die Instruktionen zur Erstellung 
  der Ressourcen Datei enthalt. 
  Der Inhalt von WinXP.rc schaut so aus:}
   1 24 "WinXP.manifest"
 {4) 
  Now we need to use Delphi''s resource compiler (brcc32.exe) to compile the WinXP.rc file. 
  Doing so will result in a WinXP.res 
  From the command line, type the following: 
  Compilire nun mit Borland''s Resource Compiler (brcc32.exe), 
  die Datei WinXP.rc. Es wird dann eine WinXP.res Datei erstellt. 
  Gibt im MS-DOS Prompt, im Verzeichnis wo sich WinXP.rc befindet, nun folgendes ein:}
   brcc32 WinXP.rc
 (*5)
   Now include the resource in your application.
   Include the following compiler directive:
   immediately after {$R *.DFM}:
   Nun muss noch eine Compiler Directive dem Sourcecode hinzugefugt werden.
   Der Eintrag sollte unmittelbar nach der Form Directive {$R *.DFM} folgen,
   so wie hier:*)
   {$R WinXP.res}
 {6) 
  Compile your application and run it! 
  Compiliere die Anwendung und starte sie!}
 {7) 
  Test it if it runs correctly. 
  Note that some controls don''t adapt the new XP design such
   as TGroupBox, TSpeedButton and some others.
   If you use the TListView component with the view style of vsReport, have a look at this tip:
   http://www.swissdelphicenter.ch/de/showcode.php?id=1117 
  Uberpruf nun, ob die Anwendung korrekt lauft. Einige Controls nehmen das neue XP Design
   nicht an (TGroupBox, TSpeedButton und andere)
   Bei der ListView mit vsReport Style muss dies beachtet werden:
   http://www.swissdelphicenter.ch/de/showcode.php?id=1117 
}

Показать символы для пароля в XP.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  Set the font to Wingdings and then type on the 
  PasswordChar := l; 
  or ... 
}
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Edit1.Font.Name := 'Wingdings';
   Edit1.PasswordChar := 'l';
 end;

Создать Системную Точку Восстановления (XP).

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  If you haven't installed the Microsoft Scripting Control yet 
  (TScriptControl component), 
  get it from http://www.msdn.microsoft.com/scripting/ 
  Once you've downloaded and run the installation, start Delphi and go to the 
  Component | Import ActiveX Control... menu. 
  Select "Microsoft Script Control 1.0" from the Listbox amd click "Install" 
  to install the component into Delphi's palette. 
  What you should end up with now is a TScriptControl component on your ActiveX tab. 
  Start a new application, and drop a TButton, and a TScriptControl onto the main form. 
  In the OnClick event of Button1, put the following code: 
}
 { 
  Wenn du das Microsoft Scripting Control noch nicht installiert hast 
  (Komponente TScriptControl), dann kannst du hier runterladen: 
  http://www.msdn.microsoft.com/scripting/ 
  Nachdem Herunterladen und der Installation wahle in der Delphi IDE unter dem 
  Menu "Komponente" den Menupunkt "ActiveX importieren". 
  Dann in der Listbox "Microsoft Script Control 1.0" auswahlen und "Installieren..." 
  anklicken. 
  Nun sollte die TScriptControl Komponente unter dem ActiveX Register zu finden sein. 
  Plaziere nun eine TScriptControl Komponente und einen TButton auf einer Form und 
  schreibe im OnClick Ereignis des Buttons den folgenden Code: 
}
 procedure TForm1.Button1Click(Sender: TObject);
 var
   sr: OLEVAriant;
 begin
   ScriptControl1.Language := 'VBScript';
   sr := ScriptControl1.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")');
   if sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then
     ShowMessage('New Restore Point successfully created.')
     // Wiederherstellungspunkt erfolgreich erstellt 
  else
     ShowMessage('Restore Point creation Failed!');
     // Wiederherstellungspunkt Erstellung fehlgeschlagen. 
end;
 {*****************************************************}
 {2. Using the SRSetRestorePoint() API from SrClient.dll}
 // Translation from SRRestorePtAPI.h 
const
  // Type of Event 
 BEGIN_SYSTEM_CHANGE = 100;
  END_SYSTEM_CHANGE  = 101;
  // Type of Restore Points 
 APPLICATION_INSTALL =  0;
  CANCELLED_OPERATION = 13;
  MAX_DESC = 64;
  MIN_EVENT = 100;
 // Restore point information 
type
 PRESTOREPTINFOA = ^_RESTOREPTINFOA;
 _RESTOREPTINFOA = packed record
     dwEventType: DWORD;  // Type of Event - Begin or End 
    dwRestorePtType: DWORD;  // Type of Restore Point - App install/uninstall 
    llSequenceNumber: INT64;  // Sequence Number - 0 for begin 
    szDescription: array [0..MAX_DESC] of CHAR; // Description - Name of Application / Operation 
end;
 RESTOREPOINTINFO = _RESTOREPTINFOA;
 PRESTOREPOINTINFOA = ^_RESTOREPTINFOA;
 // Status returned by System Restore 
PSMGRSTATUS = ^_SMGRSTATUS;
 _SMGRSTATUS = packed record
     nStatus: DWORD; // Status returned by State Manager Process 
    llSequenceNumber: INT64;  // Sequence Number for the restore point 
end;
 STATEMGRSTATUS =  _SMGRSTATUS;
 PSTATEMGRSTATUS =  ^_SMGRSTATUS;
 function SRSetRestorePointA(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus: PSTATEMGRSTATUS): Bool;
   stdcall; external 'SrClient.dll' Name 'SRSetRestorePointA';
 // Example how to create and cancel a previous restore point. 
// Ref: http://tinyurl.com/78pv 
procedure TForm1.Button1Click(Sender: TObject);
 const
  CR = #13#10;
var
  RestorePtSpec: RESTOREPOINTINFO;
   SMgrStatus: STATEMGRSTATUS;
 begin
   // Initialize the RESTOREPOINTINFO structure 
  RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE;
   RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL;
   RestorePtSpec.llSequenceNumber := 0;
   RestorePtSpec.szDescription := 'SAMPLE RESTORE POINT';
   if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
   begin
     ShowMessage('Restore point set. Restore point data:' + CR+
       'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+
       'Status: ' + Format('%u', [SMgrStatus.nStatus]));
       // Restore Point Spec to cancel the previous restore point. 
      RestorePtSpec.dwEventType := END_SYSTEM_CHANGE;
       RestorePtSpec.dwRestorePtType  := CANCELLED_OPERATION;
       RestorePtSpec.llSequenceNumber := SMgrStatus.llSequenceNumber;
       // This is the sequence number returned by the previous call. 
      // Canceling the previous restore point 
      if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
         ShowMessage('Restore point canceled. Restore point data:' + CR+
         'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+
         'Status: ' + Format('%u', [SMgrStatus.nStatus]))
       else
         ShowMessage('Couldn''t cancel restore point.');
     end
     else
       ShowMessage('Couldn''t set restore point.');
   end;
 end;

Преобразование даты и времени в строковый вид YYYYMMDDHHNNSS и обратно.

Автор: Mfender WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование даты-времени в строковый вид и обратно (yyyymmddhhnnss)
Иногда становится нужно хранить дату и время в виде yyyymmddhhnnss.
Так, по некоторым причинам, с ними порой легче общаться и сортировать.
Зависимости: Windows, StdCtrls, SysUtils
Автор:       mfender, mfender@fromru.com, Майкоп
Copyright:   mfender
Дата:        10 августа 2003 г.
***************************************************** }
function mfStringToDateTime(const mfDTStr: string): TDateTime;
//Возвращает значение TDateTime из входящей строки mfDTStr
//в формате YYYYMMDDHHMMSS
var
  Safe: string;
begin
  Safe := ShortDateFormat; //сохраняем формат даты
  ShortDateFormat := 'dd.mm.yyyy hh:nn:ss'; //придаем произвольный вид
  //формату даты-времени
  mfStringToDateTime := StrToDateTime(Copy(mfDTStr, 7, 2) + '.' +
    Copy(mfDTStr, 5, 2) + '.' +
    Copy(mfDTStr, 1, 4) + ' ' +
    Copy(mfDTStr, 9, 2) + ':' +
    Copy(mfDTStr, 11, 2) + ':' +
    Copy(mfDTStr, 13, 2));
  //Преобразуем, собственно, части строки в соответствующие
  //детали даты и времени
  ShortDateFormat := Safe; //возвращаем дате первоначальный вид
end;
function mfDateTimeToString(const Date: TDateTime): string;
//Возвращает строку в формате YYYYMMDDHHNNSS из входящей DateTime
begin
  mfDateTimeToString := FormatDateTime('yyyymmddhhnnss', Date); //No comments
end;

Технология dbExpress (статья).

Одной из проблем различных технологий доступа к данным, используемым в приложениях Delphi, является трудность распространения готовых приложений. Для BDE требуется отдельная установка, которая занимает порядка 15 Мбайт дискового пространства, а также специальная настройка псевдонимов (см. гл. 16). ADO предустановлена в операционной системе, но нуждается в настраиваемых провайдерах данных (см. гл. 19). При необходимости обновить версию ADO, дистрибутив вашего приложения "потяжелеет" более чем на 2 Мбайт.

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

Примечание.

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

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

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

DB2;

InterBase;

MySQL;

Oracle;

Microsoft SQL Server 2000.

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

Кроме того, технология dbExpress обеспечивает доступ к данным в кроссплатформенных приложениях для Windows и Linux, т. к. применяется и в Delphi и Kylix (см. гл. 4), а способы ее применения идентичны.

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

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

Компоненты dbExpress располагаются в Палитре компонентов на одноименной странице.

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

Настройка соединений с различными серверами баз данных, подключение драйверов и установка их параметров;

Способы использования компонентов dbExpress для просмотра данных и создание пользовательского интерфейса приложений;

Программная реализация редактирования данных;

Работа с данными в режиме кэширования изменений и использование компонента TSimpleDataSet;

Использование интерфейсов;

Распространение приложений с интегрированной технологией dbExpress.

©Drkb::02685.

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

Code: Unit Stilizator; Interface. Uses. Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, XPMan; Type. TForm1 = class(TForm). MemoSource: TMemo; MemoDest: TMemo; Button: TButton; XPManifest1: TXPManifest; Procedure ButtonClick(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. Procedure ConvertText(Letter: String); End; Var. Form1: TForm1; RS : Array [0..65] of String; PRS : Array [0..65] of String; ES : Array [0..51] of String; PPS : Array [0..51] of String; Implementation. Uses AboutUnit; {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. RS[0]:='а'; PRS[0]:='@'; RS[1]:='б'; PRS[1]:='6'; RS[2]:='в'; PRS[2]:='B'; RS[3]:='г'; PRS[3]:='r'; RS[4]:='д'; PRS[4]:='g'; RS[5]:='е'; PRS[5]:='e'; RS[6]:='ё'; PRS[6]:='e'; RS[7]:='ж'; PRS[7]:='}|{'; RS[8]:='з'; PRS[8]:='3'; RS[9]:='и'; PRS[9]:='u'; RS[10]:='й'; PRS[10]:='u'; RS[11]:='к'; PRS[11]:='k'; RS[12]:='л'; PRS[12]:='JI'; RS[13]:='м'; PRS[13]:='M'; RS[14]:='н'; PRS[14]:='H'; RS[15]:='о'; PRS[15]:='o'; RS[16]:='п'; PRS[16]:='n'; RS[17]:='р'; PRS[17]:='p'; RS[18]:='с'; PRS[18]:='c'; RS[19]:='т'; PRS[19]:='T'; RS[20]:='у'; PRS[20]:='y'; RS[21]:='ф'; PRS[21]:='%'; RS[22]:='х'; PRS[22]:='x'; RS[23]:='ц'; PRS[23]:='?'; RS[24]:='ч'; PRS[24]:='4'; RS[25]:='ш'; PRS[25]:='III'; RS[26]:='щ'; PRS[26]:='III,'; RS[27]:='ъ'; PRS[27]:='b'; RS[28]:='ы'; PRS[28]:='bI'; RS[29]:='ь'; PRS[29]:='b'; RS[30]:='э'; PRS[30]:='&'; RS[31]:='ю'; PRS[31]:='I-o'; RS[32]:='я'; PRS[32]:='9I'; RS[33]:='А'; PRS[33]:='A'; RS[34]:='Б'; PRS[34]:='6'; RS[35]:='В'; PRS[35]:='B'; RS[36]:='Г'; PRS[36]:='r'; RS[37]:='Д'; PRS[37]:='g'; RS[38]:='Е'; PRS[38]:='E'; RS[39]:='Ё'; PRS[39]:='E'; RS[40]:='Ж'; PRS[40]:='}|{'; RS[41]:='З'; PRS[41]:='3'; RS[42]:='И'; PRS[42]:='U'; RS[43]:='Й'; PRS[43]:='U'; RS[44]:='К'; PRS[44]:='K'; RS[45]:='Л'; PRS[45]:='JL'; RS[46]:='М'; PRS[46]:='M'; RS[47]:='Н'; PRS[47]:='H'; RS[48]:='О'; PRS[48]:='O'; RS[49]:='П'; PRS[49]:='n'; RS[50]:='Р'; PRS[50]:='p'; RS[51]:='С'; PRS[51]:='c'; RS[52]:='Т'; PRS[52]:='T'; RS[53]:='У'; PRS[53]:='Y'; RS[54]:='Ф'; PRS[54]:='%'; RS[55]:='Х'; PRS[55]:='X'; RS[56]:='Ц'; PRS[56]:='?'; RS[57]:='Ч'; PRS[57]:='4'; RS[58]:='Ш'; PRS[58]:='III'; RS[59]:='Щ'; PRS[59]:='III,'; RS[60]:='Ъ'; PRS[60]:='b'; RS[61]:='Ы'; PRS[61]:='bI'; RS[62]:='Ь'; PRS[62]:='b'; RS[63]:='Э'; PRS[63]:='&'; RS[64]:='Ю'; PRS[64]:='I-O'; RS[65]:='Я'; PRS[65]:='9I'; ES[0]:='a'; PPS[0]:='@'; ES[1]:='b'; PPS[1]:='6'; ES[2]:='c'; PPS[2]:='|_|,'; ES[3]:='d'; PPS[3]:=',^,'; ES[4]:='e'; PPS[4]:='e'; ES[5]:='f'; PPS[5]:='%'; ES[6]:='g'; PPS[6]:='|"'; ES[7]:='h'; PPS[7]:=']['; ES[8]:='i'; PPS[8]:='|/|'; ES[9]:='j'; PPS[9]:='>|<'; ES[10]:='k'; PPS[10]:='K'; ES[11]:='l'; PPS[11]:='/\'; ES[12]:='m'; PPS[12]:='M'; ES[13]:='n'; PPS[13]:='|-|'; ES[14]:='o'; PPS[14]:='0'; ES[15]:='p'; PPS[15]:='n'; ES[16]:='q'; PPS[16]:='k|3'; ES[17]:='r'; PPS[17]:='P'; ES[18]:='s'; PPS[18]:='$'; ES[19]:='t'; PPS[19]:='T'; ES[20]:='u'; PPS[20]:='Y'; ES[21]:='v'; PPS[21]:='\/'; ES[22]:='w'; PPS[22]:='|3'; ES[23]:='x'; PPS[23]:='kc'; ES[24]:='y'; PPS[24]:='9'; ES[25]:='z'; PPS[25]:='3'; ES[26]:='A'; PPS[26]:='@'; ES[27]:='B'; PPS[27]:='6'; ES[28]:='C'; PPS[28]:='|_|,'; ES[29]:='D'; PPS[29]:=',^,'; ES[30]:='E'; PPS[30]:='E'; ES[31]:='F'; PPS[31]:='%'; ES[32]:='G'; PPS[32]:='|"'; ES[33]:='H'; PPS[33]:='}{'; ES[34]:='I'; PPS[34]:='|/|'; ES[35]:='J'; PPS[35]:='>|<'; ES[36]:='K'; PPS[36]:='K'; ES[37]:='L'; PPS[37]:='/\'; ES[38]:='M'; PPS[38]:='M'; ES[39]:='N'; PPS[39]:='|-|'; ES[40]:='O'; PPS[40]:='0'; ES[41]:='P'; PPS[41]:='n'; ES[42]:='Q'; PPS[42]:='K|3'; ES[43]:='R'; PPS[43]:='P'; ES[44]:='S'; PPS[44]:='$'; ES[45]:='T'; PPS[45]:='T'; ES[46]:='U'; PPS[46]:='Y'; ES[47]:='V'; PPS[47]:='\/'; ES[48]:='W'; PPS[48]:='|3'; ES[49]:='X'; PPS[49]:=']['; ES[50]:='Y'; PPS[50]:='9'; ES[51]:='Z'; PPS[51]:='3'; End; Procedure TForm1.ButtonClick(Sender: TObject); Var. I : Integer; Letter : String; Begin. MemoDest.Clear; For i := 0 to MemoSource.GetTextLen - 1 do begin. MemoSource.SelStart := i; MemoSource.SelLength := 1; Letter := MemoSource.SelText; ConvertText(Letter); Sleep(5). End; MemoSource.SelLength := 0; End; Procedure TForm1.ConvertText(Letter: String); Var. I : Integer; Begin. For i := 0 to 65 do begin. If Letter = RS[i] then. Letter := PRS[i]; End; For i := 0 to 51 do begin. If Letter = ES[i] then. Letter := PPS[i]; End; MemoDest.Text := MemoDest.Text + Letter; End; End.

©Drkb::04654.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Драйверы доступа к данным.

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

Драйверы dbExpress.

Сервер БД Драйвер Клиентское ПО.

DB2 Dbexpdb2.dll Db2cli.dll.

InterBase Dbexpint.dll GDS32.DLL.

Informix Dbexpinf.dll Isqlb09a.dll.

MS SQL Server Dbexpmss.dll OLE DB.

MySQL Dbexpmys.dll LIBMYSQL.DLL.

Oracle Dbexpora.dll OCI.DLL.

Перечисленные в табл. файлы находятся в папке \Delphi7\Bin.

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

Стандартные настройки для каждого драйвера хранятся в файле \Borland Shared\DBExpress\dbxdrivers.ini.

Отладка приложений с технологией dbExpress.

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

Через свойство.

Property SQLConnection: TSQLConnection;

Компонент связывается с отлаживаемым соединением. Затем компонент включается установкой Active = True.

Теперь во время выполнения приложения сразу после открытия соединения свойство.

Property TraceList: TStrings;

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

Procedure SaveToFile(AFileName: string);

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

Property FileName: string;

Но только тогда, когда свойство.

Property AutoSave: Boolean;

Будет иметь значение True. Свойство.

Property MaxTraceCount: Integer;

Определяет максимальное число контролируемых команд, а также управляет процессом контроля. При значении -1 ограничения снимаются, а при значении 0 контроль останавливается. Текущее число проверенных команд содержится в свойстве.

Property TraceCount: Integer;

Перед записью команды в список вызывается метод-обработчик.

TTraceEvent = procedure(Sender: TObject; CBInfo: pSQLTRACEDesc; var LogTrace: Boolean) of object;

Property OnTrace: TTraceEvent;

А сразу после записи в список вызывается.

TTraceLogEvent = procedure (Sender: TObject; CBInfo: pSQLTRACEDesc) of object;

Property OnLogTrace: TTraceLogEvent;

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

Если же компонент TSQLMonitor не подходит, можно воспользоваться методом.

Procedure SetTraceCallbackEvent(Event: TSQLCallbackEvent; IClientlnfo: Integer);

Компонента TSQLConnection. Параметр процедурного типа Event определяет функцию, которая будет вызываться при выполнении каждой команды. Параметр iclientinfo должен содержать любое число.

Он позволяет разработчику самостоятельно определить функцию типа.

TSQLCallbackEvent:

TRACECat = TypedEnum;

TSQLCallbackEvent = function(CallType: TRACECat; CBInfo: Pointer): CBRType; stdcall;

Эта функция будет вызываться каждый раз при прохождении команды. Текст команды будет передаваться в буфер CBInfo. Разработчику необходимо лишь выполнить запланированные действия с буфером внутри функции.

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

Function GеtТгасе1nfо(CallType: TRACECat; CBInfo: Pointer): CBRType;stdcall;

Begin.

If Assigned(Forml.TraceList) then Forml.TraceList.Add(pChar(CBinfo));

End;

Procedure TForml.MyConnectionBeforeConnect(Sender: TObject);

Begin.

TraceList := TStringList.Create;

End;

Procedure TForml.MyConnectionAfterDisconnect(Sender: TObject);

Begin.

If Assigned(TraceList) then.

Begin.

TraceList.SaveToFile('с:\Temp\TraceInfo.txt');

TraceList.Free;

End;

End;

Procedure TForml.StartBtnClick(Sender: TObject);

Begin.

MyConnection.SetTraceCallbackEvent(GetTracelnfo, 8);

MyConnection.Open;

{...}

MyConnection.Close;

End;

Перед открытием соединения в методе-обработчике BeforeConnection создается объект типа TStringList. После закрытия соединения этот объект сохраняется в файле и уничтожается.

Перед открытием соединения (метод-обработчик нажатия кнопки Start) при помощи метода SetTraceCallbackEvent с соединением связывается функция GetTracelnfo.

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

Примечание.

В своей работе компонент TSQLMonitor также использует вызовы метода SetTraceCallbackEvent. Поэтому одновременно применять компонент и собственные функции нельзя.

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

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

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

Алгоритм работы сокетного сервера.

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

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

Разберем схему подробнее:

· Определение св-в Port и ServerType - чтобы к серверу могли нормально подключаться клиенты, нужно, чтобы порт, используемый сервером точно совпадал с портом, используемым клиентом (и наоборот). Свойство ServerType определяет тип подключения (подробнее см.ниже);

· Открытие сокета - открытие сокета и указанного порта. Здесь выполняется автоматическое начало ожидания подсоединения клиентов (Listen);

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

· Отключение клиента - Здесь клиент отключается и закрывается его сокетное соединение с сервером;

· Закрытие сервера и сокета - По команде администратора сервер завершает свою работу, закрывая все открытые сокетные каналы и прекращая ожидание подключений клиентов.

Следует заметить, что пункты 3-4 повторяются многократно, т.е. эти пункты выполняются для каждого нового подключения клиента.

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

Краткое описание компонента TServerSocket.

Здесь мы познакомимся с основными свойствами, методами и событиями компонента.

Свойства.

Socket - класс TServerWinSocket, через который Вы имеете доступ к открытым сокетным каналам. Далее мы рассмотрим это свойство более подробно, т.к. оно, собственно и есть одно из главных. Тип: TServerWinSocket;

ServerType - тип сервера. Может принимать одно из двух значений: stNonBlocking - синхронная работа с клиентскими сокетами. При таком типе сервера Вы можете работать с клиентами через события OnClientRead и OnClientWrite. stThreadBlocking - асинхронный тип. Для каждого клиентского сокетного канала создается отдельный процесс (Thread). Тип: TServerType;

ThreadCacheSize - количество клиентских процессов (Thread), которые будут кэшироваться сервером. Здесь необходимо подбирать среднее значение в зависимости от загруженности Вашего сервера. Кэширование происходит для того, чтобы не создавать каждый раз отдельный процесс и не убивать закрытый сокет, а оставить их для дальнейшего использования. Тип: Integer;

Active - показатель того, активен в данных момент сервер, или нет. Т.е., фактически, значение True указывает на то, что сервер работает и готов к приему клиентов, а False - сервер выключен. Чтобы запустить сервер, нужно просто присвоить этому свойству значение True. Тип: Boolean;

Port - номер порта для установления соединений с клиентами. Порт у сервера и у клиентов должны быть одинаковыми. Рекомендуются значения от 1025 до 65535, т.к. от 1 до 1024 - могут быть заняты системой. Тип: Integer;

Service - строка, определяющая службу (ftp, http, pop, и т.д.), порт которой будет использован. Это своеобразный справочник соответствия номеров портов различным стандартным протоколам. Тип: string;

Методы.

Open - Запускает сервер. По сути, эта команда идентична присвоению значения True свойству Active;

Close - Останавливает сервер. По сути, эта команда идентична присвоению значения False свойству Active.

События.

OnClientConnect - возникает, когда клиент установил сокетное соединение и ждет ответа сервера (OnAccept);

OnClientDisconnect - возникает, когда клиент отсоединился от сокетного канала;

OnClientError - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;

OnClientRead - возникает, когда клиент передал берверу какие-либо данные. Доступ к этим данным можно получить через пеаедаваемый параметр Socket: TCustomWinSocket;

OnClientWrite - возникает, когда сервер может отправлять данные клиенту по сокету;

OnGetSocket - в обработчике этого события Вы можете отредактировать параметр ClientSocket;

OnGetThread - в обработчике этого события Вы можете определить уникальный процесс (Thread) для каждого отдельного клиентского канала, присвоив параметру SocketThread нужную подзадачу TServerClientThread;

OnThreadStart, OnThreadEnd - возникает, когда подзадача (процесс, Thread) запускается или останавливается, соответственно;

OnAccept - возникает, когда сервер принимает клиента или отказывает ему в соединении;

OnListen - возникает, когда сервер переходит в режим ожидания подсоединения клиентов.

TServerSocket.Socket (TServerWinSocket).

Итак, как же сервер может отсылать данные клиенту? А принимать данные? В основном, если Вы работаете через события OnClientRead и OnClientWrite, то общаться с клиентом можно через параметр ClientSocket (TCustomWinSocket). Про работу с этим классом можно прочитать в статье про клиентские сокеты, т.к. отправка/посылка данных через этот класс аналогична - методы (Send/Receive)(Text,Buffer,Stream). Также и при работе с TServerSocket.Socket. Однако, т.к. здесь мы рассматриваем сервер, то следует выделить некоторые полезные свойства и методы:

· ActiveConnections (Integer) - количество подключенных клиентов;

· ActiveThreads (Intеgег) - количество работающих процессов;

· Connections (array) - массив, состоящий из отдельных классов TClientWinSocket для каждого подключенного клиента. Например, такая команда:

· ServerSocket1.Socket.Connections[0].SendText('Hello!');

· отсылает первому подключенному клиенту сообщение 'Hello!'. Команды для работы с элементами этого массива - также (Send/Receive)(Text,Buffer, Stream);

· IdleThreads (Integer) - количество свободных процессов. Такие процессы кэшируются сервером (см. ThreadCacheSize);

· LocalAddress, LocalHost, LocalPort - соответственно - локальный IP-адрес, хост-имя, порт;

· RemoteAddress, RemoteHost, RemotePort - соответственно - удаленный IP-адрес, хост-имя, порт;

· Методы Lock и UnLock - соответственно, блокировка и разблокировка сокета.

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

А теперь рассмотрим вышеприведенное на конкретном примере. Скачать уже готовые исходники можно, щелкнув здесь.

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

Пример 1. Протоколирование и изучение работы сервера, посылка/прием сообщений через сокеты.

Code: {... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}. {Полный исходник смотри здесь}. Procedure TForm1.Button1Click(Sender: TObject); Begin. {Определяем порт и запускаем сервер}. ServerSocket1.Port := 1025; {Метод Insert вставляет строку в массив в указанную позицию}. Memo2.Lines.Insert(0,'Server starting'); ServerSocket1.Open; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. {Останавливаем сервер}. ServerSocket1.Active := False; Memo2.Lines.Insert(0,'Server stopped'); End; Procedure TForm1.ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket); Begin. {Здесь сервер "прослушивает" сокет на наличие клиентов}. Memo2.Lines.Insert(0,'Listening on port '+IntToStr(ServerSocket1.Port)); End; Procedure TForm1.ServerSocket1Accept(Sender: TObject; Socket: TCustomWinSocket); Begin. {Здесь сервер принимает клиента}. Memo2.Lines.Insert(0,'Client connection accepted'); End; Procedure TForm1.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket); Begin. {Здесь клиент подсоединяется}. Memo2.Lines.Insert(0,'Client connected'); End; Procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket); Begin. {Здесь клиент отсоединяется}. Memo2.Lines.Insert(0,'Client disconnected'); End; Procedure TForm1.ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; Var ErrorCode: Integer); Begin. {Произошла ошибка - выводим ее код}. Memo2.Lines.Insert(0,'Client error. Code = '+IntToStr(ErrorCode)); End; Procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket); Begin. {От клиента получено сообщение - выводим его в Memo1}. Memo2.Lines.Insert(0,'Message received from client'); Memo1.Lines.Insert(0,'> '+Socket.ReceiveText); End; Procedure TForm1.ServerSocket1ClientWrite(Sender: TObject; Socket: TCustomWinSocket); Begin. {Теперь можно слать данные в сокет}. Memo2.Lines.Insert(0,'Now can write to socket'); End; Procedure TForm1.ServerSocket1GetSocket(Sender: TObject; Socket: Integer; Var ClientSocket: TServerClientWinSocket); Begin. Memo2.Lines.Insert(0,'Get socket'); End; Procedure TForm1.ServerSocket1GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; Var SocketThread: TServerClientThread); Begin. Memo2.Lines.Insert(0,'Get Thread'); End; Procedure TForm1.ServerSocket1ThreadEnd(Sender: TObject; Thread: TServerClientThread); Begin. Memo2.Lines.Insert(0,'Thread end'); End; Procedure TForm1.ServerSocket1ThreadStart(Sender: TObject; Thread: TServerClientThread); Begin. Memo2.Lines.Insert(0,'Thread start'); End; Procedure TForm1.Button3Click(Sender: TObject); Var i: Integer; Begin. {Посылаем ВСЕМ клиентам сообщение из Edit1}. For i := 0 to ServerSocket1.Socket.ActiveConnections-1 do begin. ServerSocket1.Socket.Connections[i].SendText(Edit1.Text); End; Memo1.Lines.Insert(0,'< '+Edit1.Text); End;

Перетаскивание информации с помощью мыши стало стандартом для программ, работающих в Windows. Часто это бывает удобно и позволяет добиться более быстрой работы. В данной статье я постарался показать максимальное количество примеров использования данной технологии при разработке приложений в среде Delphi. Конечно, результат может быть достигнут различными путями, продемонстрированные приемы не являются единственными и, возможно, не всегда самые оптимальные, но вполне работоспособны, и указывают направление поиска. Надеюсь, что они побудят начинающих программистов к более широкому использованию Drag'n'Drop в своих программах, тем более что пользователи, особенно неопытные, быстро привыкают к перетаскивание и часто его применяют.

Проще всего делать Drag из тех компонентов, для которых однозначно ясно, что именно перетаскивать. Для этого устанавливаем у источника DragMode = dmAutomatic, а у приемника пишем обработчики событий OnDragOver - разрешение на прием, и OnDragDrop - действия, производимые при окончании перетаскивания.

Code: Procedure TForm1.StringGrid2DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. Accept := Source = Edit1; // разрешено перетаскивание только из Edit1, // при работе программы меняется курсор. End; Procedure TForm1.StringGrid2DragDrop(Sender, Source: TObject; X, Y: Integer); Var. ACol, ARow: Integer; Begin. StringGrid2.MouseToCell( X, Y, ACol, ARow); // находим, над какой ячейкой произвели Drop. StringGrid2.Cells[ Acol, Arow] := Edit1.Text; // записываем в нее содержимое Edit1. End;

Delphi и Flash. Совмещение несовместимого!

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

Итак, как же совместить Флэш и Дельфи? (Надеюсь, что у вас Флэш установлен:)).

Запустите Дельфи и выберите пункт меню Component->Import ActiveX Control... Перед вами откроется диалоговое окно с заголовком Import ActiveX Control. В разделе Registered Controls выберите Shockwave Flash. В разделе Pallete Page... Выберите страницу в палитре компонентов, на которой будет располагаться установленный компонент (по умолчанию это ActiveX). В разделе Unit Dir Name... путь к папке куда будет установлен компонент.

Нажмите на кнопку Install. Перед вами появится окно, в котором вам нужно будет выбрать в какой пакет будет установлен компонент (вы можете установить как в уже существующий, так и в новый пакет). Затем перед вами появится окно редактирования выбранного пакета и Дельфи вас спросит: "...Package will be rebuilt. Continue?". Ответьте Yes. Все готово теперь можно использовать флэш в ваших приложениях!!!

Теперь, чтобы показать вам как пользоваться этим компонентом, попробуем вместе сделать программу для просмотра *.SWF файлов. Для этого нам понадобятся следующие компоненты: TShockwaveFlash (для удобства назовите его просто Flash1), TTrackBar, TTimer, TOpendialog и три кнопки TButton ("открыть", "старт" и "стоп").

Для начала установим необходимые свойства OpenDialog'a.

Свойство Filter может быть таким: Флэш-ролики|*.swf.

Свойство DefaultExt должно быть: *.swf.

Для Timer'a нужно установить свойство Interval равным 1.

Для TShockwaveFlash:

Name сделайте равным Flash1.

Свойство Playing установите в false.

Свойство BGColor, установите как вам хочется (цвет фона).

Теперь напишем обработчик события OnClick для кнопки, которая вызывать OpenDialog:

If open1.Execute then begin.

Flash1.Movie:=open1.FileName;

Trackbar1.Max:=flash1.TotalFrames; {это делается для того, чтобы потом можно было перемещаю ползунок посмотреть каждый кадр ролика}.

В обработчик события OnClick для второй кнопки ("Старт") напишем:

Flash1.Play;

Ну тут вообще все просто! Почти таким же образом это будет выглядеть для третьей кнопки ("Стоп"):

Flash1.Stop;

Теперь сделаем, чтобы при перемещении ползунка Trackbar'a мы могли посмотреть каждый кадр (событие OnChange):

If Flash1.IsPlaying=true then Flash1.Stop; {если ролик проигрывается, то надо его остановить}.

Flash1.GotoFrame(trackbar1.position); {открываем кадр номер которого соответствует позиции ползунка}.

Ну и наконец осталось сделать чтобы при проигрывании ролика ползунок перемещался, указывая сколько осталось и сколько прошло. Для этого то мы и используем Timer. В обработчик события OnTimer,напишем:

Trackbar1.Position:=flash1.CurrentFrame;

Приведу полный код приложения:

Code: Unit flash; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, OleCtrls, ShockwaveFlashObjects_TLB, ExtCtrls; Type. TForm1 = class(TForm). Flash1: TShockwaveFlash; Button1: TButton; TrackBar1: TTrackBar; Open1: TOpenDialog; Button2: TButton; Button3: TButton; Timer1: TTimer; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Button3Click(Sender: TObject); Procedure TrackBar1Change(Sender: TObject); Procedure Timer1Timer(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. If open1.Execute then. Begin. Flash1.Movie := open1.FileName; Trackbar1.Max := flash1.TotalFrames; End; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Flash1.Play; End; Procedure TForm1.TrackBar1Change(Sender: TObject); Begin. If Flash1.IsPlaying = true then Flash1.Stop; Flash1.GotoFrame(trackbar1.position); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. Flash1.Stop; End; Procedure TForm1.Timer1Timer(Sender: TObject); Begin. Trackbar1.Position := flash1.CurrentFrame; End; End.

Иногда нужные мысли приходят после того, как программа сдана заказчику. Для этого придумали плугины. Плугины - это простая dll библиотека, в которой обязательно присутствует ряд процедур и функций, которые выполняют определенные разработчиком действия, например (из моей практики) : function PluginType : PChar; - функция, определяющая назначение плугина. function PluginName : PChar; - функция, которая возвращает название плугина. Это название будет отоброжаться в меню. function PluginExec(AObject:ТТип) : boolean; - главный обработчик, выполняет определённые действия и возвращает TRUE; и ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res файл можно так: 1. создайте файл с расширением *.rc 2. напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций 3. откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ .

Загрузка плугина.

Перейдём к теоретической части.

Раз плугин это dll значит её можно подгрузить следующими способами:

1. Прищипыванием её к программе!

Function PluginType : PChar; external 'myplg.dll';

//в таком случае dll должна обязательно лежать возле exe и мы не можем передать.

Туда конкретное имя! не делать же все плугины одного имени! это нам не подходит.

Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке. Этот способ.

Может подойти для поддержки обновления вашей программы!

2. Динамический.

Это оэночает, что мы грузим её так, как нам надо! Вот пример:

Code: Var. PluginType: function: PChar; // объявляем процедурный тип функции из плугина. PlugHandle: THandle; //объявляем переменную типа хендл в которую мы занесём хендл плугина. Procedure Button1Click(Sender: TObject); Begin. PlugHandle := LoadLibrary('MYplg.DLL'); //грузим плугин. If PlugHandle <> 0 then //Получилось или нет?? Begin. @PluginType := GetProcAddress(plugHandle,'Plugintype'); // ищем функцию в dll. If @PluginType <> nil then ShowMessage(PluginType); //вызываем функцию. End; FreeLibrary(LibHandle);//освобождаем библиотеку. End;

Библиотека KOL.

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

Кладов В.Л.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Почта: bonanzas@xcl.cjb.net.

Взято с сайта www.emanual.ru.

©Drkb::04526.

Часть 1.

Как преодолеть отсутствие множественного наследования в Delphi.

Все сообщество программистов разделяется по приверженности к той или иной платформе и языку программирования. Один предпочитает Delphi для Windows, другому нравится ассемблер для DOS, третий программирует на Си++ для OS/2. Навыки работы для одной платформы совсем не обязательно станут полезными при переходе на другую, а знание отдельного языка программирования может даже затруднить изучение другого. Все эти преграды можно было бы преодолеть, используя межпроцессное взаимодействие между программами, однако здесь возникает новая трудность - разные формы внутреннего представления данных в этих программах.

Однако есть способ решения этих проблем: применение единого стандарта для организации связи между объектами, который не зависит от используемой платформы и языка. Именно такова разработанная Microsoft компонентная модель объекта COM (Component Object Model). Данная технология уже получила широкое внедрение: ведь на ее базе работают механизмы OLE и ActiveX.

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

В этой и следующей за ней статьях мы рассмотрим процесс формирования COM-объектов в среде разработки Borland Delphi. В первой части мы коснемся проблем организации COM-объектов в Delphi и покажем несколько вариантов их решения. Во второй части будут приведены примеры пяти типовых объектов для стандартных надстроек оболочки Windows 95. В отдельных случаях COM-объекты целесообразно хранить как EXE-файлы. Однако в этой статье с целью простоты изложения материала будут рассматриваться лишь COM-объекты, записанные в наиболее часто используемой для них форме DLL-модулей.

Основные понятия о COM-объектах.

Что же кроется внутри COM-объекта? Нам совершенно не нужно вникать в это! Весь обмен информацией между COM-объектом и внешним миром осуществляется через конкретные интерфейсы. Каждый из них реализует доступ к одной или нескольким функциям, обратиться к которым может любой объект или программа. Все COM-объекты должны иметь интерфейс IUnknown с тремя его функциями - AddRef, Release и QueryInterface. Функции AddRef и Release отвечают за обычную задачу сопровождения жизненного цикла объекта. При каждом обращении к Addref содержимое счетчика ссылок данного объекта увеличивается на единицу, а при каждом обращении к Release - уменьшается. Когда значение счетчика достигает нуля, объект уничтожается. Практический интерес представляет третья функция интерфейса IUnknown - QueryInterface. Получив доступ к обязательно присутствующему интерфейсу IUnknown, программа или любой другой объект сразу может обратиться к функции QueryInterface и узнать обо всех остальных имеющихся у этого объекта интерфейсах. IUnknown находится на вершине иерархического дерева всех COM-интерфейсов. Любой другой интерфейс фактически наследуется от IUnknown и поэтому также должен обеспечивать доступ ко всем трем IUnknown-функциям.

Понятие объекта как в терминологии COM-модели, так и в Delphi или Си++ имеет практически одинаковый смысл. А вот COM-интерфейс больше напоминает Delphi- или Си++-объект, у которого отсутствуют public-переменные и имеются лишь виртуальные методы. Список функций интерфейса соответствует виртуальной таблице методов Object Pascal или объекта Си++. Создать COM-интерфейс можно средствами практически любого языка: достаточно лишь объявить объект с требуемым списком виртуальных методов. Само собой разумеется, что задаваемые определения методов должны в точности соответствовать определениям функций в самих интерфейсах. Однако, кроме того, необходимо соблюдать правильный порядок их размещения в виртуальной таблице. Сказанное означает, что эти определения следуют в заданном порядке, а перед ними нет никаких других виртуальных методов.

В файле OLE2.PAS, входящем в комплект Delphi 2.0, показано, как давать определение типу интерфейсного объекта для IUnknown и для нескольких десятков других, производных от IUnknown интерфейсов, например IClassFactory, IMarshal и IMalloc. Каждому методу, входящему в состав этих интерфейсных объектов, дается такое определение, как virtual, stdcall или abstract. Пояснение, зачем указывается virtual, уже было дано. Ключевое слово stdcall сообщает компилятору, что вызов данного метода следует производить по стандартным правилам. Слово abstract указывает, что функциональная часть данного метода в текущем объекте отсутствует, но она должна присутствовать у некоторого дочернего объекта, для которого будет создаваться его экземпляр. В файле OLE2.PAS дается определение для более чем 50 интерфейсов, непосредственно наследуемых от IUnknown, причем каждый из них предоставляет как собственный интерфейс, так и IUnknown.

Однако из-за необходимости иметь для COM-объекта два или более интерфейса, не считая IUnknown, возникает одна проблема. В Си++ достаточно дать определение COM-объекту как многократно наследуемому от тех объектов, где требуемые интерфейсы содержатся. Однако для объектов Delphi возможность множественного наследования не допускается. Поэтому приходится искать иное решение. (К сведению программистов на Си++: при создании COM-объектов на базе MFC применяется технология, аналогичная описываемой здесь для Delphi. Эта особенность остается незамеченной на фоне великого множества макроконструкций, которые используются при определении COM-объекта средствами MFC.).

Сателлиты и контейнеры.

Ключевой фактор создания в Delphi COM-объекта с несколькими интерфейсами состоит в том, что объект рассматривается как передающий контейнер этих интерфейсов. Совсем не обязательно иметь их внутри данного COM-объекта. Необходимо лишь при запросе, когда вызывается метод QueryInterface его интерфейса IUnknown предоставлять доступ к нужному интерфейсу. Такой COM-объект, созданный в Delphi, может лишь непосредственно обслуживать три свои функции IUnknown, а при запросе через QueryInterface интерфейса IUnknown, передавать указатель на самого себя. Он действует как передаточный механизм и распорядитель других объектов, имеющих свои интерфейсы. Такие интерфейсные объекты-сателлиты отображают свои три IUnknown-метода на общий объект-контейнер. Если приходит запрос на один из сателлитных интерфейсов (как правило, через метод QueryInterface), контейнер передает указатель на соответствующий объект-сателлит. На листинге показан пример, как средствами Delphi можно создать такие интерфейсные объекты с типами сателлит и контейнер, а также как подготовить соответствующий интерфейс IClassFactory.

Листинг. С помощью этих обобщенных объектов с описанием интерфейсов можно создавать в среде Delphi COM-объекты с несколькими интерфейсами.

Code: Unit DelphCom; // "Обобщенные" объекты. Предназначены для создания COM-объектов. // в Delphi. ISatelliteUnknown - интерфейсный объект, который. // будет обслуживаться через IContainerUnknown. Любой реальный. // COM-объект с несколькими интерфейсами. // будет наследоваться из IContainerUnknown и содержать. // функцию QueryInterface. Interface. Uses Windows, Ole2, Classes, SysUtils, ShellApi, ShlObj; Var DllRefCount : Integer; Type. IContainerUnknown = class; ISattelliteUnknown = class(IUnknown). // Этот интерфейс будет обслуживаться через IContainerUnknown. // Отображает три IUnknown-функции на свой объект-контейнер. Protected. FContainer : IContainerUnknown; Public. Constructor Create(vContainer : IContainerUnknown); Function QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; override; Function AddRef: Longint; override; Function Release: Longint; override; End; IContainerUnknown = class (IUnknown). Protected. FRefCount : Integer; Public. Соnstгисtог Create; Destructor Destroy; override; (IUnknown-функции). Function QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; override; Function AddRef: LongInt; override; Function Release: LongInt; override; End; IMyClassFactory = с1аss(IClassFactory). Private. FRefcount : Integer; Public. Constructor Create; Destructor Destroy; override; Function QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; override; Function AddRef: LongInt; override; Function Release: LongInt; override; // В дочернем объекте должно быть дано определение. // для функции CreateInstance. Function LockServer(fLock: BOOL): HResult; override; End; Function DLLCanUnloadNow : HResult; StdCall; Export; Implementation. (****** ISatelliteUnknown *****). Constructor ISatelliteUnknown.Create(vContainer: IContainerUnknown); Begin fContainer := vContainer; end; Function ISatelliteUnknown.QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; Begin. Result := fContainer.QueryInterface(WantIid, ReturnedObject); End; Function ISatelliteUnknown.AddRef: LongInt; Begin Result := fContainer.AddRef; end; Function ISatelliteUnknown.Release: LongInt; Begin Result := fContainer.Release; end; (****** IContainerUnknown ******). Constructor IContainerUnknown.Create; Begin. Inherited Create; FRefCount := 0; Inc(DllRefCount); End; Destructor IContainerUnknown.Destroy; Begin. Dec(DllRefCount); Inherited Destroy; End; Function IContainerUnknown.QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; Var P : IUnknown; Begin. If IsEqualIID(WantIID, IID_IUnknown) then P := Self. Else P:= nil; Pointer(ReturnedObject) := P; If P = nil then Result := E_NOINTERFACE. Else begin. P.AddRef; Result := S_OK; End; End; Function IContainerUnknown.AddRef: LongInt; Begin Inc(FRefCount); Result := FRefCount; end; Function IContainerUnknown.Release: LongInt; Begin. Dec(FRefCount); Result := FRefCount; If FRefCount = 0 then Free; End; (****** IMyClassFactory ******). Constructor IMyClassFactory.Create; Begin. Inherited Create; Inc(DllRefCount); FRefCount := 0; End; Destructor IMyClassFactory.Destroy; Begin. Dec(DllRefCount); Inherited Destroy; End; Function IMyClassFactory.QueryInterface(const WantIID: TIID; Var ReturnedObject): HResult; Begin. If IsEqualIID(WantIiD, IID_IUnknown) or. IsEqualIID(WantIiD, IID_IClassFactory) then. Begin. Pointer(ReturnedObject) := Self; AddRef; Result := S_OK; End. Else begin. Pointer(ReturnedObject) := NIL; Result := E_NOINTERFACE; End. End; Function IMyClassFactory.AddRef: LongInt; Begin. Inc(FRefCount); Result := FRefCount; End; Function IMyClassFactory.Release: LongInt; Begin. Dec(FRefCount); Result := FRefCount; If FRefCount = 0 then Free; End; Function IMyClassFactory.LockServer(fLock: Bool):HResult; Begin Result := E_NOTIMPL; end; (****** экспортируемая функция ******). Function DLLCanUnloadNow: hResult; StdCall; Export; Begin. If DllRefCount = 0 then Result := S_OK. Else Result := S_FALSE; End; Initialization. DllRefCount := 0; End.

Функция возвращает True если найден OLE-объект.

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

Code: If not IsOLEObjectInstalled('Excel.Application') then. ShowMessage('Класс не зарегистрирован'). Else. ShowMessage('Класс найден'); Function IsOLEObjectInstalled(Name: String): boolean; Var. ClassID: TCLSID; Rez : HRESULT; Begin. // Ищем CLSID OLE-объекта. Rez := CLSIDFromProgID(PWideChar(WideString(Name)), ClassID); If Rez = S_OK then // Объект найден. Result := true. Else. Result := false; End;

Данный пример ищет активный экземпляр Excel и делает его видимым.

Code: Var. ExcelApp : Variant; Begin. Try. // Ищем запущеный экземплят Excel, если он не найден, вызывается исключение. ExcelApp := GetActiveOleObject('Excel.Application'); // Делаем его видимым. ExcelApp.Visible := true; Except. End;

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

Code: Var. ExcelApp, Workbook, Range, Cell1, Cell2, ArrayData : Variant; TemplateFile : String; BeginCol, BeginRow, i, j : integer; RowCount, ColCount : integer; Begin. // Координаты левого верхнего угла области, в которую будем выводить данные. BeginCol := 1; BeginRow := 5; // Размеры выводимого массива данных. RowCount := 100; ColCount := 50; // Создание Excel. ExcelApp := CreateOleObject('Excel.Application'); // Отключаем реакцию Excel на события, чтобы ускорить вывод информации. ExcelApp.Application.EnableEvents := false; // Создаем Книгу (Workbook). // Если заполняем шаблон, то Workbook := ExcelApp.WorkBooks.Add('C:\MyTemplate.xls'); Workbook := ExcelApp.WorkBooks.Add; // Создаем Вариантный Массив, который заполним выходными данными. ArrayData := VarArrayCreate([1, RowCount, 1, ColCount], varVariant); // Заполняем массив. For I := 1 to RowCount do. For J := 1 to ColCount do. ArrayData[I, J] := J * 10 + I; // Левая верхняя ячейка области, в которую будем выводить данные. Cell1 := WorkBook.WorkSheets[1].Cells[BeginRow, BeginCol]; // Правая нижняя ячейка области, в которую будем выводить данные. Cell2 := WorkBook.WorkSheets[1].Cells[BeginRow + RowCount - 1, BeginCol + ColCount - 1]; // Область, в которую будем выводить данные. Range := WorkBook.WorkSheets[1].Range[Cell1, Cell2]; // А вот и сам вывод данных. // Намного быстрее поячеечного присвоения. Range.Value := ArrayData; // Делаем Excel видимым. ExcelApp.Visible := true;

Повторюсь, не смотря на то, что я уже писал об этом в предыдущей статье. В главной форме проекта-примера я объявил свойство IWorkbook. Оно будет содержать интерфейс книги, которую мы будем создавать и использовать. Естественно, в обработчике FormDestroy я его освобождаю.

Property IWorkbook: Excel8TLB._Workbook read FIWorkbook;

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

If Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then.

FIWorkbook := IXLSApp.Workbooks.Add(EmptyParam, 0);

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

Коллекция Workbooks содержит все открытые книги и предоставляет возможность кое-как управлять всем этим.

Боже, как убоги коллекции от Microsoft, и особенно поиск в них! Я отклонюсь, но это надо видеть. Вот пример поиска книги с заданным именем, приведенный как совет в MSDN Office Developer.

Code: Public Function SheetExists(strSearchFor As String) As Boolean. SheetExists = False. For Each sht In ThisWorkbook.Worksheets. If sht.Name = strSearchFor Then. SheetExists = True. End If. Next sht. End Function.

Есть в VBA одна вещь, которая меня раздражает. Это ActiveSheet и ActiveWorkbook, а также возможность работы с Cells и Range без указания, к какому листу или книге они принадлежат. Одно время я боролся сам с собой, то применяя, то совсем отказываясь от подобных конструкций. Окончательно я отказался от этого лишь после обнаружения многочисленных ошибок в анализе «лога» моего Web-сервера, который я сделал на VBA. Благо, при работе в Delphi нет возможности написать Cells(x, y) = NewValue, подразумевая при этом какой-то неуловимый ActiveSheet. Поэтому прежде, чем работать с отдельными ячейками, я всегда получаю интерфейс на конкретный и вполне осязаемый лист книги. И делю это так:

Code: Var ISheet: Excel8TLB._Worksheet; … ISheet := IWorkbook.Worksheets.Item['Лист1'] as Excel8TLB._Worksheet;

Для использования следующиего примера необходимо иметь "Microsoft Video for Windows SDK". Пример показывает, как открыть видео устройство для захвата видео, как сграбить фрейм с устройства, как сохранить этот фрейм на диск в виде файла .BMP, как записать .AVI файл (со звуком, но без предварительного просмотра), и как закрыть устройство.

Замечание: Для работы примера необходимо иметь установленное устройство захвата видео (video capture device).

Пример:

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; Type. TForm1 = class(TForm). Panel1: TPanel; OpenVideo: TButton; CloseVideo: TButton; GrabFrame: TButton; SaveBMP: TButton; StartAVI: TButton; StopAVI: TButton; SaveDialog1: TSaveDialog; Procedure FormCreate(Sender: TObject); Procedure OpenVideoClick(Sender: TObject); Procedure CloseVideoClick(Sender: TObject); Procedure GrabFrameClick(Sender: TObject); Procedure SaveBMPClick(Sender: TObject); Procedure StartAVIClick(Sender: TObject); Procedure StopAVIClick(Sender: TObject); Private. { Private declarations }. HWndC : THandle; CapturingAVI : bool; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const WM_CAP_START = WM_USER; Const WM_CAP_STOP = WM_CAP_START + 68; Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10; Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11; Const WM_CAP_SAVEDIB = WM_CAP_START + 25; Const WM_CAP_GRAB_FRAME = WM_CAP_START + 60; Const WM_CAP_SEQUENCE = WM_CAP_START + 62; Const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20; Function capCreateCaptureWindowA(lpszWindowName : PCHAR; DwStyle : longint; X : integer; Y : integer; NWidth : integer; NHeight : integer; ParentWin : HWND; NId : integer): HWND; STDCALL EXTERNAL 'AVICAP32.DLL'; Procedure TForm1.FormCreate(Sender: TObject); Begin. CapturingAVI := false; HWndC := 0; SaveDialog1.Options := [ofHideReadOnly, ofNoChangeDir, ofPathMustExist]. End; Procedure TForm1.OpenVideoClick(Sender: TObject); Begin. HWndC := capCreateCaptureWindowA('My Own Capture Window', WS_CHILD or WS_VISIBLE , Panel1.Left, Panel1.Top, Panel1.Width, Panel1.Height, Form1.Handle, 0); If hWndC <> 0 then. SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0); End; Procedure TForm1.CloseVideoClick(Sender: TObject); Begin. If hWndC <> 0 then begin. SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0); HWndC := 0; End; End; Procedure TForm1.GrabFrameClick(Sender: TObject); Begin. If hWndC <> 0 then. SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0); End; Procedure TForm1.SaveBMPClick(Sender: TObject); Begin. If hWndC <> 0 then begin. SaveDialog1.DefaultExt := 'bmp'; SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp'; If SaveDialog1.Execute then. SendMessage(hWndC, WM_CAP_SAVEDIB, 0, Longint(pchar(SaveDialog1.FileName))); End; End; Procedure TForm1.StartAVIClick(Sender: TObject); Begin. If hWndC <> 0 then begin. SaveDialog1.DefaultExt := 'avi'; SaveDialog1.Filter := 'AVI files (*.avi)|*.avi'; If SaveDialog1.Execute then begin. CapturingAVI := true; SendMessage(hWndC, WM_CAP_FILE_SET_CAPTURE_FILEA, 0, Longint(pchar(SaveDialog1.FileName))); SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0); End; End; End; Procedure TForm1.StopAVIClick(Sender: TObject); Begin. If hWndC <> 0 then begin. SendMessage(hWndC, WM_CAP_STOP, 0, 0); CapturingAVI := false; End; End; End.

Code: Unit NetProcs; Interface. Uses Classes, Windows; Type. TAdapterStatus = record. Adapter_address: array [0..5] of Char; Filler: array [1..4*SizeOf(Char)+19*SizeOf(Word). +3*SizeOf(DWORD)] of Byte; End; THostInfo = record. Username: PWideChar; Logon_domain: PWideChar; Oth_domains: PWideChar; Logon_server: PWideChar; End;{record}. Function IsNetConnect : Boolean; {Возвращает TRUE если компьютер подключен к сети, иначе - FALSE}. Function AdapterToString(Adapter: TAdapterStatus): string; {Преобразует MAC адес в привычный xx-xx-xx-xx}. Function GetMacAddresses(const Machine: string; Const Addresses: TStrings): Integer; {Заполняет Addresses MAC-адресами компьютера с сетевым именем Machine. Возвращает число МАС адресов на компьютере}. Function GetNetUser(HostName: WideString): THostInfo; {Возвращает LOGIN текущего пользователя на HOSTNAME компьютере}. Implementation. Uses NB30, SysUtils; Function IsNetConnect : Boolean; Begin. If GetSystemMetrics(SM_NETWORK) AND $01 = $01. Then Result:= True. Else Result:= False; End;{function}. Function AdapterToString(Adapter: TAdapterStatus): string; Begin. With Adapter do Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [ Integer(adapter_address[0]), Integer(adapter_address[1]), Integer(adapter_address[2]), Integer(adapter_address[3]), Integer(adapter_address[4]), Integer(adapter_address[5])]); End;{function}. Function GetMacAddresses(const Machine: string; Const Addresses: TStrings): Integer; Const NCBNAMSZ = 16; // absolute length of a net name. MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive. NRC_GOODRET = $00; // good return. NCBASTAT = $33; // NCB ADAPTER STATUS. NCBRESET = $32; // NCB RESET. NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS. Type. PNCB = ^TNCB; TNCBPostProc = procedure (P: PNCB); stdcall; TNCB = record. Ncb_command: Byte; Ncb_retcode: Byte; Ncb_lsn: Byte; Ncb_num: Byte; Ncb_buffer: PChar; Ncb_length: Word; Ncb_callname: array [0..NCBNAMSZ - 1] of Char; Ncb_name: array [0..NCBNAMSZ - 1] of Char; Ncb_rto: Byte; Ncb_sto: Byte; Ncb_post: TNCBPostProc; Ncb_lana_num: Byte; Ncb_cmd_cplt: Byte; Ncb_reserve: array [0..9] of Char; Ncb_event: THandle; End; PLanaEnum = ^TLanaEnum; TLanaEnum = record. Length: Byte; Lana: array [0..MAX_LANA] of Byte; End; ASTAT = record. Adapt: TAdapterStatus; Namebuf: array [0..29] of TNameBuffer; End; Var. NCB: TNCB; Enum: TLanaEnum; I: Integer; Adapter: ASTAT; MachineName: string; Begin. Result := -1; Addresses.Clear; MachineName := UpperCase(Machine); If MachineName = '' Then MachineName := '*'; FillChar(NCB, SizeOf(NCB), #0); NCB.ncb_command := NCBENUM; NCB.ncb_buffer := Pointer(@Enum); NCB.ncb_length := SizeOf(Enum); If Word(NetBios(@NCB)) = NRC_GOODRET. Then begin. Result := Enum.Length; For I := 0 to Ord(Enum.Length) - 1. Do begin. FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBRESET; NCB.ncb_lana_num := Enum.lana[I]; If Word(NetBios(@NCB)) = NRC_GOODRET. Then begin. FillChar(NCB, SizeOf(TNCB), #0); NCB.ncb_command := NCBASTAT; NCB.ncb_lana_num := Enum.lana[i]; StrLCopy(NCB.ncb_callname, PChar(MachineName),NCBNAMSZ); StrPCopy(@NCB.ncb_callname[Length(MachineName)], StringOfChar(' ', NCBNAMSZ - Length(MachineName))); NCB.ncb_buffer := PChar(@Adapter); NCB.ncb_length := SizeOf(Adapter); If Word(NetBios(@NCB)) = NRC_GOODRET. Then Addresses.Add(AdapterToString(Adapter.adapt)); End; End; End; End;{function}. Function. NetWkstaUserEnum(servername: PWideChar; Level : DWord; Var bufptr: Pointer; Prefmaxlen: DWord; Var entriesread: PDWord; Var totalentries: PDWord; Var resumehandle: PDWord ): LongInt ; Stdcall; external 'netapi32.dll' name 'NetWkstaUserEnum'; Function GetNetUser(HostName: WideString): THostInfo; Var. Info: Pointer; ElTotal: PDWord; ElCount: PDWord; Resume: PDWord; Error: LongInt; Begin. Resume:=0; NetWkstaUserEnum(PWideChar(HostName),1, Info,0, ElCount,ElTotal,Resume); Error:=NetWkstaUserEnum(PWideChar(HostName),1,Info,256*Integer(ElTotal), ElCount,ElTotal,Resume); Case Error of. ERROR_ACCESS_DENIED: Result.UserName:= 'ERROR - ACCESS DENIED'; ERROR_MORE_DATA: Result.UserName:= 'ERROR - MORE DATA'; ERROR_INVALID_LEVEL: Result.UserName:= 'ERROR - INVALID LEVEL'; Else if Info <> nil. Then Result:=THostInfo(info^). Else begin. Result.username:= '???'; Result.logon_domain:= '???'; Result.oth_domains:= '???'; Result.logon_server:= '???'; End;{if}. End;{case}. End; {function}. End.

Code: /// <summary> /// Enumerates all installed Common Language Runtime Engines. /// </summary> /// <param name="Index">Zero-based index of looked runtime. Record.</param> /// <returns>True if runtime with specified index found.</returns> Function EnumInstalledRuntimes(Index: Integer; out VersionName: String): Boolean; Var. Hkey: Windows.HKEY; Hsubkey: Windows.HKEY; I: Cardinal; J: Cardinal; NameBuf: array[0..MAX_PATH] of Char; CNameBuf: Cardinal; Lwt: TFileTime; Vt: DWORD; AnyFound: Boolean; Begin. Result := False; VersionName := ''; If ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar('SOFTWARE\Microsoft\.NETFramework\policy'), 0, KEY_ENUMERATE_SUB_KEYS, hkey) then. Try. I := 0; While True do. Begin. AnyFound := False; CNameBuf := MAX_PATH + 1; If ERROR_SUCCESS <> RegEnumKeyEx(hkey, I, @NameBuf[0], CNameBuf,nil, nil, nil, @lwt) then. Begin. Break; End; If (NameBuf[0] = 'v') and (NameBuf[1] in ['1'..'9']) then. Begin. VersionName := String(NameBuf); If ERROR_SUCCESS = RegOpenKeyEx(hkey, @NameBuf[0], 0,KEY_QUERY_VALUE, hsubkey) then. Try. J := 0; While true do. Begin. CNameBuf := MAX_PATH + 1; If ERROR_SUCCESS <> RegEnumValue(hsubkey, J, @NameBuf[0],CNameBuf, nil, @vt, nil, nil) then. Begin. Break; End; If (vt = REG_SZ) and (NameBuf[0] <> #0) then. Begin. VersionName := VersionName + '.' + String(NameBuf); AnyFound := True; Break; End; Inc(J); End; Finally. RegCloseKey(hsubkey); End; End; Inc(I); If AnyFound then. Begin. If Index = 0 then. Begin. Result := True; Break; End; Dec(Index); End; End; Finally. RegCloseKey(hkey); End; End;

Список зарезервированных слов Local SQL BDE.

ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING,

AT, AUTO, AUTOINC, AVG.

BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY,

BYTES.

CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH,

COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL,

CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT,

CURSOR.

DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT,

DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP.

ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS,

EXIT, EXTERNAL, EXTRACT.

FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION.

GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP,

GROUP_COMMIT_WAIT_TIME.

HAVING, HOUR.

IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT,

INTEGER, INTO, IS, ISOLATION.

JOIN.

KEY.

LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE,

LOG_BUFFER_SIZE.

MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE,

MODULE_NAME, MONEY, MONTH.

NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL,

NUM_LOG_BUFFERS, NUMERIC.

OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW.

PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION,

POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY,

PRIVILEGES.

RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION,

REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES,

RETURNS, REVOKE, RIGHT, ROLLBACK.

SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA,

SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE,

STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING,

SUM, SUSPEND.

TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE,

TO, TRAILING, TRANSACTION, TRIGGER, TRIM.

UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER.

VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW.

WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE.

YEAR.

||, -, *, /, <>, <, >, ,(comma), =, <=, >=, ~=, !=, ^=, (, ).

Взято с сайта http://www.delphikingdom.ru/

©Drkb::02501.

Code: Procedure GetEnumNameList(Pti: PTypeInfo; AList: TStrings; X: Integer); {(********************************************************** Will return in AList string version of an. Enumerated type less the first X characters . Eg X = 4. And. Type. EXORBuySell = ( XOR_BUY, XOR_SELL. ); GetEnumNameList(TypeInfo(eXORBuySell), ComboBox1.Items, 4); Now ComboBox1.Items[0] = 'BUY' And ComboBox1.Items[1] = 'SELL' ************************************************************)} Var. I: Integer; Begin. AList.Clear; With GetTypeData(pti)^ do. For I := MinValue to MaxValue do. AList.Add(Copy(GetEnumName(pti, I), X + 1, 255)); End;

Каковы текущие ограничения BDE?

Основные ограничения BDE:

48 клиентов в системе;

32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit).

256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit).

32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit).

2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit).

32 загруженных драйвера.

64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit).

12288 сессии в системе (для версии 4.0 и выше, 32 Bit).

4000 курсоров на сессию.

16 вхождений в стеке ошибок.

8 типов таблиц на один драйвер.

16 типов полей на один драйвер.

8 типов индексов на один драйвер.

48K Размер конфигурационного файла (IDAPI.CFG).

64K Максимальный размер оператора SQL при RequestLive=False.

4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit).

6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit).

16K Размер буфера записи (SQL и ODBC).

31 Размер имени таблицы и имени поля в символах.

64 Размер имени хранимой процедуры в символах.

16 Полей в ключе.

3 Размер расширения имени файла в символах.

260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения).

260 Длина полного имени файла и пути файловой системы в символах.

Ограничения Paradox:

127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit).

254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit).

64 блокировки на запись на одну таблицу (16Bit) на одну сессию.

255 блокировок на запись на одну таблицу (32Bit) на одну сессию.

255 записей, учавствующих в транзакции на таблицу (32 Bit).

512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit).

1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit).

300 пользователей в одном файле PDOXUSRS.NET.

255 полей в таблице.

255 размер символьных полей.

2 миллиарда записей в таблице.

2 миллиарда байт в .DB (таблица) файле.

10800 байт на запись для индексированных таблиц.

32750 байт на запись для неиндексированных таблиц.

127 вторичных индексов на таблицу.

16 полей на индекс.

255 одновременно работающих пользователей на таблицу.

256 Мегабайт данных на одно BLOb поле.

100 паролей на сессию.

15 длина пароля.

63 паролей на таблицу.

159 полей с проверками корректности (validity check) (32 Bit).

63 поля с проверками корректности (validity check) (16 Bit).

Ограничения dBase:

256 открытых таблиц dBASE на систему (16 Bit).

350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit).

512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit).

100 блокировок на запись на одной таблице dBASE (16 and 32 Bit).

100 записей, учавствующих в транзакции на таблицу (32 Bit).

1 миллиард записей в таблице.

2 миллиарда байт в файле .DBF (таблица).

4000 Размер записи в байтах (dBASE 4).

32767 Размер записи в байтах (dBASE for Windows).

255 Количество полей в таблице (dBASE 4).

1024 Количество полей в таблице (dBASE for Windows).

47 Количество тэгов индексов на один .MDX-файл.

254 Размер символьных полей.

10 открытых основных индексов (.MDX) на таблицу.

220 Длина ключевого выражения в символах.

Взято из Akzhan's Database Delphi.

©Drkb::02500.

1. Управление Word-ом из Delphi.

(опубликовано - 13 SoftWare).

Здесь мы рассмотрим пример того, как управлять объектами Word-а (Excel - аналогично) из программ на Delphi. Исходный код примера можно скачать на страничке 'DownLoad'

А). Для чего это нужно ?

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

Б). Подготовительные работы. На самом деле существует несколько способов сделать это, мы рассмотрим только один (пример кроме Delphi 5, в Delphi5 для этого есть компоненты на закладке Servers переименуете в программе типы на соответствующие компоненты, дальше так же).

Для начала начнем новый проект File, New Application; File, Save All. Создадим отдельную папку для проекта и сохраним Unit1 как Main, а Project1 как WordWriter.

Далее для работы с Word-ом нам потребуется библиотека типов Word-а, это делается так:

Project, Import Type Library, Add, далее переходим в папку, где стоит Word ( у меня это - "c:\program files\microsoft office) , заходим в папку Office и выбираем файл - msword8.olb (цифра -? версии Word-а - у Вас может отличаться ) или excel8.olb (для Excel).Нажимаем Ок. Delphi создаст 2 файла - Word_tlb.pas и Office_tlb.pas, их надо включить в раздел uses модуля Main нашего проекта:

Code: Uses ... ,Office_Tlb, word_tlb;

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

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

Code: Const. Gfsr_SystemResources = 0; Gfsr_GdiResources = 1; Gfsr_UserResources = 2; Var. HInst16: THandle; GFSR: Pointer; { Undocumented Kernel32 calls. }. Function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35; Procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36; Function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37; Procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk'; { QT_Thunk needs a stack frame. }. {$StackFrames On}. { Thunking call to 16-bit USER.EXE. The ThunkTrash argument. Allocates space on the stack for QT_Thunk. }. Function NewGetFreeSystemResources(SysResource: Word): Word; Var. ThunkTrash: array[0..$20] of Word; Begin. { Prevent the optimizer from getting rid of ThunkTrash. }. ThunkTrash[0] := hInst16; HInst16 := LoadLibrary16('user.exe'); If hInst16 < 32 then. Raise Exception.Create('Cannot load USER.EXE!'); { Decrement the usage count. This doesn't really free the. Library, since USER.EXE is always loaded. }. FreeLibrary16(hInst16); { Get the function pointer for the 16-bit function in USER.EXE. }. GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources'); If GFSR = nil then. Raise Exception.Create('Cannot get address of GetFreeSystemResources!'); { Thunk down to USER.EXE. }. Asm. Push SysResource { push arguments }. Mov edx, GFSR { load 16-bit procedure pointer }. Call QT_Thunk { call thunk }. Mov Result, ax { save the result }. End; End;

Delphi Run-Time Error Codes.

Delphi's online help documentation seems to miss the run-time error codes. I usually looked them up in my old Borland Pascal for Windows help file - now they are here for fast access:

1 Invalid function number.

2 File not found.

3 Path not found.

4 Too many open files.

5 File access denied.

6 Invalid file handle.

12 Invalid file access code.

15 Invalid drive number.

16 Cannot remove current directory.

17 Cannot rename across drives.

100 Disk read error.

101 Disk write error.

102 File not assigned.

103 File not open.

104 File not open for input.

105 File not open for output.

106 Invalid numeric format.

200 Division by zero.

201 Range check error.

202 Stack overflow error.

203 Heap overflow error.

204 Invalid pointer operation.

205 Floating point overflow.

206 Floating point underflow.

207 Invalid floating point operation.

210 Object not initialized.

211 Call to abstract method.

212 Stream registration error.

213 Collection index out of range.

214 Collection overflow error.

215 Arithmetic overflow error.

216 General protection fault.

©Drkb::00013.

Взято с сайта http://www.delphifaq.com.

Типы файлов в среде Дельфи.

DPR - Delphi Project File. This is actually a Pascal source file; it just happens to be the main program for the application.

PAS - In Delphi, PAS files are always the source code to either a unit or a form. The main program of an application is in the DPR file.

DFM - These files are always paired with PAS files. The DFM file is the binary data used to set up initial data for components (IE, the properties you set in design mode rather than in code). You can't edit a DFM file with a text editor, but if you open it in Delphi, you will see a textual version of the contents.

DCU - A compiled unit, similar in concept to an OBJ file.

OPT - Project Options; i.e. compiler and linker settings, which form is the main form, what icon to use for the application, etc. Generally, the stuff you edit under Options/Project.

RES - A Windows resource file; generated automatically by Delphi and required by the compilation process. You don't need to worry about this file, but don't delete it either.

EXE - All of the above linked together into runnable format.

~DP - A backup file of the DPR file before the last save operation.

~PA - A backup of a .PAS file.

~DF - A backup of a .DFM file.

©Drkb::00047.

Взято с сайта http://www.delphifaq.com.

Формат .CAB-файлов.

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

Формат .LIC-файлов.

В действительности, как такового, формата .lic-файла не существует. Обычно это такие же текстовые файлы, содержащие одну или две ключевых строки.

Формат .INF-файлов.

Все inf-файлы состоят из секций и пунктов. Каждая именованная секция содержит соответствующие пункты. Все inf-файлы начинаются с заголовочной секции. После заголовка включенные секции могут располагаться в любом порядке. Каждый заголовок представляет собой строку с [Именем Заголовка]. Далее следуют пункты: ItemA = ItemDetail. Для получения дополнительной информации обратитесь к документу "Device Information File Reference".

Формат .dpr-файлов.

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

Формат .pas-файлов.

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

Формат .dfm-файлов.

Данный файл содержит описание объектов, расположенных на форме. Содержимое файла можно увидеть в виде текста, вызвав правой кнопкой мыши контекстное меню и выбрав пункт "view as text", или же с помощью конвертера convert.exe (расположенного в каталоге bin), также позволяющего перевести файл в текстовый вид и обратно. Данный файл нужно редактировать очень осторожно, поскольку это может закончиться тем, что IDE не сможет загрузить форму. Этот файл является критическим при перемещении и пересборке проекта.

Формат .DOF-файлов.

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

Формат .DSK-файлов.

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

Формат .DPK-файлов.

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

Формат .DCP-файлов.

Данный бинарный image-файл состоит фактически из реально скомпилированного пакета. Информация о символах и дополнительных заголовках, требуемых IDE, полностью содержится в .DCP-файле. Чтобы собрать (build) проект, IDE должен иметь доступ к этому файлу.

Формат .DPL-файла.

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

Формат .DCI-файла.

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

Формат .DCT-файла.

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

Формат .TLB-файла.

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

Формат .DRO-файла.

Данный текстовый файл содержит информацию об объектном хранилище. Каждый пункт данного файла содержит специфическую информацию о каждом доступном элементе в хранилище объектов. Хотя этот файл и является простым текстовым файлом, мы настоятельно не рекомендуем править его вручную. Хранилище может редактироваться только с помощью меню Tools|Repository в самом IDE.

Формат .RES-файла.

Это стандартный двоичный windows-формата файл ресурсов, включающий в себя информацию о приложении. По умолчанию, Delphi создает новый .RES-файл при каждой компиляции проекта в исполняемое приложение.

Формат .DB-файла.

Файлы с таким расширением - стандартные файлы Paradox.

Формат .DBF-файла.

Файлы с таким расширением - стандартные dBASE-файлы.

Формат .GDB-файла.

Файлы с таким расширением - стандартные Interbase-файлы.

Формат .DMT-файла.

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

Формат .DBI-файла.

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

Формат .DEM-файла.

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

Формат .OCX-файла.

.OCX-файл является специализированной DLL, которая содержит все или несколько функций, связанных с элементом управления ActiveX. Файл OCX задумывался как "обертка", которая содержала бы сам объект, и средства для связи с другими объектами и серверами.

©Drkb::00048.

Взято с http://delphiworld.narod.ru.

Как заставить стартовать дельфи без заставки?

Командной строкой:

Delphi32.EXE -ns.

©Drkb::00049.

Взято с сайта http://www.delphifaq.com.

Создание pop-up меню своего компонента и кое-что еще о классе TComponentExpert.

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

Как мне избавиться от выскакивающего окна CPU при ошибках?

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Debugging.

ViewCPUOnException=0.

©Drkb::00014.

Взято с сайта http://www.delphifaq.com.

Как заставить стартовать дельфи без проекта?

Командной строкой:

Delphi32.exe -np.

©Drkb::00050.

Взято с сайта http://www.delphifaq.com.

Список префиксов Internal Error.

Иногда выскакивают ошибки типа "Internal Error SY424", вот расшифровка префиксов:

B : debugger.

BC : debugger.

BR : browser.

C : codegen.

CM : command line version of the compiler.

D : parser.

DB : debugger.

DBG: debug info output.

DM : IDE version of the compiler.

E : parser.

EO : debugger/evaluator.

FN : filename / pathname parsing.

GH : HPP generator.

I : code generator.

IN : inspectors.

L : linker.

LI : BPI file writing.

LO : object file loading.

M : memory allocation.

MA : name mangling.

MB : multi-byte (MBCS) support.

O : object (OMF) file handling.

P : package managment.

R : resource writing.

S : scanner.

ST : standard procedure handling.

SY : symbol table.

T : code generator.

TI : RTTI generator.

U : parser.

UD : IDE version of the compiler.

UI : error handling.

URW: DCU reading/writing.

W : Object file (OMF) writing.

X : code generator.

©Drkb::00019.

Взято с сайта http://www.delphifaq.com.

Надеюсь, многие сталкивались с Corel Draw? А у многих слюнки текли, что это мощнейший графический редактор и хотелось бы под него свои программы писать, к примеру, чертежи выводить? Я один из вас :).

Формат файлов *.cdr конечно, не представлю, т.к. сам его не знаю :), но как с этим зверем работать расскажу. Вычитал, что с Corel Draw можно работать только через скрипт, причем изначально я готовил файлы скриптов *.csc, а затем их запускал в самом редакторе. Рабочий инструмент для освоения - Corel Script Editor. Если Вы хотите действительно что-то написать, то он вам просто необходим, хотя бы ради того, что смотреть как Corel Draw их сам создает, ну и самое главное - дока по языку и функциям. Все замечательно, только вот скрипты медленно работают т.к. они эмитируют работу человека - т.е. кнопочки сами нажимаются, панельки меняются и т.д.

А чертеж, к примеру на котором около 3000 объектов мог загружаться и исполнятся до часу! Нет, когда это утомляет, то можно и самому посидеть - глядишь за неделю сделаешь :).

И тут я "чисто случайно" наткнулся на статейку http://www.djpate.freeserve.co.uk/AutoCDrw.htm. Оказывается можно и через OLE этот Corel Draw дергать, и как оказывается, не так уж оно и сложно. Да, совершенно верно, нужно использовать CorelDraw.Automation.xx. Я возился с 8-й версией. Забегая на перед, скажу, что тот же чертеж выводился в течении 5-10 минут.

Ну что, начнем?

Code: Var. CorelDraw: Variant; … CorelDraw := CreateOleObject('CorelDraw.Automation.8'); // цифирку можете свою поставить. CorelDraw.FileNew; // или CorelDraw.FileOpen(FileName); CorelDraw.SetDocVisible(True); // можно и не показывать, что он там делает, но ведь интересно! :). // кстати, можно нарисовать, а потом показать - будет на 30% быстрее. ... // ну и в конце. CorelDraw.FileSave('NewName', 0, False, 0, False); CorelDraw.FileExit(False); // можно не писать, если не надо закрывать. CorelDraw := Unassigned;

Проблема использования компонентов в D6/7 от предыдущих версий.

Решение в случае ошибок компиляции пакетов типа: Missing unit 'Proxies.pas' и Missing DsgnIntf.pas.

1) Сначала заменить.

Uses DsgnIntf;

На.

Uses DesignIntf, DesignEditors;

2) Затем.

Добавить DesignIde.dcp в лист требуемых модулей.

©Drkb::00057.

Взято с сайта http://www.delphifaq.com.

Переименование модулей не решит проблемы 'Proxies.pas' Эта проблема возкает из-за того, что сами компоненты и редакторы свойств помещают в один пакет. Это нехорошо, но в D5 и ниже проходило, а начиная с D6 уже не проходит. Пакет разбиваете на два: run-time и design-time. RT-пакет содержит ТОЛЬКО код самих компонентов и больше НИЧЕГО. Ни один его модуль не должен ссылаться в uses ни на один модуль DT-пакета. В его секции Requires могут содержаться ТОЛЬКО run-time модули VCL. Компилируется RT-пакет в любой каталог, доступный через пути поиска IDE, либо через переменную системного окружения Path. Инсталлировать в IDE его не нужно. DT-пакет содержит процедуру Register, иконки компонентов и все design-time редакторы (свойств и компонентов), если такие есть. Любой его модуль может ссылаться в uses на любой модуль из RT-пакета. В его секцию Requires и подключается DesignIDE.dcp. Компилируется он куда угодно и должен инсталлироваться в IDE. Таким образом, в конечные приложения будут подключаться только модули RT-пакета, в которых нет ссылок на DesignEditors - а тогда не потребуется и Proxies. Кроме того, в конечный проект не будут подтягиваться ненужные в run-time код и ресурсы из DT-пакета. Отвечал Юрий Зотов

©Drkb::00058.

Автор: Simon Carter.

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

Обычно таким способом ломаются игрушки :).

Конечно данный способ не сможет полностью защитить Ваш программный продукт от взлома, но прекратить выполнение секретного кода - запросто. Для этого мы будем использовать API функцию IsDebuggerPresent. Единственный недостаток этой функции, заключается в том, что она не работет под Windows 95.

Теперь посмотрим как эту функцию реализовать в Delphi:

Code: Function DebuggerPresent: boolean; Type. TDebugProc = function: boolean; stdcall; Var. Kernel32: HMODULE; DebugProc: TDebugProc; Begin. Result := False; Kernel32 := GetModuleHandle('kernel32.dll'); If Kernel32 <> 0 then. Begin. @DebugProc := GetProcAddress(Kernel32, 'IsDebuggerPresent'); If Assigned(DebugProc) then. Result := DebugProc; End; End;

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. OldBkMode : integer; Begin. Image1.Picture.Bitmap.Canvas.Font.Color := clBlue; OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT); Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello'); SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode); End;

Как использовать клавишу-акселератор в TTabsheets?

Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.

Можно перехватить сообщение CM_DIALOGCHAR.

Code: Type. TForm1 = class(TForm). PageControl1: TPageControl; TabSheet1: TTabSheet; TabSheet2: TTabSheet; TabSheet3: TTabSheet; Private. {Private declarations}. Procedure CMDialogChar(var Msg: TCMDialogChar); Message CM_DIALOGCHAR; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.CMDialogChar(var Msg: TCMDialogChar); Var. I: integer; Begin. With PageControl1 do. Begin. If Enabled then. For i := 0 to PageControl1.PageCount - 1 do. If ((IsAccel(Msg.CharCode, Pages[i].Caption)) and. (Pages[i].TabVisible)) then. Begin. Msg.Result := 1; ActivePage := Pages[i]; Exit; End; End; Inherited; End;

©Drkb::01160.

Взято из.

DELPHI VCL FAQ Перевод с английского.

Подборку, перевод и адаптацию материала подготовил Aziz(JINX).

Специально для Королевства Дельфи.

Можно ли динамически изменять свойство owner компонента во время выполнения программы?

Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent().

©Drkb::00105.

Взято из.

DELPHI VCL FAQ Перевод с английского.

Подборку, перевод и адаптацию материала подготовил Aziz(JINX).

Специально для Королевства Дельфи.

Как определить наличие сопроцессора?

В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.

Пример:

Code: {$IFDEF WIN32}. Uses Registry; {$ENDIF}. Function HasCoProcesser : bool; {$IFDEF WIN32}. Var. TheKey : hKey; {$ENDIF}. Begin. Result := true; {$IFNDEF WIN32}. If GetWinFlags and Wf_80x87 = 0 then. Result := false; {$ELSE}. If RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0, KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false; RegCloseKey(TheKey); {$ENDIF}. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If HasCoProcesser then. ShowMessage('Has CoProcessor'). Else. ShowMessage('No CoProcessor - Windows Emulation Mode'); End;

©Drkb::01432.

Взято из.

DELPHI VCL FAQ Перевод с английского.

Подборку, перевод и адаптацию материала подготовил Aziz(JINX).

Специально для Королевства Дельфи.

Как узнать серийный номер аудио CD?

CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.

Пример:

Code: Uses MMSystem, MPlayer; Procedure TForm1.Button1Click(Sender: TObject); Var. Mp : TMediaPlayer; Msp : TMCI_INFO_PARMS; MediaString : array[0..255] of char; Ret : longint; Begin. Mp := TMediaPlayer.Create(nil); Mp.Visible := false; Mp.Parent := Application.MainForm; Mp.Shareable := true; Mp.DeviceType := dtCDAudio; Mp.FileName := 'D:'; Mp.Open; Application.ProcessMessages; FillChar(MediaString, sizeof(MediaString), #0); FillChar(msp, sizeof(msp), #0); Msp.lpstrReturn := @MediaString; Msp.dwRetSize := 255; Ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, Longint(@msp)); If Ret <> 0 then. Begin. MciGetErrorString(ret, @MediaString, sizeof(MediaString)); Memo1.Lines.Add(StrPas(MediaString)); End. Else. Memo1.Lines.Add(StrPas(MediaString)); Mp.Close; Application.ProcessMessages; Mp.free; End; End.

©Drkb::01401.

Взято из.

DELPHI VCL FAQ Перевод с английского.

Подборку, перевод и адаптацию материала подготовил Aziz(JINX).

Специально для Королевства Дельфи.

Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-RОМ'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.

Пример:

Code: Function IsAudioCD(Drive : char) : bool; Var. DrivePath : string; MaximumComponentLength : DWORD; FileSystemFlags : DWORD; VolumeName : string; Begin. Sult := false; DrivePath := Drive + ':\'; If GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then. Exit; SetLength(VolumeName, 64); GetVolumeInformation(PChar(DrivePath),PChar(VolumeName), Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0); If lStrCmp(PChar(VolumeName),'Audio CD') = 0 then. Result := true; End; Function PlayAudioCD(Drive : char) : bool; Var. Mp : TMediaPlayer; Begin. Result := false; Application.ProcessMessages; If not IsAudioCD(Drive) then. Exit; Mp := TMediaPlayer.Create(nil); Mp.Visible := false; Mp.Parent := Application.MainForm; Mp.Shareable := true; Mp.DeviceType := dtCDAudio; Mp.FileName := Drive + ':'; Mp.Shareable := true; Mp.Open; Application.ProcessMessages; Mp.Play; Application.ProcessMessages; Mp.Close; Application.ProcessMessages; Mp.free; Result := true; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If not PlayAudioCD('D') then. ShowMessage('Not an Audio CD'); End;

Code: Uses Registry; Procedure TForm1.Button1Click(Sender: TObject); Var. Reg: TRegistry; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false); ShowMessage(reg.ReadString('SourcePath')); Reg.CloseKey; Reg.free; End;

Декомпиляция в Delphi.

(перевод одноимённой статьи с delphi.about.com ).

Читая форумы по программированию, иногда натыкаешься на вопрос типа: "У меня есть откомпилированная программа на Delphi. Как мне получить её исходный код?". Обычно такой вопрос возникает, когда программист потерял файлы проекта и у него остался только .exe. Как правило полностью восстановить исходный код на языке высокого уровня невозможно. Значит ли это, что другие тоже не смогут восстановить исходный код Вашей программы ? Хм ... и да и нет ...

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

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

Когда же применяется декомпиляция ? Для этого существует довольно много причин. Вот некторые из них:

- Восстановление исходного кода;

- Перенос приложения на другую платформу;

- Определение наличия вирусов в коде программы или вредоносного кода;

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

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

На данный момент Borland не предоставляет никаких программных продуктов, способных декомпилировать исполняемые файлы (.exe) либо откомпилированные Delphi-модули (.dcu) в исходный код (.pas).

Если же Вы всё-таки решились попробовать декомпилировать исполняемый файл, то необходимо знать следующие вещи. Исходные коды на Delphi обычно хранятся в файлах двух типов: сам исходник в ASCII кодировке (.pas, .dpr) и файлы ресурсов (.res, .rc, .dfm, .dcr). Dfm файлы хранят в себе свойства объектов, содержащихся в форме. При создании конечного .exe, Delphi копирует в него информацию из .dfm файлов. Каждый раз, когда мы изменяем координаты формы, описания кнопок или связанные с ними события, то Delphi записывает эти изменения в .dfm (за исключением кода процедур. Он сохраняется в файлах pas/dcu ). И наконец, чтобы получить при декомпиляции файл .dfm, нужно знать - какие типы ресурсов хранятся внутри Win32 исполняемого модуля.

Все программы, скомпилированные в Delphi имеют следующие секции: CODE, DATA, BSS, .idata, tls, .rdata, .rsrc. Самые важные для декомпиляции секции CODE и .rsrc. В статье "Adding functionality to a Delphi program" приведены некоторые интересные факты о исполняемых форматах Delphi, а так же информация о классах и DFM ресурсах. В этой статье есть один интересный момент под заголовком: "Как добавить свой обработчик события в уже откомпилированный файл, например, чтобы изменять тект на кнопке".

Среди многих типов ресурсов, которые сохранены в .exe файле, интерес представляет RT_RCDATA, который хранит информацию, которая были в DFM файле перед трансляцией. Чтобы извлеч DFM данные из .exe файла, мы можем вызываться API функцией EnumResourceNames.

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

И в заключение, если Вы заинтересовались декомпилованием, то предлагаю Вам несколько Delphi декомпиляторов:

DeDe.

DeDe довольно шустрая программка, позволяющая анализировать экзешники, скомпилированные в Delphi. После декомпиляции DeDe даёт Вам следующее:

- Все dfm файлы. Вы сможете открывать их и редактировать в Delphi.

- Все объявленные методы с хорошо комментированным кодом на ассемблере с ссылками на строки, импортированных функций, методов и компонент в юните, блоки Try-Except и Try-Finally.

- Большое количество дополнительной информации.

- Вы можете создать папку Delphi проекта со всеми файлами dfm, pas, dpr. Не забудьте, что pas файлы содержат ассемблерный код.

Revendepro.

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

MRIP.

Позволяет извлекать из Delphi приложения любые ресурсы: курсоры, иконки, dfm файлы, pas файлы и т.д. Но главная его особенность - это способность извлекать файлы, хранящиеся в других файлах. Поддерживается более 100 форматов файлов. MRip работает под DOS.

Exe2Dpr.

Эта программа может восстановить частично потерянные исходники проекта. Не имеет интерфейса и работает с командной строки, например: 'exe2dpr [-o] exeFile' ( исходники проекта будут созданы в текущей директории).

©Drkb::04511.

Взято из http://forum.sources.ru.

Как сделать меню как в Дельфи?

1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.

2. Разместите TToolBar (закладка Win32) внутри TControlBar.

3. Установите в True свойства Flat и ShowCaptions этого TToolBar.

4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar.

Правой кнопкой и выбрав NewButton).

5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать.

При перемещении курсора между главными пунктами меню (если меню уже показано).

6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной.

Формы. (посмотрите свойство Menu формы).

7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer).

8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.

©Drkb::01303.

Взято из.

DELPHI VCL FAQ Перевод с английского.

Подборку, перевод и адаптацию материала подготовил Aziz(JINX).

Специально для Королевства Дельфи.

В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости,

Так как обьект класса TPrinter (называемый Printer) автоматически создается при.

Использовании модуля Printers.

Пример:

Code: Uses Printers; Procedure TForm1.Button1Click(Sender: TObject); Begin. Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Hello World!'); Printer.EndDoc; End;

Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите.

WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей.

Неклиенстской области окна (рамка и заголовок).

Пример:

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Private. {Private declarations}. Procedure WMNCMOUSEMOVE(var Message: TMessage); Message WM_NCMOUSEMOVE; Public. {Public declarations}. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage); Var. S : string; Begin. Case Message.wParam of. HTERROR: S:= 'HTERROR'; HTTRANSPARENT: S:= 'HTTRANSPARENT'; HTNOWHERE: S:= 'HTNOWHERE'; HTCLIENT: S:= 'HTCLIENT'; HTCAPTION: S:= 'HTCAPTION'; HTSYSMENU: S:= 'HTSYSMENU'; HTSIZE: S:= 'HTSIZE'; HTMENU: S:= 'HTMENU'; HTHSCROLL: S:= 'HTHSCROLL'; HTVSCROLL: S:= 'HTVSCROLL'; HTMINBUTTON: S:= 'HTMINBUTTON'; HTMAXBUTTON: S:= 'HTMAXBUTTON'; HTLEFT: S:= 'HTLEFT'; HTRIGHT: S:= 'HTRIGHT'; HTTOP: S := 'HTTOP'; HTTOPLEFT: S:= 'HTTOPLEFT'; HTTOPRIGHT: S:= 'HTTOPRIGHT'; HTBOTTOM: S:= 'HTBOTTOM'; HTBOTTOMLEFT: S:= 'HTBOTTOMLEFT'; HTBOTTOMRIGHT: S:= 'HTBOTTOMRIGHT'; HTBORDER: S:= 'HTBORDER'; HTOBJECT: S:= 'HTOBJECT'; HTCLOSE: S:= 'HTCLOSE'; HTHELP: S:= 'HTHELP'; Else s:= ''; End; Form1.Caption := s; Message.Result := 0; End; End.

Kylix Tutorial. Часть 1. Установка.

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

Беглое изучение их показало, что один содержит непосредственно Kylix, а второй дополнительные компоненты и утилиты третьих фирм и Interbase 6. По хорошей традиции пиратами была слита самая "продвинутая" версия Kylix Server Developer.

Ставить Kylix я пробовал под RedHat Linux 7.0.

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

А) Компьютер с установленной ОС Linux.

Б) В составе Linux должны быть установлены графические оболочки GNOME и / или KDE (возможно Kylix будет работать и с другими, но эти две наиболее распространенны и Borland гарантирует работу под ними). Лично я пользуюсь KDE, посему про нее и буду рассказывать.

В) Права пользователя root.

Первым делом необходимо установить патч на библиотеку glibc, по каким-то причинам не устроившую фирму Borland. Для этого и необходимо иметь права root. Заплатки (patches) сложены в директории /patches CD-ROM. Для Redhat 7.0 необходимо перейти в директорию <путь к CD>/patches/glibc_redhat/7.0. Установка патчей выполняется командами.

Rpm -Uvh glibc-[2c]*

Rpm -Fvh glibc-[dp]* nscd-*

Возможно также Вам придется установить пакет libjpeg либо из дистрибутива RedHat либо из папки <путь к CD>/patches/jpeg6.2.0.

Далее установка может проводиться как под аккаунтом root, так и под простым пользователем. Для инсталляции необходимо запустить на выполнение скрипт setup.sh. из корня CD.Графическая оболочка установки сделана удобно и интуитивно понятна. По умолчанию установка предлагается в домашнюю директорию пользователя, однако, чтобы при наличии нескольких пользователей лучше устанавливать в /usr/kylix, чтобы Kylix был доступен всем.

После установки запуск IDE Kylix можно выполнить.

1) из командной строки: <путь инсталляции>/bin/stаrtкуliх.

2) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню Borland Kylix/Kylix.

3) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню /RedHat/ Borland Kylix/Kylix.

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

1. Прописать пути к библиотекам. В файле .bash_profile в строку PATH добавить путь к директории bin Kylix-а. Например, если он установлен в /usr/kylix - то добавить надо путь /usr/kylix/bin.

2. В файл /etc/ld.so.conf добавить строчку с путем к libqtintf.so (в нашем примере /usr/kylix/bin).

3. запустить ldconfig.

Автор: Mike Goblin.

Взято с сайта http://www.delphimaster.ru/

С разрешения автора.

Иногда, особенно при создании компонент, бывает необходимо получить доступ к компоненту только когда запущена Delphi IDE.

Code: If FindWindow('TAppBuilder',nil) <= 0 then. ShowMessage('Delphi is not running !'). Else. ShowWindow('Delphi is running !');

Как включить/выключить спикер?

Это выключит спикер:

SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:

SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

Alexey Lesovik.

(2:5020/898.15).

Взято из FAQ:

Delphi and Windows API Tips'n'Tricks.

Olmal@mail.ru.

Http://www.chat.ru/~olmal.

©Drkb::02259.

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

Code: Unit ClipStrm; { This unit is Copyright (c) Alexey Mahotkin 1997-1998. And may be used freely for any purpose. Please mail. Your comments to. E-Mail: alexm@hsys.msk.ru. FidoNet: Alexey Mahotkin, 2:5020/433. This unit was developed during incorporating of TP Lex/Yacc. Into my project. Please visit ftp://ftp.nf.ru/pub/alexm. Or FREQ FILES from 2:5020/433 or mail me to get hacked. Version of TP Lex/Yacc which works under Delphi 2.0+. } Interface uses Classes, Windows; Type. TClipboardStream = class(TStream). Private. FMemory : pointer; FSize : longint; FPosition : longint; FFormat : word; Public. Constructor Create(fmt : word); Destructor Destroy; override; Function Read(var Buffer; Count : Longint) : Longint; override; Function Write(const Buffer; Count : Longint) : Longint; override; Function Seek(Offset : Longint; Origin : Word) : Longint; override; End; Implementation uses SysUtils; Constructor TClipboardStream.Create(fmt : word); Var. Tmp : pointer; FHandle : THandle; Begin. FFormat := fmt; OpenClipboard(0); FHandle := GetClipboardData(FFormat); FSize := GlobalSize(FHandle); FMemory := AllocMem(FSize); Tmp := GlobalLock(FHandle); MoveMemory(FMemory, tmp, FSize); GlobalUnlock(FHandle); FPosition := 0; CloseClipboard; End; Destructor TClipboardStream.Destroy; Begin. FreeMem(FMemory); End; Function TClipboardStream.Read(var Buffer; Count : longint) : longint; Begin. If FPosition + Count > FSize then. Result := FSize - FPosition. Else. Result := Count; MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result); Inc(FPosition, Result); End; Function TClipboardStream.Write(const Buffer; Count : longint) : longint; Var. FHandle : HGlobal; Tmp : pointer; Begin. ReallocMem(FMemory, FPosition + Count); MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count); FPosition := FPosition + Count; FSize := FPosition; FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize); Try. Tmp := GlobalLock(FHandle); Try. MoveMemory(tmp, FMemory, FSize); OpenClipboard(0); SetClipboardData(FFormat, FHandle); Finally. GlobalUnlock(FHandle); End; CloseClipboard; Except. GlobalFree(FHandle); End; Result := Count; End; Function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint; Begin. Case Origin of. 0 : FPosition := Offset; 1 : Inc(FPosition, Offset); 2 : FPosition := FSize + Offset; End; Result := FPosition; End; End.

Автор: Diego Jones.

Совместимость: Delphi 4.x (или выше).

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

Но сначала обратимся к основам типов данных, используемых в Delphi, и детально рассмотрим - сколько байт памяти занимает каждый тип данных:

· boolean, char and byte = 1 байт

· smallInt, word, wordbool = 2 байт

· string, pointers, longint, integer = 4 байт

Теперь давайте посмотрим на объявление класса в нашем исходном коде:

Code: TMyClass = class. Private. Field1: char; Field2: longint; Field3: boolean; Field4: string; Field5: byte; Field6: integer; Public. Procedure proc1; End;

Свойства.

Фирма Borland в Kylix и Delphi 6 реализовала новый движок для работы с базой данных dbExpress. Данный движок предназначен для работы с серверными БД. На сегодняшний день поддерживаются MySQL, Oracle, Interbase, DB2. К сожалению, на момент выпуска Kylix он работал не со всеми версиями MySQL. В частности, он не заработал с MySQL 3.23.22-beta. За неимением Oracle и DB2 я пользовался Interbase 6, находившемся на втором диске дистрибутива.

Архитектура доступа к данным.

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

Ничего принципиально нового здесь нет, по сравнению с Delphi. Но это только на первый взгляд. В dbExpress датасеты делятся на два вида:

1. Клиентский датасет (client dataset).

2. Однонаправленные датасеты (unidirectional dataset).

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

Однонаправленные запросы не кешируют данные. Передвигаться по ним можно только в направлении указанном в конструкции ORDER BY SQL запроса, данные не могут быть изменены. Однако они предоставляют быстрый доступ к большим массивам записей.

Компоненты закладки dbExpress.

Посмотрим, что приготовила нам фирма Borland по части компонентов на закладке dbExpress.