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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



DBGrid c FixedCols



Автор: Cheers

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

Кам мне при прокрутке "зафиксировать" левое поле табличной сетки?

Я делаю это таким образом:


 unit Fcdgrid;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Grids, DBGrids, DBCtrls, DB, Menus;
 
 type
   TFixedColDBGrid = class(TDBGrid)
   private
     FUserFixedCols: Integer;
   protected
     procedure LayoutChanged; override;
     procedure SetUserFixedCols(I: Integer);
 
   published
     property UserFixedCols: Integer read FUserFixedCols write SetUserFixedCols;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Data Controls', [TFixedColDBGrid]);
 end;
 
 procedure TFixedColDBGrid.LayoutChanged;
 begin
   inherited LayoutChanged; {   присваиваем FixedCols 1 если индикатор, иначе 0 }
   if ((inherited FixedCols + FUserFixedCols) < inherited ColCount) then
     inherited FixedCols := (FUserFixedCols + inherited FixedCols);
 end;
 
 procedure TFixedColDBGrid.SetUserFixedCols(I: Integer);
 begin
   FUserFixedCols := I;
   LayoutChanged;
 end;
 
 end.
 




DBGrid с номером строки

Автор: Mark Meyer

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

Скомпилируйте это, и вы получите новый компонент с нужными свойствами:


 unit RowGrid;
 
 interface
 
 uses
   WinTypes, WinProcs, Classes, Grids, DBGrids;
 
 type
   TRowDBGrid = class(TDBGrid)
   public
     property Row;
     property RowCount;
     property VisibleRowCount;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Data Controls', [TRowDBGrid]);
 end;
 
 end.
 


 {вот небольшой испытательный демо-проект.. мы
 поместили на форму нашу сетку-наследницу, 3 компонента
 EditBox и поместили следующий код в обработчик события
 ondrawdatacell вашего TRowGrid}
 procedure TForm1.RowDBGrid1DrawDataCell(Sender: TObject; const Rect:
   TRect; Field: TField; State: TGridDrawState);
 begin
   eb_row.text := inttostr(rowdbgrid1.row);
   eb_rowcount.text := inttostr(rowdbgrid1.rowcount);
   eb_visiblerowcount.text := inttostr(rowdbgrid1.visiblerowcount);
 end;
 




Синтаксис функции DbiAddAlias

DbiAddAlias (пропущено в BDE.HLP & Руководстве пользователя)

Синтаксис:

   DBIResult DbiAddAlias( [hCfg], pszAliasName, pszDriverType, pszParams, bPersistent );
Описание:
   DbiAddAlias добавляет псевдоним в конфигурационный файл, связанный с
    текущим сеансом.
Параметры:
   hCfg              Type: hDBICfg              (Входящий)
       Для BDE 2.5 данный параметр должен быть NULL. Указывает, что
       конфигурация действует в течение текущего сеанса.
       Другие значения для BDE 2.5 не поддерживаются.
 
    pszAliasName      Type: pCHAR                (Входящий)
       Указатель на имя псевдонима. Это имя нового псевдонима, который
       должен быть добавлен.
 
    pszDriverType     Type: pCHAR                (Входящий)
       Указатель на тип устройства. Это тип устройства для добавляемого
       псевдонима. Если данный параметр NULL, псевдоним будет добавлен
       для базы данных STANDARD. Если указан szPARADOX, szDBASE или szASCII,
       будет добавлена запись в генератор псевдонимов базы данных STANDARD
       для указания того, что данный тип будет предпочтительным типом
       устройства. Если указано имя устройства, то оно должно существовать
       в измененном файле конфигурации.
 
    pszParams         Type: pCHAR                (Входящий)
       Указатель на список дополнительных параметров. Данный список
       определяется следующим образом:
       "AliasOption: Option Data[;AliasOption: Option Data][;...]".
       AliasOption должен соответствовать одному из значений, возвращаемому
       DbiOpenCfgInfoList. Для псевдонимов базы данных STANDARD, единственно
       необходимый параметр - PATH, остальные игнорируются (без ошибок).
 
       Пример 1: Чтобы установить путь для использования базы данных
         STANDARD:
          "PATH:c:\mydata"
 
       Пример 2: Чтобы установить имя сервера и имя пользователя для
         использования драйвера SQL:
          "SERVER NAME: server:/path/database;USER NAME: myname"
 
    bPersistent       Type: BOOL                 (Входящий)
       Определяет область действия нового псевдонима.
          TRUE     Сохраняется в файле конфигурации для будующих сеансов.
          FALSE    Для использования только в течение текущего сеанса.
                   Псевдоним удаляется в конце сеанса (или при выходе из
                   программы).
 
 Использование:
    Созданный данной функцией псевдоним будет иметь параметры по умолчанию,
    хранимые в списке параметров драйверов "DB OPEN", если только оне не
    перекрыты в параметре pszParams. Вы можете использовать
    DbiOpenCfgInfoList, чтобы изменить значение по умолчанию после добавления
    псевдонима с помощью DbiAddAlias.
 
    Для псевдонимов стандартной базы данных все параметры pszParams за
    исключением PATH игнорируются.
 
 
 Предварительные условия:
    DbiInit должен вызываться до вызова DbiAddAlias.
 
 Возвращаемые значения DBIResult:
    DBIERR_INVALIDPARAM
       Имя псевдонима Null или один из следующих типов pszDriverType:
       szASCII, szDBASE, szPARADOX. В последнем случае используйте
       NULL pszDriverType для указания на базу данных STANDARD.
 
    DBIERR_NONE
       Псевдоним был успешно добавлен.
 
    DBIERR_NAMENOTUNIQUE
       Существует другой псевдоним с тем же именем (работает
       когда bPersistent равен TRUE).
 
    DBIERR_OBJNOTFOUND
       Один (или более) из дополнительных параметров, указанных в
       pszParams не соответствуют правильным типам в секции драйверов
       конфигурационного файла.
 
    DBIERR_UNKNOWNDRIVER
       Имя устройства в конфигурационном файле при сопоставлении с
       pszDriverType не найдено.
 
 Смотри также:
    DbiInit, DbiOpenCfgInfoList



Пример DbiAddFilter

Автор: Mark Erbaugh


 type
   TmyFilter = record
     Expr: CANExpr;
     Nodes: array[0..2] of CANNode;
     literals: array[0..7] of char;
   end;
 
 const
   myFilter: TMyFilter = (Expr:
     (iVer: 1; iTotalSize: sizeof(TMyFilter); iNodes: 3;
     iNodeStart: sizeof(CANExpr); iLiteralStart: sizeof(CANExpr) +
     3 * sizeof(CANNode));
     Nodes:
     ((canBinary: (nodeClass: nodeBinary; canOP: canEQ;
     iOperand1: sizeof(CANNode); iOperand2: 2 * sizeof(CANNode))),
     (canField: (nodeClass: nodeField; canOP: canField2;
     iFieldNum: 0; iNameOffset: 0)),
     (canConst: (nodeClass: nodeConst; canOP: canCONST2;
     iType: fldZSTRING; iSize: 3; iOffset: 5)));
     literals:
     ('T', 'Y', 'P', 'E', #0, 'I', 'N', #0));
 
 var
   dbResult: DBIResult;
   hFilter, hFilter1: hDBIFilter;
 begin (* procedure SetupFilter *)
   dbResult := DbiAddFilter(tblAP_.Handle, 1, 1,
     False, addr(myFilter), nil, hFilter);
   dbResult := DbiActivateFilter(tblAP_.Handle, hFilter);
   tblAP_.First;
   myFilter.nodes[0].canBinary.canOp := canNE;
   dbResult := DbiAddFilter(tblAP1_.Handle, 1, 1,
     False, addr(myFilter), nil, hFilter1);
   dbResult := DbiActivateFilter(tblAP1_.Handle, hFilter1);
   tblAP1_.First;
   myFilter.nodes[0].canBinary.canOp := canEQ;
 end;
 

Этот пример устанавливает два фильтра. Первый (применяемый к tblAP_) выводит все записи, где ТИП поля имеет значение 'IN'. Второй (применяемый к tblAP1_) выводит все записи, где ТИП поля не имеет значения 'IN'.

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




Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE


Общеизвестно, что люди на Земле делятся на ноpмальнах и тех кто занимается компьтеpами. Пpичем пеpвых с каждым годом становится все меньше и меньше.
СТАДИИ ЗАБОЛЕВАИЯ,СИМТОМЫ И МЕТОД ЛЕЧЕHИЯ
1. Пеpвая стадия (легкая)
Симптомы: Человек садиться за компутеp, включает его, pаботает и уходит домой в конце pабочего дня, после чего не вспоминает о компутеpе до следующего утpа. Аппетит и сон ноpмален головные боли и понос отсутствуют.
Лечение: В лечении вpеменно не нуждается.
2. Втоpая стадия (полулегкая)
Симптомы: У больного наблюдается повышенный интеpес к компутеpу, выpажающийся в нездоpовом возбуждении, охватывающим его пpи виде указанного обьекта. Аппетит ноpмальный. Сон беспокойный со вскpикиваниями и повизгиваниями. Задеpживается на pаботе на 2-3 часа и топчет кнопки.
Лечение: Удалить больного от компутеpа, пpинимать внутpь медецинский спиpт 3 pаза в день по 0.5 столовой ложки. Компутеpную литеpатуpу убpать в недоступное место. С pаботы встpечать.
3. Тpетия стадия (сpедней тяжести)
Симптомы: Больной задеpживается на pаботе более 4-5 часов после окончания pабочего дня, копит деньги на домашний компутеp. В обиходе начинает употpеблять компьютеpную теpминологию и не pеагиpует на расшиpенные глаза окpужающих. Аппетит повышенный. Сон беспокойный с выкpикиванием компутеpных словечек и беспpичинным смехом. Пpиходит в pезкое возбуждение пpи виде компутеpа или пpи встpечи с больным 3-й стадии и выше. В этом случае болезнь может пеpейти в 4-ю стадию.
Лечение: Больного изолиpовать от общества и от компутеpа, деньги отобpать, женить. Пpи буpном поведении и отказе от лечения вводить внутpижелудочно 1-2 ковша водки с поpтвейном "777", смешаных в пpопоpции 1:2. Тазик не давать.
4. Четвеpтая стадия (тяжелая)
Симптомы: Больной покупает модем и компутеp. Речь изобилует pазличными компутеpными словечками и их сочетаниями. Изобpетает новые слова, копит денег на выделенную телефонную линию. Аппетит сильно повышен. Ест любую пищу в любое вpемя суток пpи ее наличии. Спит 3-4 часа в день, т.к.ночью звонит по модему и пpи каждои соединении издает вопли, описанные в 3-ем томе книги "Жизнь Животных" (глава 1 поведение самца макаки-pезуса в бpачный пеpиод). Половое влечение сниженно. Рвота, pабота, бpед и понос отсутсвуют.
Лечение: Лечению подлежит только в стационаpе.
5.(Безнадежная)
Симптомы: Больной заводит у себя BBS, котоpой уделяет все свободное от звонков и пpогpаммиpования вpемя. Речь невнятная, состоящая на 80 и более пpоцентов компутеpного жаpгона со спецтеpминами. Аппетит и сон отсутствуют. Ест только то что попадает в пpeделы пpямой видимости, независимо от вида и качества пpодукта. На окpужающих обpащает внимание только в том случае если они пpоизносят фpазы связанные с компутеpом. Половое влечение отсутствует полностью, т.к. пеpиодически испытывает чувство глубокого удовлетвоpения от стpоки на экpане "Connect 33600...". деpжит около компутеpа ночную вазу и пачку чая, котоpую забывает pазвести в воде.
Лечение: Лечению не подлежит.

  1. Предполагается, что поле BLOB (например, Pict)
  2. в запросе Query.SQL пишется что-то вроде
  3. 'select Pict from sometable where somefield=somevalue'
  4. запрос открывается
  5. делается "присваивание":

 Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
 

или, если известно, что эта картинка - Bitmap, то можно


 Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))
 

А можно воспользоваться компонентом TDBImage.




Значение DBLookupComboBox

Я думаю что у меня есть то, что вы хотите. Если вы обратитесь к свойству LookUpValue, то вы получите поле, которое .... ищете.

Я надеюсь что помог вам.


 unit clookup;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, DB, DBLookup;
 
 type
   TDBJustLookupCombo = class(TDBLookupCombo)
   private
     { Private declarations }
   protected
     { Protected declarations }
     function GetLValue: TField;
   public
     { Public declarations }
     property LookUpValue: TField read GetLValue;
   published
     { Published declarations }
   end;
 
   TDBJustLookupList = class(TDBLookupList)
   private
     { Private declarations }
   protected
     { Protected declarations }
     function GetLValue: TField;
   public
     { Public declarations }
     property LookUpValue: TField read GetLValue;
   published
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Data Controls', [TDBJustLookupList,
     TDBJustLookupCombo]);
 end;
 
 function TDBJustLookupCombo.GetLValue: TField;
 begin
   Result := LookupSource.DataSet.FieldByName(LookUpField);
 end;
 
 function TDBJustLookupList.GetLValue: TField;
 begin
   Result := LookupSource.DataSet.FieldByName(LookUpField);
 end;
 
 end.
 




Обновить DBLookUpComboBox при скролинге таблицы

Автор: Stone

Есть табличка, к ней привязан TDBLookupComboBox. Значение в нем отображается только после клика мышкой. Как заставить его перерисоваться после изменения текущей записи в таблице, к которой он привязан?


 DBLookupComboBox.KeyValue := Table1.FieldByName('Field1').Value;
 




Показываемое DBLookupComboBox значение

Автор: Michael Pratt

Cледующая строка в обработчике события OnActivate:


 DBLookupCombox1.Perform(WM_KeyDown,38,0);
 

заполняет показываемое в dblookupcombox значение. Вы посылаете сообщение индекса непосредственно в dblookupcombox.




Поиск текста в DBMemo

Попробуйте так: "Подключите" следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.


 procedure TMainForm.FindDialog1Find(Sender: TObject);
 var
   Buff, P, FT: PChar;
   BuffLen: Word;
 begin
   with Sender as TFindDialog do
   begin
     GetMem(FT, Length(FindText) + 1);
     StrPCopy(FT, FindText);
     BuffLen := DBMemo1.GetTextLen + 1;
     GetMem(Buff, BuffLen);
     DBMemo1.GetTextBuf(Buff, BuffLen);
     P := Buff + DBMemo1.SelStart + DBMemo1.SelLength;
     P := StrPos(P, FT);
     if P = nil then
       MessageBeep(0)
     else
     begin
       DBMemo1.SelStart := P - Buff;
       DBMemo1.SelLength := Length(FindText);
     end;
     FreeMem(FT, Length(FindText) + 1);
     FreeMem(Buff, BuffLen);
   end;
 end;
 

Попробуйте так: "Подключите" следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.


 begin
   DBMemo1.SelStart:= P - Buff;
   DBMemo1.SelLength:= Length(FindText);
 end;
   FreeMem(FT, Length(FindText) + 1);
   FreeMem(Buff,BuffLen);
   DBMemo1.SetFocus;
 end;
 




Выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки

Автор: Nomadic

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

set serveroutput on size 10000;



Выключение кнопок в DBNavigator

Microsoft - маленький софт с большими сюрпризами.


 { Расширение DBNavigator: позволяет разработчику включать и выключать
 отдельные кнопки через методы EnableButton и DisableButton }
 
 unit GNav;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, DBCtrls;
 
 type
   TMyNavigator = class(TDBNavigator)
   public
     procedure EnableButton(Btn: TNavigateBtn);
     procedure DisableButton(Btn: TNavigateBtn);
   end;
 
 procedure Register;
 
 implementation
 
 procedure TMyNavigator.EnableButton(Btn: TNavigateBtn);
 begin
   Buttons[Btn].Enabled := True;
 end;
 
 procedure TMyNavigator.DisableButton(Btn: TNavigateBtn);
 begin
   Buttons[Btn].Enabled := False;
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TMyNavigator]);
 end;
 
 end.
 




Свойства кнопок DBNavigator

Принято решение переименовать Windows 98 в Windows Diana. Во-первых, выглядит очень привлекательно, во-вторых, требует дофига ресурсов, а в-третьих, живописно крушится.

Как можно узнать значения свойств кнопок компонента DBNavigator (enabled/disabled или видимая/невидимая)?

Для определения видимости вы можете использовать свойство VisibleButtons. Например:


 if nbRefresh in DBNavigator1.VisibleButtons then
   ShowMessage('Кнопка Refresh видимая') ;
 

Для того, чтобы узнать, активизирована (enabled/disabled) кнопка или нет:


 {Вместо nbFirst вы можете определить другой
 член TNavigateBtn (например, nbFirst, nbPrior,
 nbNext, nbLast, nbInsert, nbDelete, nbEdit,
 nbPost, nbCancel, nbRefresh)}
 
 if DBNavigator1.Controls[Ord(nbFirst)].Enabled then
   ShowMessage('Кнопка First активизирована') ;
 




Вызов кнопок DBNavigator

Встречаются два хакера. Один говорит:
- А я знаю что надо сделать чтоб OSR2 ваабще не глючила!
- Что???
- Да всего один байт поменять!
- Какой ???
- Да в названии OSR2 третий байт надо поменять на "/"!!! Ж:-)))

Я думаю для этого отлично подойдет вызов public-метода BtnClick(nbButton). Я догадываюсь, почему они не назвали его просто "Click", поскольку это метод события OnClick :-) .

Я делаю приблизительно так:


 DBNavigator1.BtnClick(nbInsert);
 

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

Я не знаю, задокументирована эта "фича", рекомендована ли для таких случаев... Просто у меня это работает и я этим пользуюсь.




Настройки всплывающих подсказок в DBNavigator

Автор: Freddy Hansson

Звонок интернет повайдеру:
- Алло, это интернет?
- Да.
- Тогда соедените меня с www.delphiworld.ext


 procedure TForm1.Button1Click(Sender: TObject);
 var
   ix: integer;
 begin
   with DBNavigator1 do
     for ix := 0 to ControlCount - 1 do
       if Controls[ix] is TNavButton then
         with Controls[ix] as TNavButton do
           case index of
             nbFirst: Hint := 'Подсказка для кнопки First';
             nbPrior: Hint := 'Подсказка для кнопки Prior';
             nbNext: Hint := 'Подсказка для кнопки Next';
             nbLast: Hint := '';
             {......}
           end;
 end;
 




DBNavigator без иконок

Автор: Ralph Friedman

Фидошник игpает в Поле Чудес, на табло: ***
Якубович читает задание:
- Часть тела
Фидошник сpазу:
- Hога!
- Hо ведь в задании только тpи буквы...
- :-/ а я думал у вас H не настpоена.


 var
   c: shortint;
   s: string;
 begin
   s := 'A';
   with DBNavigator1 do
     for c := 0 to ControlCount - 1 do
       if Controls[c] is TNavButton then
         with TNavButton(Controls[c]) do
         begin
           ListBox1.Items.Add(Name);
           Glyph := nil;
           Caption := s;
           Inc(s[1]);
         end;
 end;
 




Как можно открыть отчёт (в режиме Print Preview а также Print Direct) в MS Access



От: Святой Петр
Кому: Всем на Земле
Дата Октябрь, 1999 от рождества Христова
Тема: Не помирать!
Для ускорения регистрационного процесса у врат Рая, мы стали использовать Microsoft Access, после чего у нас начались серьeзные проблемы. А посему, пожалуйста, не помирайте пока!


 var
   Access: Variant;
 begin
   // Открываем Access
   try
     Access := GetActiveOleObject('Access.Application');
   except
     Access := CreateOleObject('Access.Application');
   end;
   Access.Visible := True;
 
   // Открываем базу данных
   // Второй параметр указывает - будет ли база открыта в Exclusive режиме
   Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);
 
   // открываем отч¸т
   {Значение второго пораметра может быть одним из следующих
   acViewDesign, acViewNormal, or acViewPreview. acViewNormal,
   которые устанавливаются по умолчанию, для печати отч¸та.
   Если Вы не используете библиотеку типов, то можете определить
   эти значения следующими:
 
   const
   acViewNormal = $00000000;
   acViewDesign = $00000001;
   acViewPreview = $00000002;
 
   Третий параметр - это имя очереди для текущей базы данных.
   Четв¸ртый параметр - это строка для SQL-евского WHERE -
   то есть строка SQL, минус WHERE.}
 
   Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
     EmptyParam);
 
   < ... >
 
   // Закрываем базу данных
   Access.CloseCurrentDatabase;
 
   // Закрываем Access
   {const
   acQuitPrompt = $00000000;
   acQuitSaveAll = $00000001;
   acQuitSaveNone = $00000002;}
   Access.Quit(acQuitSaveAll);
 end;
 



Как в Delphi сбросить кэш БД на диск

- Ты слишком много знал, - сказал Windows HardDisk-у.


 uses BDE {в Delphi 1.x не помню, но вроде bdeprocs};
 
 dbiSaveChanges
 

На Delphi 1.x (16bit) дополнительно вызовите эту процедуру:


 procedure DropCache; assembler;
 asm
   mov ah,$0D
   int $21
 end;
 




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

Базу селектом не испортишь.

Обзор

Данный документ описывает минимально необходимые шаги, необходимые для создания компонента для работы с базами данных, который может отображать данные отдельного поля. Примером такого компонента может служить панель со свойствами DataSource и DataField, похожая на компонент TDBText. Для получения дополнительных примеров обратитесь к Руководству по написанию компонентов "Making a Control Data-Aware".

Как пользоваться данным документом

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

  • создание компонентов на основе существующих

  • перекрытие конструкторов и деструкторов

  • создание новых свойств

  • чтение и запись значений свойств

  • назначение обработчиков событий

Основные шаги по созданию компоненты, осуществляющей навигацию по данным

  • Создайте или наследуйте компонент, который допускает свое отображение, но не ввод данных. Например, вы могли бы использовать компонент TMemo с установленным в True свойством ReadOnly. В примере, приведенном в данном документе, мы используем TCustomPanel. TCustomPanel позволяет себя отображать, но не вводить данные.

  • Добавьте к вашему компоненту data-link object (объект для связи с данными). Данный объект позволяет управлять связью между компонентом и таблицей базы данных.

  • Добавьте к компоненту свойства DataField и DataSource.

  • Добавьте методы для получения и установления DataField и DataSource.

  • Добавьте к компоненту метод DataChange, позволяющий управлять событиями OnDataChange объекта data-link.

  • Перекройте конструктор компонента для создания datalink и перехвата метода DataChange.

  • Перекройте деструктор компонента для очищения datalink.

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

    Выберите соответствующий пункт меню для создания нового компонента (он меняется от версии к версии Delphi), определите TDBPanel как имя класса, и TCustomPanel в качестве наследуемого типа. Определите любую страницу Палитры компонентов.

  • Добавьте DB и DBTables в список используемых модулей.

  • Добавьте data-link объект в секцию private вашего компонента. Данный пример отображает данные одного поля, поэтому мы используем TFieldDataLink для обеспечения связи между нашим новым компонентом и DataSource. Имя нового data-link объекта - FDataLink.

 { пример }
 private
 FDataLink: TFieldDataLink;
 

  • Добавьте к компоненту свойства DataField и DataSource. Мы добавим соответствующий код для методов записи/чтения в последующих шагах.

Примечание: Наш новый компонент будет иметь свойства DataField и DataSource, FDataLink также будет иметь собственные свойства DataField и Datasource.


 { пример }
 published
 property DataField: string
 read   GetDataField
 write  SetDataField;
 property DataSource: TDataSource
 read   GetDataSource
 write  SetDataSource;
 

  • Добавьте частные методы для чтения/записи значений свойств DataField и DataSource, и свойств DataField и DataSource для FDataLink.

 { пример }
 private
 FDataLink: TFieldDataLink;
 function GetDataField: String;
 function GetDataSource: TDataSource;
 procedure SetDataField(Const Value: string);
 procedure SetDataSource(Value: TDataSource);
 .
 .
 implementation
 .
 .
 function TDBPanel.GetDataField: String;
 begin
 Result := FDataLink.FieldName;
 end;
 
 
 function TDBPanel.GetDataSource: TDataSource;
 begin
 Result := FDataLink.DataSource;
 end;
 
 
 procedure TDBPanel.SetDataField(Const Value: string);
 begin
 FDataLink.FieldName := Value;
 end;
 
 
 procedure TDBPanel.SetDataSource(Value: TDataSource);
 begin
 FDataLink.DataSource := Value;
 end;
 

  • Добавьте частный метод DataChange, назначая событие объекта datalink OnDataChange. В методе DataChange добавьте код для отображения данных поля актуальной базы данных, связь с которой обеспечивает объект data-link. В нашем примере мы назначаем значение поля FDataLink заголовку панели.

 { пример }
 private
 .
 .
 procedure DataChange(Sender: TObject);
 
 
 implementation
 .
 .
 procedure TDBPanel.DataChange(Sender: TObject);
 begin
 if FDataLink.Field = nil then
 Caption := '';
 else
 Caption := FDataLink.Field.AsString;
 end;
 

  • Перекройте метод конструктора компонента Create. При реализации Create, создайте объект FDataLink и назначьте частный метод DataChange событию FDataLink OnDataChange.

 { пример }
 public
 constructor Create(AOwner: TComponent); override;
 .
 .
 implementation
 .
 .
 constructor TMyDBPanel.Create(AOwner: TComponent);
 begin
 inherited Create(AOwner);
 FDataLink := TFieldDataLink.Create;
 FDataLink.OnDataChange := DataChange;
 end;
 

  • Перекройте метод деструктора компонента Destroy. При реализации Destroy, установите OnDataChange в nil (чтобы избежать GPF), и освободите FDatalink.

 { пример }
 public
 .
 .
 destructor Destroy; override;
 .
 .
 implementation
 .
 .
 destructor TDBPanel.Destroy;
 begin
 FDataLink.OnDataChange := nil;
 FDataLink.Free;
 inherited Destroy;
 end;
 

  • Сохраните модуль и установите компонент (смотрите документацию Users Guide и Component Writers Guide для получения дополнительной информации по сохранению модулей и установке компонентов).

  • Для тестирования функциональности компонента расположите на форме компоненты TTable, TDatasource, TDBNavigator и TDBPanel. Установите TTable DatabaseName и Tablename в 'DBDemos' и 'BioLife', а свойство Active в True. Установите свойство TDatasource Dataset в Table1. Установите TDBNavigator и свойство TDBPanel DataSource в Datasource1. Имя TDBpanel DataField должно быть установлено в 'Common_Name'. Запустите приложение и, используя навигатор и перемещаясь по записям, убедитесь в том, что TDBPanel обнаруживает изменение данных и отображает значение соответствующего поля.

Полный код компонента


 unit Mydbp;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, DB, DBTables;
 
 type
   TDBPanel = class(TCustomPanel)
   private
     FDataLink: TFieldDataLink;
     function GetDataField: string;
     function GetDataSource: TDataSource;
     procedure SetDataField(const Value: string);
     procedure SetDataSource(Value: TDataSource);
     procedure DataChange(Sender: TObject);
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     property DataField: string
       read GetDataField
       write SetDataField;
     property DataSource: TdataSource
       read GetDataSource
       write SetDataSource;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TDBPanel]);
 end;
 
 function TDBPanel.GetDataField: string;
 begin
   Result := FDataLink.FieldName;
 end;
 
 function TDBPanel.GetDataSource: TDataSource;
 begin
   Result := FDataLink.DataSource;
 end;
 
 procedure TDBPanel.SetDataField(const Value: string);
 begin
   FDataLink.FieldName := Value;
 end;
 
 procedure TDBPanel.SetDataSource(Value: TDataSource);
 begin
   FDataLink.DataSource := Value;
 end;
 
 procedure TDBPanel.DataChange(Sender: TObject);
 begin
   if FDataLink.Field = nil then
     Caption := ''
   else
     Caption := FDataLink.Field.AsString;
 end;
 
 constructor TDBPanel.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FDataLink := TFieldDataLink.Create;
   FDataLink.OnDataChange := DataChange;
 end;
 
 destructor TDBPanel.Destroy;
 begin
   FDataLink.Free;
   FDataLink.OnDataChange := nil;
   inherited Destroy;
 end;
 
 end.
 




Как создать БД в кодировке CP1251

Автор: Nomadic

Вот такая конструкция проходит на DB2 2.1.2/NT и UDB5/NT...


CREATE DATABASE Efes2
 USING CODESET 1251 TERRITORY RU
 COLLATE USING IDENTITY;
 




Курсоры в ADO


Программы пропили всё... Даже курсор от мышки...

В Delphi компоненты ADOExpress довольно приятны в использовании. Однако программирование компонент ADOExpress весьма отличается от традиционного Delphi программирования в компонентах TTable и TQuery, основанных на BDE. Естевственно, что если Вы привыкли к компонентам BDE dataset, то сразу же заметите различие в количестве возможностей и свойств, а так же в стиле программирования BDE и ADO.

В основе ADO лежит объект Recordset (aka Dataset). Этот объект является результатом Query команды (например, выражение SELECT компонента TADOQuery). Когда ADO-приложение получает строки из базы данных, то объект ADO Recordset формирует необходимую информацию и операции, допустимые для получаемых данных. При этом ADO использует курсоры, чтобы хранить набор строк для обработанной записи. Так же курсор содержит в себе текущую позицию в записи (recordset). Обычно, при разработке приложения, курсоры используются при создании записей, а так же при перемещении по записям (вперёд или назад).

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

Каждый раз когда мы будем открывать определённую запись ADO, то мы будем открывать её с определённым типом курсора.

Класс TCustomADODataSet содержит набор свойств, событий и методов, для работы с данными, доступными через ADO datastore. Все классы-потомки от TCustomADODataSet (такие как TADODataSet, TADOTable, TADOQuery, и TADOStoredProc) совместно используют некоторые общие свойства. В каждом из этих классов присутствуют три свойства, соответствующие функциям курсоров, описанным выше: CursorType, CursorLocation, и LockType. Давайте рассмотрим эти свойства по-подробнее.

CursorType
ADO содержит четы опции для данного типа курсора: dynamic, keyset, forward-only и static. Так как каждый тип курсора ведёт себя работает по разному, то несомненно Вы извлечёте пользу из каждого из этих видов курсоров. Свойство CursorType указывает на то, каким образом Вы будете перемещаться по записям а так же какие изменения будут видны в записях базы данных, после того как Вы получите из неё данные. В Delphi классах ADO типы курсоров задаются в TCursorType.
ctDynamic
Позволит Вам видеть добавления, изменения и удаления, сделанные другими пользователями, а также позволит делать все типы перемещения по записи (Recordset) не полагаясь на закладки. Однако закладки можно использовать, если они поддерживаются. Для этого существует метод Supports в ADODataset, который сигнализирует о поддержке определённых типов операций. Следующее выражение позволяет определить, поддерживаются закладки или нет:


 if ADOTable1.Supports(coBookmark) then ...
 

Если несколько пользователей одновременно вставляют (insert), апдейтят (update), или удаляют (delete) строки в базе данных, то лучше всего выбрать курсор dynamic.
ctKeyset
Ведет себя подобно динамическому курсору, за исключением того, что Вы не сможете видеть записи, которые добавляют другие пользователи, а так же не сможете получить доступ к записям, которые удаляются другими пользователями. Изменение данных другими пользователями будет все еще видимо. Этот тип всегда поддерживает закладки и поэтому позволяет все типы перемещения по записям (Recordset).
ctStatic
Обеспечивает статическую копию набора записей, чтобы использовать её для поиска данных и генерации отчётов. Данный тип всегда разрешает закладки и поэтому позволяет все типы движения по записям. Добавления, изменения, или удаления другими пользователями не будут видимы. Статический курсор ведет себя подобно компоненту BDE Query со свойством RequestLive установленным в False.
ctForward-only
Ведет себя идентично динамическому курсору за исключением того, что позволяет Вам пролистывать по записям только вперед. Это увеличивает производительность в ситуациях, где Вы необходимо делать только один проход по набору записей (Recordset). Обратите внимание: если свойство CursorLocation в компоненте ADO dataset установлено в clUseClient, то Вы сможете использовать только опцию ctStatic. Так же обратите внимание: что если Вы запросите тип курсора неподдерживаемый базой данных, то она может вернуть другой тип курсора. То есть если Вы пробуете установить CursorLocation в clUseServer и CursorType в ctDynamic, в базе данных Access, то Delphi заменит CursorType на ctKeyset.
CursorLocation
Свойство CursorLocation определяет, где будет создан набор записей (recordset) когда он будет открыт — у клиента или на сервере. Данные в клиентском (client-side) курсоре не сязаны постоянно ("inherently disconnected") с базой данных. ADO получает результаты запроса (все строки) и копирует данные клиенту перед тем, как Вы начнёте использовать их (в курсоре ADO). После того, как Вы сделаете изменения в наборе записей (Recordset), ADO преобразует эти изменения в запрос и отправляет этот запрос в Вашу базу данных через OLE DB. Клиентский (client-side) курсор ведёт себя подобно локальному кэшу. В большинстве случаев, клиентский (client-side) курсор предпочтителен, потому что перемещения и обновления быстрее и более эффективны. Но, соответственно, увеличивается сетевой трафик при возвращении данных клиенту. Использование серверного (server-side) курсора означает получение только необходимых записей. Естевственно, что на сервер падает большая нагрузка. Серверные (Server-side) курсоры полезны при вставке, модификации, удалении записей. Данный тип курсоров иногда обеспечивает лучшую производительность чем клиентский курсор, особенно когда сеть перегружена. При выборе типа курсора Вам необходимо продумать множество факторов, таких как: будет ли у Вас большое количество обновлений либо Вы будете производить только выборку из базы данных; будете ли Вы использовать ADO как настольное приложение или Ваше приложение будет Internet-ориентированным; размер получаемых данных и т.д. Так же есть некоторое ограничения: например, MS Access не поддерживает динамических курсоров; вместо этого он использует keyset. Некоторые средства доступа к данным автоматически мастабируют свойства CursorType и CursorLocation, в то время как другие генерируют ошибку при использовании неподдерживаемых CursorType или CursorLocation.
LockType
Свойство LockType сообщает провайдеру о блокировках, которые будут помещены в записи в процессе редактирования. Блокировка позволяет предотвратить чтение данных одним пользователем в то время как другой пользователь изменяет эти данные, а так же не дать пользователю изменить данные, если они были изменены другим пользователем. Такой эффект наблюдается в базе данных Access, которая блокирует некоторые соседние записи. Дело в том, что Access использует так называемую стратегию фиксации страницы. Поэтому, если пользователь редактирует запись, то другой пользователь уже не сможет получить доступ к изменению данной записи и, даже не сможет модифицировать ближе стоящие записи (до или после неё). В Delphi, для этой цели используется TADOLockType в которой указывается тип блокировки, которая будет использоваться. Вы можете управлять строкой и блокировкой страницы, устанавливая соответствующую опцию блокировки курсора. Чтобы использовать определенную схему блокировки, провайдер и тип базы данных должны поддержать эту схему.
ltOptimistic
Оптимистическая блокировка блокирует запись только в том случае, если она была физически изменена. Этот тип блокировки полезен, если существует очень маленький шанс того, что второй пользователь может модифицировать строку в интервале между тем, когда курсор открыт, и когда строка окончательно модифицирована. Текущие значения в строке сравниваются со значением полученным когда строка была последний раз выбрана.
ltPessimistic
Пессимистическая блокировка блокирует каждую запись, до тех пор пока она находится в процессе редактирования. Эта опция заставляет ADO устанавливать исключительную блокировку на строку, когда пользователь делает любое изменения в любом столбцу записи. Компоненты ADOExpress непосредственно не поддерживают пессимистическую блокировку записей, потому что сама ADO не имеет возможности произвольно блокировать данную запись и до сих пор поддерживает навигацию в другие записи.
ltReadOnly
Данная блокировка просто не позволяет редактировать данные. Полезна в тех случаях, когда Ваше приложение должно временно предотвратить изменение данных, при этом чтение данной записи разрешено. Самый идеальный способ использования данной блокировки для создания отчётов, если установить CursorType как ctForwardOnly.
ltBatchOptimistic
Блокировка BatchOptimistic используется в клиентских курсорах. Наборы записей с данным курсором апдейтятся локально и все изменения отправляются в базу данных пакетами.



Как узнать содержание активной записи в БД

Следующая функция возвращает в виде указателя на строку содержание активной записи в БД.


 function TBDEDirect.GetCurRecord(Lock: DBILockType): PChar;
 var
   Res: DBIResult;
   RecSize: Word;
   RecBuf: PChar;
   Bookmark: TBookmark;
 begin
   Result := StrNew('');
   if CheckDatabase then
   begin
     RecSize := GetPhysicalRecSize;
     RecBuf := StrAlloc(RecSize+1);
     FillChar(RecBuf^, RecSize+1, #0);
     Bookmark := FDataLink.DataSource.DataSet.GetBookmark;
     DbiSetToBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark);
     FDataLink.DataSource.DataSet.FreeBookmark(Bookmark);
     Res := DbiGetRecord(FDataLink.DataSource.DataSet.Handle, Lock, RecBuf, nil);
     if Res = 0 then
       Result := RecBuf
     else
       Check(Res);
   end;
 end;
 




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


 for i:=0 to pred(DB1.DataSetCount) do
   {if DataSets.Tag = 1 then}
   DataSets[i].Open;
 




Быстрый доступ к нужной записи в таблице Paradox


 var
   NeedNumber: Integer;
 
 ...
 NeedNumber := Table.RecNo;
 {сохранение номера нужной записи}
 ...
 {код меняющий номе записи}
 ...
 Table.RecNo := NeedNumber;
 {востановление номера нужной записи}
 



Контекстное меню на основе базы данных

Пpиходит пpогpамеp вечеpом домой весь в кpови и без pуки. Жена спpашивает:
- Что случилось доpогой???
Пpогpамеp:
- Да так, в кулеp засосало.


 var
   m: TMenuItem;
   navidummy: TComponent;
   ..........................................................
 
   procedure TMyForm.CreatePopUpMM(Sender: TObject);
 begin
 
   Navidummy.free;
   Navidummy := TComponent.create(self);
 
   while not NaviT.EOF do
   begin
     m := TMenuItem.create(navidummy);
     II := II + 1;
     with m do
     begin
       name := 'MM' + IntToStr(II);
       caption := NaviT.Fieldbyname('MyWHAT').AsString;
       tag := NaviT.Fieldbyname('MyTAG').AsInteger;
       visible := True;
       OnClick := NaviExec;
     end;
     MyMenuItem.add(m);
     NaviT.Next;
   end;
   NaviT.Close;
 end;
 
 procedure TMyForm.NaviExec(Sender: TObject);
 begin
   { Здесь я получаю то, что хочу ! }
   What.text := (Sender as TMenuItem).Caption;
   Key := (Sender as TMenuItem).Tag;
 end;
 




БД-дерево взаимоотношений

Все это я делал раньше. Я не могу вам все это показать на развернутом примере, но я дам вам идею как сделать это. Вы должны иметь таблицу, осуществляющую взаимоотношение между людьми. Если на Peter работают Jane и Simon, вы должны иметь таблицу (RELATION) с этими двумя записями.

Master    Slave  ------- имена полей
 Peter     Jane
 Peter     Simon
Если George и Elisa работают на Jane, то таблица становится такой:
Master    Slave  ------- имена полей
 Peter     Jane
 Peter     Simon
 Jane      George
 Jane      Elisa
и так далее.

Если в таблице RELATION необходимо создать дерево, начинающееся на Peter, то нужно добавить к дереву главный узел (запись), где Master = Peter. Затем каждая дочерняя запись располагается ниже записи Master = Peter. После добавления дочерней записи вы сразу увидите, если ребенок имеет собственного ребенка. Ребенок становится теперь, вероятно, отцом, поэтому вы должны позиционировать таблицу RELATION к первой записи, где Master = child, и так далее, рекурсивно. Такой способ гарантирует построение правильного дерева.

Пример:


 AddFather('Peter')
 AddChild('Peter', 1)
 
 procedure AddFather(Name: string)
 begin
   Tree.Add(Name);
 end;
 
 procedure AddChildr(Name: string, Index: Integer)
 begin
   Relation.FindKey([Name])
   while RelationMaster.AsString = Name do
   begin
     Tree.AddChild(Index, RelationSlave.AsString);
     AddChild(RelationSlave.AsString, Tree.ItemsCount);
     Relation.Next;
   end;
 end;
 

По-моему, ошибок нет.




Сортировка связанного списка

Автор: Peter Below


 program noname;
 
 type
   PData = ^TData;
   TData = record
     next: PData;
     Name: string[40];
     { ...другие поля данных }
   end;
 
 var
   root: PData; { это указатель на первую запись в связанном списке }
 
 procedure InsertRecord(var root: PData; pItem: PData);
 (* вставляем запись, на которую указывает pItem в список начиная
 с root и с требуемым порядком сортировки *)
 var
   pWalk, pLast: PData;
 begin
   if root = nil then
   begin
     (* новый список все еще пуст, просто делаем запись,
     чтобы добавить root к новому списку *)
     root := pItem;
     root^.next := nil
   end { If }
   else
   begin
     (* проходимся по списку и сравниваем каждую запись с одной
     включаемой. Нам необходимо помнить последнюю запись,
     которую мы проверили, причина этого станет ясна немного позже. *)
     pWalk := root;
     pLast := nil;
 
     (* условие в следующем цикле While определяет порядок сортировки!
     Это идеальное место для передачи вызова функции сравнения,
     которой вы передаете дополнительный параметр InsertRecord для
     осуществления общей сортировки, например:
 
     While CompareItems( pWalk, pItem ) < 0 Do Begin
     where
     Procedure InsertRecord( Var list: PData; CompareItems: TCompareItems );
     and
     Type TCompareItems = Function( p1,p2:PData ): Integer;
     and a sample compare function:
     Function CompareName( p1,p2:PData ): Integer;
     Begin
     If p1^.Name < p2^.Name Then
     CompareName := -1
     Else
     If p1^.Name > p2^.Name Then
     CompareName := 1
     Else
     CompareName := 0;
     End;
     *)
     while pWalk^.Name < pItem^.Name do
       if pWalk^.next = nil then
       begin
         (* мы обнаружили конец списка, поэтому добавляем
         новую запись и выходим из процедуры *)
         pWalk^.next := pItem;
         pItem^.next := nil;
         Exit;
       end { If }
       else
       begin
         (* следующая запись, пожалуйста, но помните,
         что одну мы только что проверили! *)
         pLast := pWalk;
 
         (* если мы заканчиваем в этом месте, то значит мы нашли
         в списке запись, которая >= одной включенной. Поэтому
         вставьте ее перед записью, на которую в настоящий момент
         указывает pWalk, которая расположена после pLast. *)
         if pLast = nil then
         begin
           (* Упс, мы вывалились из цикла While на самой первой итерации!
           Новая запись должна располагаться в верхней части списка,
           поэтому она становится новым корнем (root)! *)
           pItem^.next := root;
           root := pItem;
         end { If }
         else
         begin
           (* вставляем pItem между pLast и pWalk *)
           pItem^.next := pWalk;
           pLast^.next := pItem;
         end; { Else }
         (* мы сделали это! *)
       end; { Else }
   end; { InsertRecord }
 
 procedure SortbyName(var list: PData);
 var
 
   newtree, temp, stump: PData;
 begin { SortByName }
 
   (* немедленно выходим, если сортировать нечего *)
   if list = nil then
     Exit;
   (* в
   newtree := Nil;
 
   (********
   Сортируем, просто беря записи из оригинального списка и вставляя их
   в новый, по пути "перехватывая" для определения правильной позиции в
   новом дереве. Stump используется для компенсации различий списков.
   temp используется для указания на запись, перемещаемую из одного
   списка в другой.
   ********)
   stump := list;
   while stump <> nil do
   begin
     (* временная ссылка на перемещаемую запись *)
     temp := stump;
     (* "отключаем" ее от списка *)
     stump := stump^.next;
     (* вставляем ее в новый список *)
     InsertRecord(newtree, temp);
   end; { While }
 
   (* теперь помещаем начало нового, сортированного
   дерева в начало старого списка *)
   list := newtree;
 end; { SortByName }
 begin
 
   New(root);
   root^.Name := 'BETA';
   New(root^.next);
   root^.next^.Name := 'ALPHA';
   New(root^.next^.next);
   root^.next^.next^.Name := 'Torture';
 
   WriteLn(root^.name);
   WriteLn(root^.next^.name);
   WriteLn(root^.next^.next^.name);
 end.
 




В чем разница между сокетами, DCOM и OLE Enterprise при использовании их в качестве транспорта

Автор: Nomadic

Sockets (TCP/IP):

  • на клиентах и сервере требуется наличие стека TCP/IP;
  • не требуется дополнительной настройки клиентов;
DCOM:
  • на клиентах и серверах требуется наличие DCOM (входит в состав Windows NT 4.0, для Windows 95 доступен как опция)
  • требуется настройка клиентов (DCOM Configuration Utility - DCOMCNFG.EXE);
  • встроенная поддержка модели безопасности Windows NT;
  • поддержка обратных вызовов (методов);
CORBA
  • на клиентах и серверах требуется наличие Common Object Request Broker;
  • требуется настройка клиентов;
  • поддержка обратных вызовов (методов);
OLE Enterprise:
  • на клиентах и серверах требуется наличие OLE Enterprise;
  • требуется настройка клиентов;
  • поддержка обратных вызовов (методов).



DDE - передача текста

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

Вот я как работаю с Excel:


 type
   DDEClientConv1.SetLink('Excel', 'Sheet1');
 try
   DDEClientConv1.OpenLink;
   DDEClientItem1.DDEItem := 'R1C1';
   DDEClientConv1.PokeData(DDEClientItem1.DDEItem,
     StrPCopy(P, SomeString)));
 finally
   DDEClientConv1.CloseLink;
 end;
 

Как вы можете здесь видеть, свойство DDEItem определяется сервером. Если ваш сервер является приложением Delphi, то DDEItem - имя DDEServerItem. На вашем месте я бы не стал так долго заниматься отладкой DDE-программ. Воспользуйтесь синхронизацией, позволяющей понять при отладке правильность действий.




DDE для захвата текущего URL из окна Internet Explorer или Netscape Navigator


Вопpос: "Можно ли сообщение "Пpогpамма выполнила недопустимую опеpацию....обpатитесь к pазpаботчику" считать официальным вызовом в США?


 uses
   windows, ddeman, ...
 
 
 function Get_URL(Servicio: string): string;
 var
   Cliente_DDE: TDDEClientConv;
   temp: PChar;      //<<-------------------------This is new
 begin
   Result := '';
   Cliente_DDE:= TDDEClientConv.Create( nil );
   with Cliente_DDE do
   begin
     SetLink( Servicio,'WWW_GetWindowInfo');
     temp := RequestData('0xFFFFFFFF');
     Result := StrPas(temp);
     StrDispose(temp);  // <<-- Предотвращаем утечку памяти
     CloseLink;
   end;
   Cliente_DDE.Free;
 end;
 
 procedure TForm1.Button1Click(Sender);
 begin
    showmessage(Get_URL('Netscape'));
 // или
    showmessage(Get_URL('IExplore'));
 end;
 




Регистрация программ в меню Пуск Windows

- Можно ли по-настоящему любить двух женщин одновременно?
- Можно, но только под UNIX.

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов - объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:


 function TForm2.ProgmanCommand(Command: string): boolean;
 var
   macrocmd: array[0..88] of char;
 begin
   DDEClient.SetLink('PROGMAN', 'PROGMAN');
   DDEClient.OpenLink; { Устанавливаем связь по DDE }
   strPCopy(macrocmd, '[' + Command + ']'); { Подготавливаем ASCIIZ строку }
   ProgmanCommand := DDEClient.ExecuteMacro(MacroCmd, false);
   DDEClient.CloseLink; { Закрываем связь по DDE }
 end;
 
 // Пример использования:
 ProgmanCommand('CreateGroup(Комплекс программ для
   каталогизации литературы, )');
 ProgmanCommand('AddItem(' + path + 'vbase.hlp, Справка по VBase,
   '+ path +' vbase.hlp, 0, , , '+ path + ', , )');
 // где path - строка типа String, содержащая
 // полный путь к каталогу ('C:\Catalog\');
 

При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:

  • Create(Имя группы, путь к GRP файлу) Создать группу с именем "Имя группы", причем в нем могут быть пробелы и знаки препинания. Путь к GRP файлу можно не указывать, тогда он создастся в каталоге Windows.
  • Delete(Имя группы) Удалить группу с именем "Имя группы"
  • ShowGroup(Имя группы, состояние) Показать группу в окне, причем состояние - число, определяющее параметры окна:
    • 1-нормальное состояние + активация
    • 2-миним.+ активация
    • 3-макс. + активация
    • 4-нормальное состояние
    • 5-Активация
  • AddItem(командная строка, имя раздела, путь к иконке, индекс иконки (с 0), Xpos,Ypos, рабочий каталог, HotKey, Mimimize) Добавить раздел к активной группе. В командной строке, имени размера и путях допустимы пробелы,
  • Xpos и Ypos - координаты иконки в окне, лучше их не задавать, тогда PROGMAN использует значения по умолчанию для свободного места.
  • HotKey - виртуальный код горячей клавиши.
  • Mimimize - тип запуска, 0-в обычном окне, <>0 - в минимизированном.
  • DeleteItem(имя раздела) Удалить раздел с указанным именем в активной группе



DDE для вызова диалога поиска файлов и папок



 uses DdeMan;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with TDDEClientConv.Create(Self) do
   begin
     ConnectMode := ddeManual;
     ServiceApplication := 'explorer.exe';
     SetLink( 'Folders', 'AppProperties');
     OpenLink;
     ExecuteMacro('[FindFolder(, C:\Мои документы)]', False);
     CloseLink;
     Free;
   end;
 end;
 




Пример DDE и WordPerfect

Автор: John Studt

Вот небольшой пример, скопированный из моего проекта:


 procedure TForm1.PrintSave(Doc: string);
 var
   ProdDoc, ArchDoc: string;
   WPCommands: TStringList;
 begin
   ProdDoc := ProdDrive + Doc;
   ArchDoc := ArchDrive + Doc;
 
   WPCommands := TStringList.Create;
   with WPCommands do
   begin
     Add('FileOpen(Filename:"' + ProdDoc + '")');
     Add('FileSave(Filename:"' + ProdDoc + '";ExportType:3;Overwrite:1)');
 
     Add('PrintCopies(NumberOfCopies:2)');
     Add('PrintCopiesBy(CopiesBy:1) ');
     Add('PrintFullDoc() ');
     Add('DocCompare(FileName:"' + ArchDoc + '";CompFlags:1) ');
     Add('FileSave(Filename:"' + EMailDoc + '";ExportType:3;Overwrite:1');
 
     Add('Close(Save:0) ');
   end;
 
   if PDDE.ExecuteMacroLines(WPCommands, True) then
   begin
     log('WPCommand Worked!')
       {  Теперь необходимо подождать WP, чтобы завершить команду... }
   end
   else
     log('Ошибка WPCommand!');
 
   WPCommands.Free;
 end;
 

Примечание: Вы не можете использовать 'True!' или 'False!', как это делается в макросах WP. Вы должны использовать числовые значения. Как узнать числовой эквивалент команды: если в WP использовать построитель макросов, то можно передавать перечислимые типы в диалоговое окно и узнавать их числовой эквивалент.

Все это проверено, DDE работает в связке WP/Delphi, первая команда возвращает сообщение 'Ok, я получил это', и запускает макрос. При попытке послать второй запрос DDE, он ожидает завершение обработки первого, выводит сообщение типа 'Необходимо подождать....', после чего немедленно передает управление. Мне хотелось бы дождаться команды завершения прежде, чем я возвращусь из своей процедуры.




Работа с Netscape Navigator через DDE


Инетчика жена отправила в магазин за кофе. Продавщица его спрашивает:
- Вам какой кофе?
- Ну этот, самый, как его... Нетскейп.
- ????
- Блин!!!! home.netscape.com


 uses DDEman;
 ...
 procedure GotoURL(sURL: string);
 var
   dde: TDDEClientConv;
 begin
   dde := TDDEClientConv.Create(nil);
   with dde do
   begin
     // specify the location of netscape.exe
     ServiceApplication :='C:\Program Files\Netscape\Communicator\Program\NETSCAPE.EXE';
     // activate the Netscape Navigator
     SetLink( 'Netscape', 'WWW_Activate' );
     RequestData('0xFFFFFFFF');
     // go to the specified URL
     SetLink( 'Netscape', 'WWW_OpenURL' );
     RequestData( sURL+',,0xFFFFFFFF,0x3,,,' );
     // ... CloseLink;
   end;
   dde.Free;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   GotoURL('http://www.site.ru');
 end;
 




Деактивация приложения

Автор: Marco Romanini (Delphi Tech Support)

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


 Application.OnDeactivate=AppDeactivate;
 

Затем создайте следующий метод:


 procedure Form1.AppDeactivate(Sender: TObject);
 begin
   ...
   { здесь ваш код}
   ...
 end;
 




В режиме отладки приложения не разрешается открытие базы данных

Автор: Nomadic

"Bugs" - фильм ужасов для программистов-отладчиков.

Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте - совет от ORACLE.

Глюк имеет место быть только под Windows NT 4.xx.




Определение и использование курсора

Если твоя мама - женщина, если Клава - для тебя имя, а мышь - грызун, то ты "ламер"!!!

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


 implementation
 {$R MyApp01.Res}
 

Вы не можете назначить курсор свойству компонента Cursor или DragCursor из .RES-файла напрямую, необходимо выполнить несколько промежуточных шагов. В каждом проекте Delphi определяет глобальный объект с именем Screen (тип TScreen), который, между прочим, определяет массив курсоров, называемый, как ни странно, Cursors. Когда вы щелкаете на свойстве Cursor/DragCursor в Инспекторе объектов, выпадающий список и есть список элементов указанного массива.

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

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


 Const
   MyCursor = 1;
 

Далее необходимо загрузить курсор. Сделать это можно в обработчике события формы OnCreate:


 Screen.Cursors[MyCursor] := LoadCursor(HInstance, 'MYCURSOR');
 

Затем просто установите в свойстве DragCursor любого элемента управления:


 MyListbox.DragCursor := MyCursor;
 

Примечание: имя вашего курсора всегда должно писаться в ВЕРХНЕМ регистре, как при вызове LoadCursor, так и в его названии в .RES-файле.




Определение присутствия функции в DLL

Данная функция определяет присутствие нужной функции в библиотеке (dll) и, в случае нахождения искомой функции возвращает True, иначе False.


 function FuncAvail (VLibraryname, VFunctionname: string;
          var VPointer: pointer): boolean;
 var
   Vlib: tHandle;
 begin
   Result := false;
   VPointer := nil;
   if LoadLibrary(PChar(VLibraryname)) = 0 then
     exit;
   VPointer := GetModuleHandle(PChar(VLibraryname));
   if Vlib <> 0 then
   begin
     VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
     if VPointer <> nil then
       Result := true;
   end;
 end;
 




Декларация события OnPassword

Автор: Tim Gooch

Мне необходимо написать процедуру для OnPassword с использованием TPasswordEvent. Но я никак не могу его прикрутить к объекту!

Объявление TPasswordEvent в исходном коде VCL неверно (исправлено в Delphi 2.0). Оно должно включать в себя ключевые слова "of object", как и все остальное объявления данного типа.

Есть два пути решения проблемы:

A) Изменить исходный код VCL

B) Создать не-стандартный обработчик события, работающий с неправильно декларированным.

Решение A - мой выбор, но для этого необходимо, чтобы вы имели копию исходного кода VCL. (Не пытайтесь пересобрать библиотеку VCL; просто измените файл и добавьте путь к файлу DB.PAS file в пути вашего проекта.)

Решение B немного более прагматичное и не требует изменения исходного кода VCL. Создайте следующую функцию:


 procedure PasswordProc(Sender: TObject; var Continue: Boolean); far;
 begin
   Session.AddPassword('Harrison');
   Continue := True;
 end;
 

Затем измените обработчик события OnCreate...


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Session.OnPassword := PasswordProc;
   Table1.Active := True;
 end;
 

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

Если вы решаете воспользоваться методом A, то единственное отличие будет заключаться в том, что вам понадобиться добавить объявление процедуры к вашему классу формы, и в секции Implementation ваша процедура должна выглядеть примерно так:


 procedure TForm1.PasswordProc(Sender: TObject; var Continue: Boolean);
 begin
   Session.AddPassword('Harrison');
   Continue := True;
 end;
 

Поскольку эта версия является функцией-членом, у нее существует преимущество при доступе к компонентам и private- или protected-членам вашей формы (TForm-производного класса).




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

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

Читая форумы по программированию, иногда натыкаешься на вопрос типа: "У меня есть откомпилированная программа на 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' ( исходники проекта будут созданы в текущей директории).



Декомпилляция звукового файла формата Wave и получение звуковых данных

ИМХО - это аббревиатура.
Истинное Мнение Хр#н Оспоришь.

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

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.


 unit LinearSystem;
 
 interface
 
 {============== Тип, описывающий формат WAV ==================}
 type
   WAVHeader = record
 
     nChannels: Word;
     nBitsPerSample: LongInt;
     nSamplesPerSec: LongInt;
     nAvgBytesPerSec: LongInt;
     RIFFSize: LongInt;
     fmtSize: LongInt;
     formatTag: Word;
     nBlockAlign: LongInt;
     DataSize: LongInt;
   end;
 
   {============== Поток данных сэмпла ========================}
 const
   MaxN = 300; { максимальное значение величины сэмпла }
 type
   SampleIndex = 0..MaxN + 3;
 type
   DataStream = array[SampleIndex] of Real;
 
 var
   N: SampleIndex;
 
   {============== Переменные сопровождения ======================}
 type
   Observation = record
 
     Name: string[40]; {Имя данного сопровождения}
     yyy: DataStream; {Массив указателей на данные}
     WAV: WAVHeader; {Спецификация WAV для сопровождения}
     Last: SampleIndex; {Последний доступный индекс yyy}
     MinO, MaxO: Real; {Диапазон значений yyy}
   end;
 
 var
   K0R, K1R, K2R, K3R: Observation;
 
   K0B, K1B, K2B, K3B: Observation;
 
   {================== Переменные имени файла ===================}
 var
   StandardDatabase: string[80];
 
   BaseFileName: string[80];
   StandardOutput: string[80];
   StandardInput: string[80];
 
   {=============== Объявления процедур ==================}
 procedure ReadWAVFile(var Ki, Kj: Observation);
 procedure WriteWAVFile(var Ki, Kj: Observation);
 procedure ScaleData(var Kk: Observation);
 procedure InitAllSignals;
 procedure InitLinearSystem;
 
 implementation
 {$R *.DFM}
 uses VarGraph, SysUtils;
 
 {================== Стандартный формат WAV-файла ===================}
 const
   MaxDataSize: LongInt = (MaxN + 1) * 2 * 2;
 const
   MaxRIFFSize: LongInt = (MaxN + 1) * 2 * 2 + 36;
 const
   StandardWAV: WAVHeader = (
 
     nChannels: Word(2);
     nBitsPerSample: LongInt(16);
     nSamplesPerSec: LongInt(8000);
     nAvgBytesPerSec: LongInt(32000);
     RIFFSize: LongInt((MaxN + 1) * 2 * 2 + 36);
     fmtSize: LongInt(16);
     formatTag: Word(1);
     nBlockAlign: LongInt(4);
     DataSize: LongInt((MaxN + 1) * 2 * 2)
     );
 
   {================== Сканирование переменных сопровождения ===================}
 
 procedure ScaleData(var Kk: Observation);
 var
   I: SampleIndex;
 begin
 
   {Инициализация переменных сканирования}
   Kk.MaxO := Kk.yyy[0];
   Kk.MinO := Kk.yyy[0];
 
   {Сканирование для получения максимального и минимального значения}
   for I := 1 to Kk.Last do
   begin
     if Kk.MaxO < Kk.yyy[I] then
       Kk.MaxO := Kk.yyy[I];
     if Kk.MinO > Kk.yyy[I] then
       Kk.MinO := Kk.yyy[I];
   end;
 end; { ScaleData }
 
 procedure ScaleAllData;
 begin
 
   ScaleData(K0R);
   ScaleData(K0B);
   ScaleData(K1R);
   ScaleData(K1B);
   ScaleData(K2R);
   ScaleData(K2B);
   ScaleData(K3R);
   ScaleData(K3B);
 end; {ScaleAllData}
 
 {================== Считывание/запись WAV-данных ===================}
 
 var
   InFile, OutFile: file of Byte;
 
 type
   Tag = (F0, T1, M1);
 type
   FudgeNum = record
 
     case X: Tag of
       F0: (chrs: array[0..3] of Byte);
       T1: (lint: LongInt);
       M1: (up, dn: Integer);
   end;
 var
   ChunkSize: FudgeNum;
 
 procedure WriteChunkName(Name: string);
 var
   i: Integer;
 
   MM: Byte;
 begin
 
   for i := 1 to 4 do
   begin
     MM := ord(Name[i]);
     write(OutFile, MM);
   end;
 end; {WriteChunkName}
 
 procedure WriteChunkSize(LL: Longint);
 var
   I: integer;
 begin
 
   ChunkSize.x := T1;
   ChunkSize.lint := LL;
   ChunkSize.x := F0;
   for I := 0 to 3 do
     Write(OutFile, ChunkSize.chrs[I]);
 end;
 
 procedure WriteChunkWord(WW: Word);
 var
   I: integer;
 begin
 
   ChunkSize.x := T1;
   ChunkSize.up := WW;
   ChunkSize.x := M1;
   for I := 0 to 1 do
     Write(OutFile, ChunkSize.chrs[I]);
 end; {WriteChunkWord}
 
 procedure WriteOneDataBlock(var Ki, Kj: Observation);
 var
   I: Integer;
 begin
 
   ChunkSize.x := M1;
   with Ki.WAV do
   begin
     case nChannels of
       1: if nBitsPerSample = 16 then
         begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
           ChunkSize.up := trunc(Ki.yyy[N] + 0.5);
           if N < MaxN then
             ChunkSize.dn := trunc(Ki.yyy[N + 1] + 0.5);
           N := N + 2;
         end
         else
         begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
           for I := 0 to 3 do
             ChunkSize.chrs[I]
               := trunc(Ki.yyy[N + I] + 0.5);
           N := N + 4;
         end;
       2: if nBitsPerSample = 16 then
         begin {2 Двухканальный 16-битный сэмпл}
           ChunkSize.dn := trunc(Ki.yyy[N] + 0.5);
           ChunkSize.up := trunc(Kj.yyy[N] + 0.5);
           N := N + 1;
         end
         else
         begin {4 Двухканальный 8-битный сэмпл}
           ChunkSize.chrs[1] := trunc(Ki.yyy[N] + 0.5);
           ChunkSize.chrs[3] := trunc(Ki.yyy[N + 1] + 0.5);
           ChunkSize.chrs[0] := trunc(Kj.yyy[N] + 0.5);
           ChunkSize.chrs[2] := trunc(Kj.yyy[N + 1] + 0.5);
           N := N + 2;
         end;
     end; {with WAV do begin..}
   end; {четырехбайтовая переменная "ChunkSize" теперь заполнена}
 
   ChunkSize.x := T1;
   WriteChunkSize(ChunkSize.lint); {помещаем 4 байта данных}
 end; {WriteOneDataBlock}
 
 procedure WriteWAVFile(var Ki, Kj: Observation);
 var
   MM: Byte;
 
   I: Integer;
   OK: Boolean;
 begin
 
   {Приготовления для записи файла данных}
   AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }
   ReWrite(OutFile);
   with Ki.WAV do
   begin
     DataSize := nChannels * (nBitsPerSample div 8) * (Ki.Last + 1);
     RIFFSize := DataSize + 36;
     fmtSize := 16;
   end;
 
   {Записываем ChunkName "RIFF"}
   WriteChunkName('RIFF');
 
   {Записываем ChunkSize}
   WriteChunkSize(Ki.WAV.RIFFSize);
 
   {Записываем ChunkName "WAVE"}
   WriteChunkName('WAVE');
 
   {Записываем tag "fmt_"}
   WriteChunkName('fmt ');
 
   {Записываем ChunkSize}
   Ki.WAV.fmtSize := 16; {должно быть 16-18}
   WriteChunkSize(Ki.WAV.fmtSize);
 
   {Записываем  formatTag, nChannels}
   WriteChunkWord(Ki.WAV.formatTag);
   WriteChunkWord(Ki.WAV.nChannels);
 
   {Записываем  nSamplesPerSec}
   WriteChunkSize(Ki.WAV.nSamplesPerSec);
 
   {Записываем  nAvgBytesPerSec}
   WriteChunkSize(Ki.WAV.nAvgBytesPerSec);
 
   {Записываем  nBlockAlign, nBitsPerSample}
   WriteChunkWord(Ki.WAV.nBlockAlign);
   WriteChunkWord(Ki.WAV.nBitsPerSample);
 
   {Записываем метку блока данных "data"}
   WriteChunkName('data');
 
   {Записываем DataSize}
   WriteChunkSize(Ki.WAV.DataSize);
 
   N := 0; {первая запись-позиция}
   while N <= Ki.Last do
     WriteOneDataBlock(Ki, Kj); {помещаем 4 байта и увеличиваем счетчик N}
 
   {Освобождаем буфер файла}
   CloseFile(OutFile);
 end; {WriteWAVFile}
 
 procedure InitSpecs;
 begin
 end; { InitSpecs }
 
 procedure InitSignals(var Kk: Observation);
 var
   J: Integer;
 begin
 
   for J := 0 to MaxN do
     Kk.yyy[J] := 0.0;
   Kk.MinO := 0.0;
   Kk.MaxO := 0.0;
   Kk.Last := MaxN;
 end; {InitSignals}
 
 procedure InitAllSignals;
 begin
   InitSignals(K0R);
   InitSignals(K0B);
   InitSignals(K1R);
   InitSignals(K1B);
   InitSignals(K2R);
   InitSignals(K2B);
   InitSignals(K3R);
   InitSignals(K3B);
 end; {InitAllSignals}
 
 var
   ChunkName: string[4];
 
 procedure ReadChunkName;
 var
   I: integer;
 
   MM: Byte;
 begin
 
   ChunkName[0] := chr(4);
   for I := 1 to 4 do
   begin
     Read(InFile, MM);
     ChunkName[I] := chr(MM);
   end;
 end; {ReadChunkName}
 
 procedure ReadChunkSize;
 var
   I: integer;
 
   MM: Byte;
 begin
 
   ChunkSize.x := F0;
   ChunkSize.lint := 0;
   for I := 0 to 3 do
   begin
     Read(InFile, MM);
     ChunkSize.chrs[I] := MM;
   end;
   ChunkSize.x := T1;
 end; {ReadChunkSize}
 
 procedure ReadOneDataBlock(var Ki, Kj: Observation);
 var
   I: Integer;
 begin
 
   if N <= MaxN then
   begin
     ReadChunkSize; {получаем 4 байта данных}
     ChunkSize.x := M1;
     with Ki.WAV do
       case nChannels of
         1: if nBitsPerSample = 16 then
           begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
             Ki.yyy[N] := 1.0 * ChunkSize.up;
             if N < MaxN then
               Ki.yyy[N + 1] := 1.0 * ChunkSize.dn;
             N := N + 2;
           end
           else
           begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
             for I := 0 to 3 do
               Ki.yyy[N + I] := 1.0 * ChunkSize.chrs[I];
             N := N + 4;
           end;
         2: if nBitsPerSample = 16 then
           begin {2 Двухканальный 16-битный сэмпл}
             Ki.yyy[N] := 1.0 * ChunkSize.dn;
             Kj.yyy[N] := 1.0 * ChunkSize.up;
             N := N + 1;
           end
           else
           begin {4 Двухканальный 8-битный сэмпл}
             Ki.yyy[N] := 1.0 * ChunkSize.chrs[1];
             Ki.yyy[N + 1] := 1.0 * ChunkSize.chrs[3];
             Kj.yyy[N] := 1.0 * ChunkSize.chrs[0];
             Kj.yyy[N + 1] := 1.0 * ChunkSize.chrs[2];
             N := N + 2;
           end;
       end;
     if N <= MaxN then
     begin {LastN    := N;}
       Ki.Last := N;
       if Ki.WAV.nChannels = 2 then
         Kj.Last := N;
     end
     else
     begin {LastN    := MaxN;}
       Ki.Last := MaxN;
       if Ki.WAV.nChannels = 2 then
         Kj.Last := MaxN;
 
     end;
   end;
 end; {ReadOneDataBlock}
 
 procedure ReadWAVFile(var Ki, Kj: Observation);
 var
   MM: Byte;
 
   I: Integer;
   OK: Boolean;
   NoDataYet: Boolean;
   DataYet: Boolean;
   nDataBytes: LongInt;
 begin
 
   if FileExists(StandardInput) then
     with Ki.WAV do
     begin { Вызов диалога открытия файла }
       OK := True; {если не изменится где-нибудь ниже}
       {Приготовления для чтения файла данных}
       AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }
       Reset(InFile);
 
       {Считываем ChunkName "RIFF"}
       ReadChunkName;
       if ChunkName <> 'RIFF' then
         OK := False;
 
       {Считываем ChunkSize}
       ReadChunkSize;
       RIFFSize := ChunkSize.lint; {должно быть 18,678}
 
       {Считываем ChunkName "WAVE"}
       ReadChunkName;
       if ChunkName <> 'WAVE' then
         OK := False;
 
       {Считываем ChunkName "fmt_"}
       ReadChunkName;
       if ChunkName <> 'fmt ' then
         OK := False;
 
       {Считываем ChunkSize}
       ReadChunkSize;
       fmtSize := ChunkSize.lint; {должно быть 18}
 
       {Считываем  formatTag, nChannels}
       ReadChunkSize;
       ChunkSize.x := M1;
       formatTag := ChunkSize.up;
       nChannels := ChunkSize.dn;
 
       {Считываем  nSamplesPerSec}
       ReadChunkSize;
       nSamplesPerSec := ChunkSize.lint;
 
       {Считываем  nAvgBytesPerSec}
       ReadChunkSize;
       nAvgBytesPerSec := ChunkSize.lint;
 
       {Считываем  nBlockAlign}
       ChunkSize.x := F0;
       ChunkSize.lint := 0;
       for I := 0 to 3 do
       begin
         Read(InFile, MM);
         ChunkSize.chrs[I] := MM;
       end;
       ChunkSize.x := M1;
       nBlockAlign := ChunkSize.up;
 
       {Считываем  nBitsPerSample}
       nBitsPerSample := ChunkSize.dn;
       for I := 17 to fmtSize do
         Read(InFile, MM);
 
       NoDataYet := True;
       while NoDataYet do
       begin
         {Считываем метку блока данных "data"}
         ReadChunkName;
 
         {Считываем DataSize}
         ReadChunkSize;
         DataSize := ChunkSize.lint;
 
         if ChunkName <> 'data' then
         begin
           for I := 1 to DataSize do
             {пропуск данных, не относящихся к набору звуковых данных}
             Read(InFile, MM);
         end
         else
           NoDataYet := False;
       end;
 
       nDataBytes := DataSize;
       {Наконец, начинаем считывать данные для байтов nDataBytes}
       if nDataBytes > 0 then
         DataYet := True;
       N := 0; {чтение с первой позиции}
       while DataYet do
       begin
         ReadOneDataBlock(Ki, Kj); {получаем 4 байта}
         nDataBytes := nDataBytes - 4;
         if nDataBytes <= 4 then
           DataYet := False;
       end;
 
       ScaleData(Ki);
       if Ki.WAV.nChannels = 2 then
       begin
         Kj.WAV := Ki.WAV;
         ScaleData(Kj);
       end;
       {Освобождаем буфер файла}
       CloseFile(InFile);
     end
   else
   begin
     InitSpecs; {файл не существует}
     InitSignals(Ki); {обнуляем массив "Ki"}
     InitSignals(Kj); {обнуляем массив "Kj"}
   end;
 end; { ReadWAVFile }
 
 {================= Операции с набором данных ====================}
 
 const
   MaxNumberOfDataBaseItems = 360;
 type
   SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;
 
 var
   DataBaseFile: file of Observation;
 
   LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}
   ItemNameS: array[SignalDirectoryIndex] of string[40];
 
 procedure GetDatabaseItem(Kk: Observation; N: LongInt);
 begin
 
   if N <= LastDataBaseItem then
   begin
     Seek(DataBaseFile, N);
     Read(DataBaseFile, Kk);
   end
   else
     InitSignals(Kk);
 end; {GetDatabaseItem}
 
 procedure PutDatabaseItem(Kk: Observation; N: LongInt);
 begin
 
   if N < MaxNumberOfDataBaseItems then
     if N <= LastDataBaseItem then
     begin
       Seek(DataBaseFile, N);
       Write(DataBaseFile, Kk);
       LastDataBaseItem := LastDataBaseItem + 1;
     end
     else
       while LastDataBaseItem <= N do
       begin
         Seek(DataBaseFile, LastDataBaseItem);
         Write(DataBaseFile, Kk);
         LastDataBaseItem := LastDataBaseItem + 1;
       end
   else
     ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}
 end; {PutDatabaseItem}
 
 procedure InitDataBase;
 begin
 
   LastDataBaseItem := 0;
   if FileExists(StandardDataBase) then
   begin
     Assign(DataBaseFile, StandardDataBase);
     Reset(DataBaseFile);
     while not EOF(DataBaseFile) do
     begin
       GetDataBaseItem(K0R, LastDataBaseItem);
       ItemNameS[LastDataBaseItem] := K0R.Name;
       LastDataBaseItem := LastDataBaseItem + 1;
     end;
     if EOF(DataBaseFile) then
       if LastDataBaseItem > 0 then
         LastDataBaseItem := LastDataBaseItem - 1;
   end;
 end; {InitDataBase}
 
 function FindDataBaseName(Nstg: string): LongInt;
 var
   ThisOne: LongInt;
 begin
 
   ThisOne := 0;
   FindDataBaseName := -1;
   while ThisOne < LastDataBaseItem do
   begin
     if Nstg = ItemNameS[ThisOne] then
     begin
       FindDataBaseName := ThisOne;
       Exit;
     end;
     ThisOne := ThisOne + 1;
   end;
 end; {FindDataBaseName}
 
 {======================= Инициализация модуля ========================}
 
 procedure InitLinearSystem;
 begin
 
   BaseFileName := '\PROGRA~1\SIGNAL~1\';
   StandardOutput := BaseFileName + 'K0.wav';
   StandardInput := BaseFileName + 'K0.wav';
 
   StandardDataBase := BaseFileName + 'Radar.sdb';
 
   InitAllSignals;
   InitDataBase;
   ReadWAVFile(K0R, K0B);
   ScaleAllData;
 end; {InitLinearSystem}
 
 begin {инициализируемый модулем код}
 
   InitLinearSystem;
 end. {Unit LinearSystem}
 




Разукрасьте Ваше приложение (Skins)


Открылся благотворительный фонд сбора средств на новый Boening 747 для глобальной реконструкции здания Microsoft.

SkinForm - это компонент, который поможет Вам создать "не-квадратное" окно и вто же время применить к нему так называемую технологию "skin", наподобие таких популярных программ как WinAMP, WPlay ..., зачем тратить часы на программирование, когда это можно сделать за пару минут! Скачать сам компонент можно с http://www.qwerks.com/download.asp?ProductID=2447. WYSIWYG скин билдер, который входит в состав архива, предназначен для создания информационного файла, описывающего структуру нашей формы. Всё, что надо сделать - это создать несколько картинок, и нарисовать кнопки, текстовые поля и т.д.. Есть возможность постоянно смотреть превью!

Теперь посмотрим, какие нам предоставлены возможности:

  • поддержка файлов bmp и jpeg
  • поддержка графических кнопок, а так же переключающиеся и радои кнопки
  • поддержка текста, графического текста и цифр
  • поддержка графического track bar
  • поддержка multi skin-ов, то есть Вы можете создать свой скин для каждой формы приложения
  • поддержка внутренних скинов, то есть скины могут быть сохранены в ресурсном файле

Теперь наши действия:

  • Создаём bitmap файлы для скина
  • Запускаем Skin Builder для создания информационного файла
  • Создаём новый проект.
  • Помещаем компонент TSkinForm в форму
  • Компилируем

Посмотрим на script файл, созданный SkinBuilder-ом:


 [VERSION]
 Ver=210 // Версия скин-файла 
 
 [BITMAPINFO]
 MaskBitmap=PlayerMask.bmp
 // Bitmap файл маски поверхности формы 
 MouseUpBitmap=PlayerMain.jpg
 // Bitmap файл, если кнопка мыши была отпущена 
 MouseDownBitmap=PlayerSel.jpg
 // Bitmap файл, если кнопка мыши была нажата 
 MouseOnBitmap=PlayerSel.jpg
 // Bitmap файла, если на объекте находится курсор мыши 
 NumbersBitmap=
 // Bitmap файл для графических цифр (не обязательно)
 TextBitmap=
 // Bitmap файл для графического текста (не обязательно) 
 
 [HOTAREAINFO]
 Count=19 // Общее количество кнопок 
 // Описание каждой кнопки 
 // number=ID, top, left, width, height, hint [, button state, group name] 
 // Значения в [ ] не обязательны 
 1=BUTTON_PLAY, 54, 165, 34, 35, Play/Pause
 2=BUTTON_STOP, 129, 165, 19, 35, Stop
 3=BUTTON_NEXT, 90, 165, 18, 17, Next
 4=BUTTON_PREV, 109, 165, 18, 17, Previous
 ...
 
 [DISPLAYINFO]
 Charset=1 // Charset текстовой области 
 Count=3 // количество тектовых полей 
 // Описание каждой текстовой области 
 // number=ID, font name, bold, italic, size, color, top, left, style, default text, hint, width, height 
 1=TEXT_LEN, Arial, TRUE, FALSE, 9, $00366835, 116, 137, Normal, [00:00], Length, 51, 18
 2=TEXT_POS, Arial, TRUE, FALSE, 12, $00366835, 55, 133, Normal, 00:00, Position, 52, 23
 3=TEXT_SONG, MS Sans Serif, FALSE, FALSE, 7, $00366835, 56, 112, Normal, Song name, Song name, 111, 21
 
 [TRACKBARINFO]
 Count=2 // Количество track-баров 
 // Описание каждого трак-бара 
 // number=ID, trackbar bitmap file, trackbar bitmap file, top, left, length, style, position, hint 
 1=TRACKBAR_VOLUME, TrackBar.BMP, TrackBar.BMP, 79, 205, 88, H, 65, Volume
 2=TRACKBAR_POS, TrackBar.BMP, TrackBar.BMP, 79, 217, 88, H, 0, Time
 

Ну вот Ваше приложение и разукрасилось и, как видите, безо всякого программирования.

Теперь можно добавить код, чтобы перехватывать события на кнопках - MouseUp, Down, Over ...

Далее следует пример кода:


 ...
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   //Загружаем скин файл
   SkinForm1.LoadDefaultSkin;
   SkinForm1.SetDisplayText('VOLUME', IntToStr(SkinForm1.GetTrackBarPos('TRACKBAR_VOLUME')));
   SkinForm1.SetDisplayText('TIME', IntToStr(SkinForm1.GetTrackBarPos('TRACKBAR_POS')));
   SkinForm1.SetTrackBarMinMax('TRACKBAR_VOLUME', 20, 80);
 end;
 
 procedure TForm1.SkinForm1MouseUpNotify(ID: string; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 var
   pos: TPoint;
 begin
   if (Button = mbLeft) then
   begin
     if ID = 'BUTTON_EXIT' then
       Close;
     if ID = 'BUTTON_MINIMIZE' then
       Form1.Perform(WM_SYSCOMMAND, SC_MINIMIZE, 0);
 
     if ID = 'BUTTON_MENU' then
     begin
       pos := ClientToScreen(Point(X, Y));
       PopupMenu1.Popup(pos.x, pos.y);
     end;
   end;
 
   if (Button = mbRight) then
   begin
     pos := ClientToScreen(Point(X, Y));
     PopupMenu1.Popup(pos.x, pos.y);
   end;
 
 ...
 




Убывающий индекс

Я нашел простой способ получения убывающего индекса. В Delphi это получается очень легко и красиво:


 Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);
 




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

Передайте данной функции любую десятичную величину (1...3999), и она возвратит строку, содержащую точное значение в римской транскрипции.


 function DecToRoman(Decimal: LongInt): string;
 const
   Romans: array[1..13] of string =
   ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
 
   Arabics: array[1..13] of Integer =
   (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
 var
   i: Integer;
   scratch: string;
 begin
   scratch := '';
   for i := 13 downto 1 do
     while (Decimal >= Arabics[i]) do
     begin
       Decimal := Decimal - Arabics[i];
       scratch := scratch + Romans[i];
     end;
   Result := scratch;
 end;
 




Определить SMTP сервер по умолчанию

Юзер за дедку, дедка за тоссер, тоссер за мэйлер - и отослали мессаж!


 {
   Here is some code I successfully used te determine
   the DEFAULT mailaccount, which is used in
   Outlook Express, to send outgoing mail via SMTP.
 }
 
 procedure TForm1.ReadRegistryDefaults;
 var
   Registry: TRegistry;
   AccountStr: string;
 begin
   Registry := TRegistry.Create;
   try
     Registry.RootKey := hkey_CURRENT_USER;
     if Registry.OpenKey('software\microsoft\internet account manager', False) then  {}
     begin
       AccountStr := Registry.ReadString('default mail account');
       Registry.CloseKey;
       if (AccountStr <> '') then
         if Registry.OpenKey('software\microsoft\internet account manager\accounts\' +
           AccountStr, False) then  {}
         begin
           Edit_Server.Text  := Registry.ReadString('SMTP Server');
           Edit_Account.Text := Registry.ReadString('SMTP Email Address');
           Registry.CloseKey;
         end;
     end;
   finally
     Registry.Free;
   end;
 end;
 




Как узнать язык Windows по умолчанию

Сына программера спрашивают на уроке:
- Вася, расскажи нам, пожалуйста, русский алфавит.
- Й, Ц, У, К, Е, Н...


 GetSystemDefaultLangID
 GetSystemDefaultLCID
 GetLocaleInfo
 




Демонстрация DefineProperties

Автор: Mike Scott(Mobius Ltd.)

Хорошо, создайте на основе опубликованного ниже кода модуль PropDemo.pas и добавьте новый компонент в палитру компонентов. Расположите его на форме и сохраните ее. Затем посмотрите файл DFM каким-либо шестнадцатиричным редактором и проверьте наличие определенных свойств по их именнованным тэгам. Вы можете также попробовать закрыть форму и модуль, а затем открыть его с помощью пункта меню File | Open file..., изменив тип файла в выпадающем списке на *.DFM.

Удачи!


 unit PropDemo;
 
 { Демонстрация DefineProperties.
 
 Mike Scott, CIS 100140,2420. }
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
   TDemoProps = class(TComponent)
   private
     { Private declarations }
     FStringThing: string;
     FThing: record
       i, j, k: integer;
       x, y: real;
       ch: char;
     end;
     procedure ReadStringThing(Reader: TReader);
     procedure WriteStringThing(Writer: TWriter);
     procedure ReadThing(Stream: TStream);
     procedure WriteThing(Stream: TStream);
   protected
     { Protected declarations }
     procedure DefineProperties(Filer: TFiler); override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 constructor TDemoProps.Create(AOwner: TComponent);
 
 begin
   inherited Create(AOwner);
 
   { создайте любые данные, чтобы было что передать в поток}
   FStringThing := 'Всем привет!';
   with FThing do
   begin
     i := 1;
     j := 2;
     k := 3;
     x := PI;
     y := 180 / PI;
     ch := '?';
   end;
 end;
 
 procedure TDemoProps.ReadStringThing(Reader: TReader);
 
 begin
   FStringThing := Reader.ReadString;
 end;
 
 procedure TDemoProps.WriteStringThing(Writer: TWriter);
 
 begin
   Writer.WriteString(FStringThing);
 end;
 
 procedure TDemoProps.ReadThing(Stream: TStream);
 
 begin
   Stream.ReadBuffer(FThing, sizeof(FThing));
 end;
 
 procedure TDemoProps.WriteThing(Stream: TStream);
 
 begin
   Stream.WriteBuffer(FThing, sizeof(FThing));
 end;
 
 procedure TDemoProps.DefineProperties(Filer: TFiler);
 
 begin
   inherited DefineProperties(Filer);
   Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
     FStringThing <> '');
   Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TDemoProps]);
 end;
 
 end.
 




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

Автор: Mike Scott(Mobius Ltd.)

Итак вам опять нужно "немного" кода. Вот небольшой примерчик компонента лично для вас и остальных моих читателей. Установите этот компонент в палитру Delphi, бросьте экземпляр на форму, закройте ее и модуль и откройте форму как файл формы, используя в диалоге открытия тип *.dfm. Вы увидите дополнительные свойства 'StringThing' и 'Thing'. Первое - свойство строки, второе - бинарное свойство, фактически запись. Если вы имеете HexEdit (шестнадцатиричный редактор) или что-то аналогичное, взгляните на ваш dfm-файл и вы увидите тэги ваших новых свойств вместе с их именами.

Если TReader/TWriter имеет специфические методы для чтения/записи свойств и вы хотите добавить, например, строку, целое, символ или что-то еще (проверьте описание соответствующих методов TReader в файлах помощи), то в этом случае используйте DefineProperty. В случае сложного объекта используйте DefineBinaryProperty и ваши методы чтения и записи получат TStream вместо TReader/TWriter.


 unit PropDemo;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
   TDemoProps = class(TComponent)
   private
     { Private declarations }
     FStringThing: string;
     FThing: record
       i, j, k: integer;
       x, y: real;
       ch: char;
     end;
     procedure ReadStringThing(Reader: TReader);
     procedure WriteStringThing(Writer: TWriter);
     procedure ReadThing(Stream: TStream);
     procedure WriteThing(Stream: TStream);
   protected
     { Protected declarations }
     procedure DefineProperties(Filer: TFiler); override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
   end;
 
 procedure Register;
 
 implementation
 
 constructor TDemoProps.Create(AOwner: TComponent);
 
 begin
   inherited Create(AOwner);
 
   { создайте любые данные, чтобы было что передать в поток}
   FStringThing := 'Всем привет!';
   with FThing do
   begin
     i := 1;
     j := 2;
     k := 3;
     x := PI;
     y := 180 / PI;
     ch := '?';
   end;
 end;
 
 procedure TDemoProps.ReadStringThing(Reader: TReader);
 
 begin
   FStringThing := Reader.ReadString;
 end;
 
 procedure TDemoProps.WriteStringThing(Writer: TWriter);
 
 begin
   Writer.WriteString(FStringThing);
 end;
 
 procedure TDemoProps.ReadThing(Stream: TStream);
 
 begin
   Stream.ReadBuffer(FThing, sizeof(FThing));
 end;
 
 procedure TDemoProps.WriteThing(Stream: TStream);
 
 begin
   Stream.WriteBuffer(FThing, sizeof(FThing));
 end;
 
 procedure TDemoProps.DefineProperties(Filer: TFiler);
 
 begin
   inherited DefineProperties(Filer);
   Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
     FStringThing <> '');
   Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TDemoProps]);
 end;
 
 end.
 




Как удалить BDE таблицу

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


  uses
    DB, DBTables, DbiProcs, DbiErrs, DbiTypes;
 
  procedure DeleteTable(Dir, TblName: String);
  var
    DBHandle: HDBIDB;
    ResultCode: DBIResult;
    tbl, Err: Array[0..255] of Char;
    SrcTbl: TTable;
  begin
    SrcTbl := TTable.Create(Application);
    try
      SrcTbl.DatabaseName := Dir;
      SrcTbl.TableName := TblName;
      SrcTbl.Open;
      DBHandle := SrcTbl.DBHandle;
      SrcTbl.Close;
      ResultCode := DbiDeleteTable(DBHandle,
        StrPCopy(Tbl,Dir + '\' + TblName), nil);
      if ResultCode <> DBIERR_NONE then
      begin
        DbiGetErrorString(ResultCode,Err);
        raise EDatabaseError.Create('While deleting ' +
          Dir + '\' + TblName + ', the database ' +
          'engine generated the error ''' + StrPas(Err) + '''');
      end;
    finally
      SrcTbl.Free;
    end;
  end;
 




Определение удаления записей в .DBF

Взято из "Dtopics Database 1.10 from 3K computer Consultancy":

Dbase в BDE имеет большее количество ситуаций 'особого случая', чем таблицы SQL и Paradox, поскольку данный формат поддерживает выражения в индексах и прочие характеристики, например:

  1. Создание и пересоздание индекса

  2.  DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }
     

    создание индекса (зависит от того, существует ли выражение или нет)


     if (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then
       Table1.AddIndex( cTagName, cTagExp, [ixExpression])  {<- ixExpression - _литерал_}
     else
       Table1.AddIndex( cTagName, cTagExp, []);
     

  3. Связки Master/Detail в выражениях дочерних индексов

    вызов процедуры BDE DbiLinkDetailToExp() вместо обычной DbiLinkDetail()

  4. Пакование таблиц

  5.  with Table1 do
     StrPCopy( TName, TableName );
     Result := DBIPackTable( DbHandle, Handle, TName, szDBASE, TRUE );
     

  6. Задание видимости удаленных записей - вкл/выкл (например, dBase SET DELETED ON/OFF)

  7.  DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue));
     

  8. Задание частичного/полного соответствия символов - вкл/выкл (например, dBase SET EXACT ON/OFF)

  9.  DbiSetProp( hDBIObj(Table1.Handle), curINEXACTON,   LongInt(bValue));
     

Ну и теперь сами вопросы:

Как мне увидеть записи dBASE, помеченные для удаления?"

В обработчике события AfterOpen вызовите приведенную ниже функцию. Включите DBITYPES, DBIERRS, DBIPROCS в список используемых модулей. Для вызова функции передайте ей в качестве аргумента имя TTable и TRUE/FALSE в зависимости от необходимости показа/скрытия удаленных записей. Пример:


 procedure TForm1.Table1AfterOpen(DataSet: TDataset);
 begin
   SetDelete(Table1, TRUE);
 end;
 
 procedure SetDelete(oTable: TTable; Value: Boolean);
 var
   rslt: DBIResult;
   szErrMsg: DBIMSG;
 begin
   try
     Table.DisableControls;
     try
       rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,
         LongInt(Value));
       if rslt <> DBIERR_NONE then
       begin
         DbiGetErrorString(rslt, szErrMsg);
         raise Exception.Create(StrPas(szErrMsg));
       end;
     except
       on E: EDBEngineError do
         ShowMessage(E.Message);
       on E: Exception do
         ShowMessage(E.Message);
     end;
   finally
     Table.Refresh;
     Table.EnableControls;
   end;
 end;
 

"Могу ли я создать в табличной сетке колонку, в которой будут показываться записи, помеченные для удаления из таблицы dBASE?"

Создайте вычисляемое поле, затем в обработчике события таблицы OnCalcField замените его таким образом:


 procedure TForm1.Table1CalcFields(DataSet: TDataset);
 var
   RCProps : RecProps;
   Result : DBIResult;
 begin
   Result := DbiGetRecord(Table1.Handle, dbiNo
 

Рукописи не горят...




Удалить каталог со всем содержимым



 function DeleteDir(Dir: string): boolean;
 var
   Found: integer;
   SearchRec: TSearchRec;
 begin
   result := false;
   if IOResult <> 0 then
     ChDir(Dir);
   if IOResult <> 0 then
   begin
     ShowMessage('Не могу войти в каталог: ' + Dir);
     exit;
   end;
   Found := FindFirst('*.*', faAnyFile, SearchRec);
   while Found = 0 do
   begin
     if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
       if (SearchRec.Attr and faDirectory) <> 0 then
       begin
         if not DeleteDir(SearchRec.name) then
           exit;
         end
         else
           if not DeleteFile(SearchRec.name) then
           begin
             ShowMessage('Не могу удалить файл: ' + SearchRec.name);
             exit;
           end;
         Found := FindNext(SearchRec);
       end;
   FindClose(SearchRec);
   ChDir('..');
   RmDir(Dir);
   result := IOResult = 0;
 end;
 




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



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



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


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