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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Избавление от системного окна с ошибкой

Автор: Neil J. Rubenking

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

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


 SetErrorMode(SEM_FAILCRITICALERRORS);
 

Это все! Эта функция сообщает Windows о том, что вызвавшая ошибку программа будет сама обрабатывать критические ошибки.




Убрать из формы Caption


 SetWindowLong(Form1.Handle, GWL_STYLE, GWL_STYLE and not WS_CAPTION or WS_SIZEBOX);
 




Снять иконку соединения с интернет из Tray

- Между моей девочкой и Интернетом есть много общего.
- Ага, пользователей много.


 uses
   shellapi;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   nt: TNotifyIconData;
 begin
   with nt do
   begin
     cbSize := SizeOf(nt);
     Wnd    := FindWindow('#32770', nil);
     uid    := 0;
     uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
     uCallbackMessage := WM_USER + 17;
     hIcon  := 0;
     szTip  := '';
   end;
   Shell_NotifyIcon(NIM_DELETE, @nt);
 end;
 




Убрать программу из списка Ctrl+Alt+Delete


- Что самое главное для программиста, собирающегося провести ночь с подругой?
- Чтобы система не повисла.
- А если все-таки повиснет?
- Ну тогда как всегда, тремя пальцами.

Конечно, отключить Ctrl+Alt+Del - это круто, но пользователь сразу догадается, что кто-то у него побывал в гостях с нечистыми намерениями, а если вы хотите всё делать "под покровом темноты", то наилучший способ просто убрать прогу из списка

Например, по созданию окна. Для этого до слова implementation вписываем следующую функцию:


 function RegisterServiceProcess(dwProcessID, dwType: integer): integer;
 stdcall; external 'KERNEL32.DLL';
 

А на создание окна код будет выглядеть так:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   if not(csDesigning in ComponentState) then
     RegisterServiceProcess(GetCurrentProcessID, 1);
 end;
 

Ну вот и всё, а если вам понадобится сделать прогу видимой, тогда сделаем это так:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if not(csDesigning in ComponentState) then
     RegisterServiceProcess(GetCurrentProcessID, 0);
 end;
 




Если нет модуля Math

Автор: Марк Шевченко

Здравствуйте.

Тут открыл кое-что, возможно, давным давно всем известное. :) Поделюсь на всякий случай.

Сначала немного о корнях проблемы. Не секрет, что в Delphi модуль Math поставляется только с Enterprise-версией программы. А платить больше тысячи долларов только за то, чтобы воспользоваться парой функций совсем не хочется (мне, например, простенькой atan2 часто не хватало).

Простым решением является "заимствование" модуля Math из пиратской Enterpise-версии, но это, вообще-то, воровство. Самому же создавать матеатическую библитеку с нуля - занятие неблагодарное (по крайней мере достаточно трудоёмкое).

Не работая плотно на MSVC я как-то был не в курсе наличия библиотеки crtdll.dll в Windows (насколько мне удалось выяснить, она таки является частью операционной системы, по крайней мере ставится вместе с Windows 9x/NT/2000). С её помощью можно решить указанную проблему, воспользовавшись готовым решением, а именно - объявить все необходые функции из math.h в своей программе и наслаждаться. :)

Пример с atan2:


 function atan2(x, y: Double): Double; stdcall;
   external 'crtdll.dll' name 'atan2';
 

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

Да, в crtdll.dll много фукнций, не связанных с математикой, в частности, если вы в программе используете PChar, то можно воспользоваться набором сишных strcmp, strcpy..., так же доступны isalpha, isdigit..., и, наконец, bsearch и qsort. :)




Как убрать заголовок в дочерней форме MDI

Если в дочерней форме MDI установить BorderStyle в bsNone, то заголовок формы не исчезнет. (Об этом сказано в хелпе). А вот следующий пример решает эту проблему:


 type
   ... = class(TForm)
   { other stuff above }
   procedure CreateParams(var Params: TCreateParams); override;
   { other stuff below }
 end;
 
 ...
 
 procedure tMdiChildForm.CreateParams(var Params: tCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := Params.Style and (not WS_CAPTION);
 end;
 




Как убрать заголовок в дочерней форме MDI 2


 type
   TForm2 = class(TForm)
     { другой код выше }
     procedure CreateParams(var Params: TCreateParams); override;
     { другой код ниже }
   end;
 
 procedure TForm2.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER
 end;
 




Спрятать Min и Max кнопки на форме


 procedure TForm1.FormCreate(Sender: TObject);
 var
   l: DWORD;
 begin
   l := GetWindowLong(Self.Handle, GWL_STYLE);
   l := l and not (WS_MINIMIZEBOX);
   l := l and not (WS_MAXIMIZEBOX);
   l := SetWindowLong(Self.Handle, GWL_STYLE, l);
 end;
 




Отключить реакцию на события мыши

Автор: KDenis

Звонок:
- У вас мыши есть?
- Нет...
- А когда будут?
- Не знаю...
- Это 'Демос'?
- Нет, квартира...


 procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
   var Handled: Boolean);
 begin
   Handled := (msg.wParam = vk_lButton) or
              (msg.wParam = vk_rButton) or
              (msg.wParam = vk_mButton);
 end;
 




Предотвратить появление окошко ввода пароля для Paradox таблицы

Вопрос:
- Почему в UNIX процедура входа называется "login", а в Winodows - "logon"?
Ответ:
- Ну, знаете ли, это от позы зависит.

Как мне при соединении с таблицей Paradox устранить/"удовлетворить" окошко с требованием ввести пароль, защищающей таблицу?

Свойство компонента Table ACTIVE должно быть установлено в FALSE. (Если она активна прежде, чем вы ввели пароль, вы получите это окошко.) Затем поместите следующий код в обработчике события формы OnCreate:


 session.AddPassword('Мой секретный пароль');
 table1.active := true;
 




Отключить команду Завершение работы

Предлагается к продаже "Соборъ" - надёжная помощь в комплексной автоматизации вашего прихода. Компьютер "Соборъ" - это:
- кадило и сокадило на 450 MHz
- оперативная паперть, расширяемая до 128 меганищих
- 15-ти дюймовый SVGA алтарь (на складе имеются 17-ти и 21 дюймовые модели)
- жесткий несъёмный крест
- кружка двухщелевая типа "На восстановление храма"
- круглый принтер для пасхальных яиц
- клавиатура со старославянским шрифтом и раскладкой
По желанию заказчика может быть установлено следующее лицензионное ПО:
- Старый Завет 7.0 и Новый Завет 98
- Слово Господне 2000
- 1С: Исповедальня (с сохранением тайны исповеди и выводом на широкий принтер)
Так же наша организация подключит ваш компьютер через выделенную линии к Верховному Провайдеру.


 uses
   Registry;
 ...
 procedure TForm1.Button1Click(Sender: TObject);
 var
   a: TRegistry;
 begin
   a := TRegistry.create;
   with a do
   begin
     RootKey := HKEY_CURRENT_USER;
     OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer', true);
     WriteInteger('NoClose', 1);
     CloseKey;
     Free;
   end;
 end;
 




Как убрать всплывающие подсказки в TreeView

Автор: Eugene Mayevski

TCustomTreeView.WMNotify. О том, что такое тип notify'а TTM_NEEDTEXT пpочтешь в хелпе. Убpать хинты можно, пеpекpыв обpаботчик для этого уведомительного сообщения.




Занесение сообшения в EventLog

Автор: Alex V. Novikov

Черт гуляет по чистилищу. В 1-ю дверь заходит, там крики, кого-то плетью хлещут. Во 2-ю заходит, там кого-то в котле варят. Заходит в 3-ю, там сидит за компьютером какой-то мужичок, тишина, спокойствие. Черт в недоумении бежит к Дьяволу.
- Чего там за такое?
- А, это? Да это Билл Гейтс. Его приговили программы для "Линукса" писать!!!

Я постоянно читаю конференции по дельфи и частенько встечается вопрос как занести свое сообщение в EventLog Windows NT. Недавно покопавшись в исходниках VCL я обнаружил такой интересный класс:


 Unit SvcMgr;
 {--Skip--}
 { TEventLogger }
 TEventLogger = class(TObject)
   private
     FName: String;
     FEventLog: Integer;
   public
     constructor Create(Name: String);
     destructor Destroy; override;
     procedure LogMessage(Message: String; EventType: DWord = 1;
       Category: Word = 0; ID: DWord = 0);
   end;
 {--Skip--}
 

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

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


 with TEventLogger.Create('My Application') do
   try
     LogMessage('Страшенная ошибка');
   finally
     Free;
   end;
 

P.S. надеюсь это кому нибудь поможет




Ограничение TEdit на ввод не-цифровой информации

Автор: Михаил Шпанер

Встречаются три операционных системы:
- PC-DOS. Version 7.
- OS/2. Version 4. Merlin.
- А я Windows... Просто Windows.

Посылаю Вам несколько расширенный вариант числовой маски компонента TЕdit c помощью OnKeyPress. В отличие от имеющегося в "Советах", приведенный код не "запирает" поле ввода при заполнении десятичной части, преобразует точку в запятую (для удобства пользователя), не позволяет поставить десятичную запятую перед числом и позволяет стирать знаки в поле ввода клавишей 'Back Space'. Код проверен в Delphi 5.


 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 var //цифровая маска
   vrPos, vrLength, vrSelStart: byte;
 const
   I: byte = 1;
     //I+1 = количество знаков после запятой (в данном случае - 2 знака)
 begin
 
   with Sender as TEdit do
   begin
     vrLength := Length(Text); //определяем длину текста
     vrPos := Pos(',', Text); //проверяем наличие запятой
     vrSelStart := SelStart; //определяем положение курсора
   end;
 
   case Key of
 
     '0'..'9':
       begin
         //проверяем положение курсора и количество знаков после запятой
         if (vrPos > 0) and (vrLength - vrPos > I) and (vrSelStart >= vrPos) then
           Key := #0; //"погасить" клавишу
       end;
     ',', '.':
       begin
         //если запятая уже есть или запятую пытаются поставить перед
         //числом или никаких цифр в поле ввода еще нет
         if (vrPos > 0) or (vrSelStart = 0) or (vrLength = 0) then
           Key := #0 //"погасить" клавишу
         else
           Key := #44; //всегда заменять точку на запятую
       end;
     #8: ; //позволить удаление знаков клавишей 'Back Space'
   else
     Key := #0; //"погасить" все остальные клавиши
   end;
 end;
 




Получить числа из строки


 type
   TCharSet = set of Char;
 
 function StripNonConforming(const S: string;
   const ValidChars: TCharSet): string;
 var
   DestI: Integer;
   SourceI: Integer;
 begin
   SetLength(Result, Length(S));
   DestI := 0;
   for SourceI := 1 to Length(S) do
     if S[SourceI] in ValidChars then
     begin
       Inc(DestI);
       Result[DestI] := S[SourceI]
     end;
   SetLength(Result, DestI)
 end;
 
 function StripNonNumeric(const S: string): string;
 begin
   Result := StripNonConforming(S, ['0'..'9'])
 end;
 




Поpазpядная цифpовая соpтиpовка

Поpазpядная цифpовая соpтиpовка. Алгоpитм тpебyет пpедстав- ления ключей соpтиpyемой последовательности в виде чисел в неко- тоpой системе счисления P. Число пpоходов соpтиpовка pавно макси- мальномy числy значащих цифp в числе - D. В каждом пpоходе анали- зиpyется значащая цифpа в очеpедном pазpяде ключа, начиная с младшего pазpяда. Все ключи с одинаковым значением этой цифpы объединяются в однy гpyппy. Ключи в гpyппе pасполагаются в поpяд- ке их постyпления. После того, как вся исходная последователь- ность pаспpеделена по гpyппам, гpyппы pасполагаются в поpядке возpастания связанных с гpyппами цифp. Пpоцесс повтоpяется для втоpой цифpы и т.д., пока не бyдyт исчеpпаны значащие цифpы в ключе. Основание системы счисления P может быть любым, в частном слyчае 2 или 10. Для системы счисления с основанием P тpебyется P гpyпп.

Поpядок алгоpитма качественно линейный - O(N), для соpтиpов- ки тpебyется D*N опеpаций анализа цифpы. Однако, в такой оценке поpядка не yчитывается pяд обстоятельств.

Во-пеpвых, опеpация выделения значащей цифpы бyдет пpостой и быстpой только пpи P=2, для дpyгих систем счисления эта опеpация может оказаться значительно более вpемяемкой, чем опеpация сpав- нения.

Во-втоpых, в оценке алгоpитма не yчитываются pасходы вpемени и памяти на создание и ведение гpyпп. Размещение гpyпп в стати- ческой pабочей памяти потpебyет памяти для P*N элементов, так как в пpедельном слyчае все элементы могyт попасть в какyю-то однy гpyппy. Если же фоpмиpовать гpyппы внyтpи той же последователь- ности по пpинципy обменных алгоpитмов, то возникает необходимость пеpеpаспpеделения последовательности междy гpyппами и все пpобле- мы и недостатки, пpисyщие алгоpитмам включения. Hаиболее pацио- нальным является фоpмиpование гpyпп в виде связных списков с ди- намическим выделением памяти.

В пpогpаммном пpимеpе 3.15 мы, однако, пpименяем поpазpяднyю соpтиpовкy к статической стpyктypе данных и фоpмиpyем гpyппы на том же месте, где pасположена исходная последовательность. Пpимеp тpебyет некотоpых пояснений.

Область памяти, занимаемая массивом пеpеpаспpеделяется междy входным и выходным множествами, как это делалось и в pяде пpеды- дyщих пpимеpов. Выходное множество (оно pазмещается в начале мас- сива) pазбивается на гpyппы. Разбиение отслеживается в массиве b. Элемент массива b[i] содеpжит индекс в массиве a,с котоpого начи- нается i+1-ая гpyппа. Hомеp гpyппы опpеделяется значением анали- зиpyемой цифpы числа, поэтомy индексация в массиве b начинается с 0. Когда очеpедное число выбиpается из входного множества и долж- но быть занесено в i-yю гpyппy выходного множества, оно бyдет за- писано в позицию, опpеделяемyю значением b[i]. Hо пpедваpительно эта позиция должна быть освобождена: yчасток массива от b[i] до конца выходного множества включительно сдвигается впpаво. После записи числа в i-yю гpyппy i-ое и все последyющие значения в мас- сиве b коppектиpyются - yвеличиваются на 1.


  { ===== Пpогpаммный пpимеp 3.15 ===== }
  { Цифpовая соpтиpовка (pаспpеделение) }
  const D=...;   { максимальное количество цифp в числе }
       P=...;   { основание системы счисления }
  Function Digit(v, n : integer) : integer;
  { возвpащает значение n-ой цифpы в числе v }
  begin
    for n:=n downto 2 do v:=v div P;
    Digit:=v mod P;
  end;
  Procedure Sort(var a : Seq);
    Var b : array[0..P-2] of integer; { индекс элемента,
                           следyющего за последним в i-ой гpyппе }
        i, j, k, m, x : integer;
    begin
      for m:=1 to D do begin   { пеpебоp цифp, начиная с младшей }
      for i:=0 to P-2 do b[i]:=1; { нач. значения индексов }
      for i:=1 to N do begin   { пеpебоp массива }
        k:=Digit(a[i],m);      { опpеделение m-ой цифpы }
        x:=a[i];
        { сдвиг - освобождение места в конце k-ой гpyппы }
        for j:=i downto b[k]+1 do a[j]:=a[j-1];
        { запись в конец k-ой гpyппы }
        a[b[k]]:=x;
        { модификация k-го индекса и всех больших }
        for j:=k to P-2 do b[j]:=b[j]+1;
        end;
  end;
 
 

Резyльтаты тpассиpовки пpогpаммного пpимеpа 3.15 пpи P=10 и D=4 пpедставлены в таблице 3.9.

                                                   Таблица 3.9
 
    ------T---------------------------------------------------¬
    ¦цифpа¦          содеpжимое массивов a и b                ¦
    +-----+---------------------------------------------------+
    ¦исх. ¦  220 8390 9524 9510  462 2124 7970 4572 4418 1283 ¦
    +-----+---------------------------------------------------+
    ¦  1  ¦  220 8390 9510 7970  462 4572 1283 9524 2124 4418 ¦
    ¦     ¦ L--------0--------- L---2---- L-3- L---4---- L-8- ¦
    ¦     ¦  b=(5,5,7,8,10,10,10,10,11,11)                    ¦
    +-----+---------------------------------------------------+
    ¦  2  ¦ 9510 4418  220 9524 2124  462 7970 4572 1283 8390 ¦
    ¦     ¦ L---1---- L------2------ L-6- L---7---- L-8- L-9- ¦
    ¦     ¦  b=(1,3,6,6,6,6,7,9,10,11)                        ¦
    +-----+---------------------------------------------------+
    ¦  3  ¦ 2124  220 1283 8390 4418  462 9510 9524 4572 7970 ¦
    ¦     ¦ L-1- L---2---- L-3- L---4---- L------5------ L-9- ¦
    ¦     ¦  b=(1,2,4,5,7,10,10,10,10,11)                     ¦
    +-----+---------------------------------------------------+
    ¦  4  ¦  220  462 1283 2124 4418 4572 7970 8390 9510 9524 ¦
    ¦     ¦ L---0---- L-1- L-2- L---4---- L-7- L-8- L---9---- ¦
    ¦     ¦  b=(3,4,5,5,7,7,7,8,9,11)                         ¦
    L-----+----------------------------------------------------
 



Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator

Сообщение в newsgroups:
Вопрос:
- Что такое RTFM?
Ответ:
- RTFM


 type
   TNumEdit = class(TEdit)
     procedure CreateParams(var Params: TCreateParams); override;
     procedure KeyPress(var Key: Char); override;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Standard', [TNumEdit]);
 end;
 
 procedure TNumEdit.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
 end;
 
 procedure TNumEdit.KeyPress(var Key: Char);
 begin
   case key of
     '0'..'9': ; // цифры
     #8: ; // забой
     '.', ',':
       if Pos(DecimalSeparator, Text) = 0 then
         Key := DecimalSeparator
       else
         Key := #0; // десятичный разделитель
     else
       key := #0;
   end; // case
 end;
 
 end.
 




Преобразование числа в двоичную запись

Один программист - другому:
- Вот представь: у тебя есть 1000 рублей... Или, для круглого счета, пусть у тебя 1024...

Для преобразования числа в двоичную запись удобно использовать функции shl и and. Эта функция преобразует число в строку из единиц и нулей. Количество цифр определяется параметром Digits.


 function IntToBin(Value: integer; Digits: integer): string;
 var
   i: integer;
 begin
   result := '';
   for i := 0 to Digits - 1 do
     if Value and (1 shl i) > 0 then
       result := '1' + result
     else
       result := '0' + result;
 end;
 

Вот пример использования этой функции:


 procedure TForm1.Edit1Change(Sender: TObject);
 begin
   Form1.Caption := IntToBin(StrToIntDef(Edit1.Text, 0), 128);
 end;
 




Объекты и TRegistry

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

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


 uses TypInfo;
 
 { Определяем тип-набор для доступа к битам целого. }
 const
 
   BitsPerByte = 8;
 type
 
   TIntegerSet = set of 0..SizeOf(Integer) * BitsPerByte - 1;
 
   { Сохраняем набор свойств в виде подключа. Каждый элемент перечислимого типа -
 
   отдельная логическая величина. Истина означает что элемент включен в набор,
   Ложь - элемент в наборе отсутствует. Это позволит пользователю
   с помощью редактора ресурсов (REGEDIT) легко изменять конфигурацию. }
 
 procedure SaveSetToRegistry(const Name: string; Value: Integer;
 
   TypeInfo: PTypeInfo; Reg: TRegistry);
 var
 
   OldKey: string;
   I: Integer;
 begin
 
   TypeInfo := GetTypeData(TypeInfo)^.CompType;
   OldKey := '\' + Reg.CurrentPath;
   if not Reg.OpenKey(Name, True) then
     raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
       [Name]);
 
   { Организуем цикл для всех элементов перечислимого типа. }
   with GetTypeData(TypeInfo)^ do
     for I := MinValue to MaxValue do
       { Записываем логическую величину для каждого установленного элемента. }
       Reg.WriteBool(GetEnumName(TypeInfo, I), I in
         TIntegerSet(Value));
 
   { Возвращаем родительский ключ. }
   Reg.OpenKey(OldKey, False);
 end;
 
 { Сохраняем объект в регистрах в отдельном подключе. }
 
 procedure SaveObjToRegistry(const Name: string; Obj: TPersistent;
 
   Reg: TRegistry);
 var
 
   OldKey: string;
 begin
 
   OldKey := '\' + Reg.CurrentPath;
   { Открываем подключ для объекта. }
   if not Reg.OpenKey(Name, True) then
     raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
       [Name]);
 
   { Сохраняем свойства объекта. }
   SaveToRegistry(Obj, Reg);
 
   { Возвращаем родительский ключ. }
   Reg.OpenKey(OldKey, False);
 end;
 
 { Сохраняем в регистрах метод путем записи его имени. }
 
 procedure SaveMethodToRegistry(const Name: string; const Method:
   TMethod;
 
   Reg: TRegistry);
 var
 
   MethodName: string;
 begin
 
   { Если указатель на метод содержит nil, сохраняем пустую строку. }
   if Method.Code = nil then
     MethodName := ''
   else
     { Находим имя метода. }
     MethodName := TObject(Method.Data).MethodName(Method.Code);
   Reg.WriteString(Name, MethodName);
 end;
 
 { Сохраняем в регистре каждое свойство в виде значения текущего
 ключа. }
 
 procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;
   Reg: TRegistry);
 begin
 
   with PropInfo^ do
     case PropType^.Kind of
       tkInteger,
         tkChar,
         tkWChar:
         { Сохраняем порядковые свойства в виде целочисленного значения. }
         Reg.WriteInteger(Name, GetOrdProp(Obj, PropInfo));
       tkEnumeration:
         { Сохраняем имена перечислимых величин. }
         Reg.WriteString(Name, GetEnumName(PropType, GetOrdProp(Obj,
           PropInfo)));
 
       tkFloat:
         { Сохраняем реальные числа как Doubles. }
         Reg.WriteFloat(Name, GetFloatProp(Obj, PropInfo));
       tkString,
         tkLString:
         { Сохраняем строки как строки. }
         Reg.WriteString(Name, GetStrProp(Obj, PropInfo));
       tkVariant:
         { Сохраняем вариантные величины как строки. }
         Reg.WriteString(Name, GetVariantProp(Obj, PropInfo));
       tkSet:
         { Сохраняем набор как подключ. }
         SaveSetToRegistry(Name, GetOrdProp(Obj, PropInfo), PropType,
           Reg);
 
       tkClass:
         { Сохраняем класс как подключ, а его свойства
         в виде значений подключа. }
         SaveObjToRegistry(Name, TPersistent(GetOrdProp(Obj, PropInfo)),
           Reg);
 
       tkMethod:
         { Сохраняем в регистрах метод путем записи его имени. }
         SaveMethodToRegistry(Name, GetMethodProp(Obj, PropInfo), Reg);
     end;
 end;
 
 { Записываем объект в регистр, сохраняя опубликованные свойства. }
 
 procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry);
 var
 
   PropList: PPropList;
   PropCount: Integer;
   I: Integer;
 begin
 
   { Получаем список опубликованных свойств. }
   PropCount := GetTypeData(Obj.ClassInfo)^.PropCount;
   GetMem(PropList, PropCount * SizeOf(PPropInfo));
   try
     GetPropInfos(Obj.ClassInfo, PropList);
     { Сохраняем каждое свойство в виде значения текущего ключа. }
     for I := 0 to PropCount - 1 do
       SavePropToRegistry(Obj, PropList^[I], Reg);
   finally
     FreeMem(PropList, PropCount * SizeOf(PPropInfo));
   end;
 end;
 
 { Сохраняем опубликованные свойства в виде значения данного ключа.
 
 Корневой улей - HKEY_CURRENT_USER. }
 
 procedure SaveToKey(Obj: TPersistent; const KeyPath: string);
 var
 
   Reg: TRegistry;
 begin
 
   Reg := TRegistry.Create;
   try
     if not Reg.OpenKey(KeyPath, True) then
       raise ERegistryException.CreateFmt('Не могу создать ключ: %s',
         [KeyPath]);
 
     SaveToRegistry(Obj, Reg);
   finally
     Reg.Free;
   end;
 end;
 




Список объектов


 type
   PMyRec = TMyRec;
   TMyRec = record
     Name: string[40];
     Addr: string[25];
     Comments: string;
     salary: Double;
   end;
 
 var
   aList: TList;
   aRecPtr: PMyRec;
   I: Integer;
 begin
   aList := TList.Create;
   New(aRecPtr);
   with aRecPtr^ do
   begin
     Name := '___Nikolay';
     Addr := 'Delphi World';
     Comments := 'Автор проекта Delphi World';
     Salary := 999000.00;
   end;
   aList.Add(aRecPtr);
   aList.Add(...);
   ...
   for I := 1 to aList.Count do
   begin
     aRecPtr := PMyRec(aList.Items[I - 1]);
     {что-то делаем с записью}
   end;
 
   {теперь избавляемся от всех записей
   и самого списка-объекта}
 
   for I := 1 to aList.Count do
     Dispose(PMyRec(aList.Items[I - 1]));
   aList.Free;
 end;
 




Переназначения объектов

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

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


 var
   PropInfo: PPropInfo;
 begin
   PropInfo := GetPropInfo(PTypeInfo(ActiveControl.ClassInfo), 'DataSource');
   if (PropInfo <> nil) and (PropInfo^.PropType^.Kind = tkClass)
     and (GetTypeData(PropInfo^.PropType)^.ClassType = TDataSource) then
       DBNavigator1.DataSource := TDataSource(GetOrdProp(ActiveControl, PropInfo));
 end;
 

Некоторая избыточность в проверках гарантирует вам, что вам не попадется некий странный объект (от сторонних производителей компонентов, например), имеющий свойство DataSource, но не типа TDataSource.




Объект DocInput

Тема: Объект DocInput: свойства и методы

Объект DocInput - объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он предназначен для описания входной информции для документа, передаваемого элементу управления. Все элементы управления для работы с Интернетом, имеющиеся в данном пакете, имеют доступ к объекту через соответствующее свойство, могут хранить в нем документы и передавать его от одного элемента управления другому. Объект DocInput имеет следующие свойства:

BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspended.

BytesTotal - счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных - Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи.

Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому.

Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах.

Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''.

Свойство Headers является свойстом только для чтения и времени выполнения. "headers" - коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола:

  1. content-type (тип содержимого)
    content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain".
  2. content-length (размер содержимого)
    content length указывает размер документа в байтах.

Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput.

Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается.

Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию - False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным.

Объект DocInput имеет 4 метода: GetData, PushStream, SetData и Suspend.

Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи. Метод PushStream может быть вызван только если PushStreamMode установлен в True и когда данные доступны. PushStream устанавливает свойство State на основе следующего шага передачи документа и активизирует в нужный момент событие DocInput. Затем происходит возврат до следующего вызова PushStream. Перед вызовом PushStream должен быть вызван SetData.

Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant.

Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False.

Вот некоторый код примера, показывающий как можно использовать объект DocInput. Полный проект, содержащий данный код, вы можете найти в подкаталоге demos на CD-ROM с Delphi 2.01. Имя проекта SimpMail.dpr. Данные проект представляет собой большое пример использования свойтсва объекта headers. Также показано соответствующее использование события DocInput и свойства State.


 {Очистка и новое заполнение заголовков MIME с помощью
 свойства компонента DocInput. Может также использоваться
 отдельный OLE объект DocInput. Для получения полной
 информации о типах MIME смотри документ RFC1521/1522.}
 
 procedure TMainForm.CreateHeaders;
 begin
 
   with SMTP1 do
   begin
     DocInput.Headers.Clear;
     DocInput.Headers.Add('To', eTo.Text);
     DocInput.Headers.Add('From', eHomeAddr.Text);
     DocInput.Headers.Add('CC', eCC.Text);
     DocInput.Headers.Add('Subject', eSubject.Text);
     DocInput.Headers.Add('Message-Id', Format('%s_%s_%s',
       [Application.Title, DateTimeToStr(Now), eHomeAddr.Text]));
     DocInput.Headers.Add('Content-Type',
       'TEXT/PLAIN charset=US-ASCII');
   end;
 end;
 
 {Посылаем простое почтовое сообщение}
 
 procedure TMainForm.SendMessage;
 begin
 
   CreateHeaders;
   with SMTP1 do
     SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
 end;
 
 {Посылаем файл, расположенный на диске. Оставляем пустым
 параметр SendDoc InputData и определяем имя файла для
 InputFile для посылки содержимого файла, расположенного
 на диске. Для осуществления собственного кодирования
 (Base64, UUEncode и др.), вы можете использовать событие
 DocInput и методы GetData }
 
 procedure TMainForm.SendFile(Filename: string);
 begin
 
   CreateHeaders;
   with SMTP1 do
   begin
     DocInput.Filename := FileName;
     SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
   end;
 end;
 
 {Событие DocInput возникает при каждом изменении
 состояния DocInput во время передачи почтового сообщения.
 DocInput хранит всю информацию о текущей передаче,
 включая заголовки, количество переданных байт и сами
 данные сообщения. Хотя в этом примере и не показано,
 для кодирования данных перед отправкой каждого блока
 вы можете вызвать метод DocInput SetData,
 если DocInput.State = icDocData. }
 
 procedure TMainForm.SMTP1DocInput(Sender: TObject;
 
   const DocInput: Variant);
 begin
 
   case DocInput.State of
     icDocBegin:
       SMTPStatus.SimpleText := 'Начало передачи документа';
     icDocHeaders:
       SMTPStatus.SimpleText := 'Посылаем заголовки';
     icDocData:
       if DocInput.BytesTotal > 0 then
         SMTPStatus.SimpleText :=
           Format('Послано данных: %d из %d байт (%d%%)',
           [Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal),
           Trunc(DocInput.BytesTransferred / DocInput.BytesTotal * 100)])
       else
         SMTPStatus.SimpleText := 'Посылка...';
     icDocEnd:
       if SMTPError then
         SMTPStatus.SimpleText := 'Передача прервана'
       else
         SMTPStatus.SimpleText := Format('Почта послана %s
           (%d байт данных)',
           [eTo.Text, Trunc(DocInput.BytesTransferred)]);
   end;
   SMTPStatus.Update;
 end;
 




Объект DocOutput

Тема: Объект DocOutput: свойства и методы

Объект DocOutput - объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он описывает выходную информацию передаваемого документа. Все элементы управления, имеющие свойство DocOutput, используют этот тип. Он также является объектом, на который указывает событие DocOutput. Объект DocOutput имеет следующие свойства:

BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspend.

BytesTotal - счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных - Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи.

Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому.

Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах.

Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''.

Свойство Headers является свойстом только для чтения и времени выполнения. "headers" - коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола:

  1. content-type (тип содержимого)
    content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain".
  2. content-length (размер содержимого)
    content length указывает размер документа в байтах.
Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput.

Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается.

Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию - False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным.

Объект DocOutput имеет три метода: GetData, SetData и Suspend.

Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи.

Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant.

Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False.

Приведенный здесь код взят из демонстрационного проекта, расположенного в подкаталоге Delphi 2.01 demos\internet. Имя проекта HTTPDemo.dpr. Данный проект представляет собой пример использования свойств объекта BytesTransferred и state. Также показано использование различных типов данных, являющимися новыми для Delphi 2.01. Эти типы данных важны для использования OLE, и пользователи Delphi должны о них узнать как можно скорее, если они хотят начать использовать технологию OLE в своих приложениях.


 procedure TForm1.HTTP1DocOutput(Sender: TObject; const DocOutput: Variant);
 var
   S: string;
   i: integer;
   MsgNo, Header: string;
   Parser: TSimpleHTMLParser;
   ALine: string;
 begin
   Statusbar1.Panels[2].Text :=
     Format('Байт: %s', [DocOutput.BytesTransferred]);
   case DocOutput.State of
     icDocBegin:
       begin
         Memo1.Lines.Clear;
         Data := '';
       end;
     icDocData:
       begin
         DocOutput.GetData(S, VT_BSTR);
         Data := Data + S;
       end;
     icDocEnd:
       begin
         { Теперь удаляем все HTML-тэги и отображаем текст }
         Parser := TSimpleHTMLParser.Create(Data);
         ALine := '';
         while Parser.FToken <> etEnd do
         begin
           case Parser.FToken of
             etHTMLTag:
               begin
                 if Parser.TokenHTMLTagIs('BR') then
                   ALine := ALine + #13#10;
                 if Parser.TokenHTMLTagIs('P') then
                   ALine := ALine + #13#10#13#10;
               end;
             etSymbol: ALine := ALine + ' ' + Parser.FTokenString;
             etLineEnd:
               begin
                 Memo1.Lines.Add(ALine);
                 ALine := '';
               end;
           end;
           Parser.NextToken;
         end;
         Memo1.Lines.Add(ALine);
         Memo1.SelStart := 0;
         SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
       end;
   end;
   Refresh;
 end;
 




База данных методами Object Pascal

Компания 2С: Программные комплексы для ведения двойной бухгалтерии.

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

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).

Файлы

В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.

Файлы Typed

В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые из определённой структуры данных.

Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем использовать для хранения нашей информации.


 type
   TMember = record
     name  : string[50];
     eMail : string[30];
     Posts : LongInt;
 end;
 
 var
   Members: array[1..50] of TMember;
 

Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка объявляет переменную файла F:


 var
   F: file of TMember;
 

Обратите внимание:

Чтобы создать файл typed в Delphi, мы используем следующий синтакс:


 var
   SomeTypedFile: file of SomeType;
 

Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной строкой, динамическим массивом, классом, объектом или указателем.

Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого используем процедуру AssignFile.


 AssignFile(F, 'Members.dat');
 

Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.

Запись

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


 var
   F: file of TMember;
 begin
   AssignFile(F,'members.dat');
   Rewrite(F);
   try
     for i:= 1 to 50 do
       write (F, Members[i]);
   finally
     CloseFile(F);
   end;
 end;
 

Чтение

Для получения всей информации из файла 'members.dat' используется следующий код:


 var
   Member: TMember
   F: file of TMember;
 begin
   AssignFile(F,'members.dat');
   Reset(F);
   try
     while not Eof(F) do
     begin
       read (F, Member);
       { Что-нибудь делаем с данными }
     end;
   finally
     CloseFile(F);
   end;
 end;
 

Обратите внимание:

Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы файла (за пределы последней, сохранённой записи).

Поиск и позиционирование

Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.


 {устанавливаем на начало - на первую запись}
 Seek(F, 0);
 
 {устанавливаем на 5-ю запись}
 Seek(F, 5);
 
 {Переходим в конец - "после" последней записи}
 Seek(F, FileSize(F));
 

Изменение и обновление

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


 procedure ChangeEMail(const RecN: integer; const NewEMail: string);
 var
   DummyMember: TMember;
 begin
   {связывание, открытие, блок обработки исключений}
   Seek(F, RecN);
   read(F, DummyMember);
   DummyMember.Email := NewEMail;
   {чтение перемещается на следующую запись, для этого необходимо
   вернуться на первоначальную запись, а затем записать}
   Seek(F, RecN);
   write(F, DummyMember);
   {закрываем файл}
 end;
 

Всё готово

Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла. Самое главное, что этот файл не в ASCII формате !

Общий вид модуля выглядит примерно так [здесь для наглядности данные выводятся в StringGrid'e]:


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Grids;
 
 type
   TMember = record
     name  : string[50];
     eMail : string[30];
     Posts : LongInt;
 end;
 
 type
   TForm1 = class(TForm)
     SaveBtn: TButton;
     EnterDataToArrayBtn: TButton;
     OpenBtn: TButton;
     StringGrid1: TStringGrid;
     ChangeEmailBtn: TButton;
     procedure SaveBtnClick(Sender: TObject);
     procedure EnterDataToArrayBtnClick(Sender: TObject);
     procedure OpenBtnClick(Sender: TObject);
     procedure ChangeEmailBtnClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
 end;
 
 var
   Form1: TForm1;
   Members : array[1..50] of TMember;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.SaveBtnClick(Sender: TObject);
 var
   F : file of TMember;
   i: integer;
 begin
   AssignFile(F,'members.dat');
   Rewrite(F);
   try
     for i:= 1 to 50 do
       write (F, Members[i]);
   finally
     CloseFile(F);
   end;
 end;
 
 procedure TForm1.EnterDataToArrayBtnClick(Sender: TObject);
 begin
   Members[1].name:='___Nikolay';
   Members[1].eMail:='DelphiWorld@mail.ru';
   Members[1].Posts:=10;
   Members[2].name:='Sveta';
   Members[2].eMail:='sveta29@mail.ru';
   Members[2].Posts:=28;
   Members[3].name:='Elena';
   Members[3].eMail:='malisheva_e@rambler.ru';
   Members[3].Posts:=5;
 end;
 
 procedure TForm1.OpenBtnClick(Sender: TObject);
 var
   ReadMembers: array[1..50] of TMember;
   F: file of TMember;
   i: integer;
 begin
   AssignFile(F,'members.dat');
   Reset(F);
   try
     i:=0;
     while not Eof(F) do
     begin
       read (F, ReadMembers[i]);
       ////////////////////////
       StringGrid1.Cells[0,i]:=ReadMembers[i].name;
       StringGrid1.Cells[1,i]:=ReadMembers[i].eMail;
       StringGrid1.Cells[2,i]:=IntToStr(ReadMembers[i].Posts);
       ////////////////////////
       i:=i+1;
     end;
   finally
     CloseFile(F);
   end;
 end;
 
 procedure ChangeEMail (const RecN : integer; const NewEMail : string);
 var
   DummyMember: TMember;
   F: file of TMember;
 begin
   AssignFile(F,ExtractFilePath(Application.ExeName)+'members.dat');
   Reset(F);
   Seek(F, RecN);
   read(F, DummyMember);
   DummyMember.Email := NewEMail;
   {чтение перемещается на следующую запись, для этого необходимо
   вернуться на первоначальную запись, а затем записать}
   Seek(F, RecN);
   write(F, DummyMember);
   CloseFile(F);
 end;
 
 
 procedure TForm1.ChangeEmailBtnClick(Sender: TObject);
 begin
   ChangeEmail(2, 'bestprogramming@mail.ru');
 end;
 
 end.
 




Шаблоны в Object Pascal

Автор: Rossen Assenov

Наверное каждый Delphi программист хоть раз общался с программистом C++ и объяснял насколько Delphi мощнее и удобнее. Но в некоторый момент, программист C++ заявляет примерно следующее "OK, но Delphi использует Pascal, а значит не поддерживает множественное наследование и шаблоны, поэтому он не так хорош как C++."

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

Давайте посмотрим на эту проблему по-внимательней

Шаблоны позволяют делать универсальные контейнеры такие как списки, стеки, очереди, и т.д. Если Вы хотите осуществить что-то подобное в Delphi, то у Вас есть два пути:

  • Использовать контейнер TList, который содержит указатели. В этом случае Вам прийдётся всё время делать явное приведение типов.
  • Сделать подкласс контейнера TCollection или TObjectList, и убрать все методы, зависящие от типов каждый раз, когда Вы захотите использовать новый тип данных.

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

Например, возьмём классы TCollection и TCollectionItem. Когда Вы объявляете нового потомка TCollectionItem , то так же Вы наследуете новый класс от TOwnedCollection и переопределяете большинство методов, чтобы их можно было вызывать с новыми типами.

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

Шаг 1: Создайте новый текстовый файл (не юнитовский) с именем TemplateCollectionInterface.pas:


 _COLLECTION_ = class (TOwnedCollection)
 protected
  function  GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
  procedure SetItem (const aIndex : Integer;
                     const aValue : _COLLECTION_ITEM_);
 public
  constructor Create (const aOwner : TComponent);
 
  function Add                                 : _COLLECTION_ITEM_;
  function FindItemID (const aID    : Integer) : _COLLECTION_ITEM_;
  function Insert     (const aIndex : Integer) : _COLLECTION_ITEM_;
  property Items      [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;
 end;
 

Обратите внимание, что нет никаких uses или interface clauses, только универсальное объявление типа, в котором _COLLECTION_ это имя универсальной коллекции класса, а _COLLECTION_ITEM_ это имя методов, содержащихся в нашем шаблоне.

Шаг 2: Создайте второй текстовый файл и сохраните его как TemplateCollectionImplementation.pas:


 constructor _COLLECTION_.Create (const aOwner : TComponent);
 begin
  inherited Create (aOwner, _COLLECTION_ITEM_);
 end;
 
 function _COLLECTION_.Add : _COLLECTION_ITEM_;
 begin
  Result := _COLLECTION_ITEM_ (inherited Add);
 end;
 
 function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;
 begin
  Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));
 end;
 
 function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
 begin
  Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));
 end;
 
 function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;
 begin
  Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));
 end;
 
 procedure _COLLECTION_.SetItem (const aIndex : Integer;
                                 const aValue : _COLLECTION_ITEM_);
 begin
  inherited SetItem (aIndex, aValue);
 end;
 

Снова нет никаких uses или interface clauses , а только код универсального типа.

Шаг 3: Создайте новый unit-файл с именем MyCollectionUnit.pas:


 unit MyCollectionUnit;
 
 interface
 
 uses Classes;
 
 type TMyCollectionItem = class (TCollectionItem)
      private
       FMyStringData  : String;
       FMyIntegerData : Integer;
      public
       procedure Assign (aSource : TPersistent); override;
      published
       property MyStringData  : String  read FMyStringData  write FMyStringData;
       property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;
      end;
 
      // !!! Указываем универсальному классу на реальный тип
 
      _COLLECTION_ITEM_ = TMyCollectionItem;
 
      // !!! директива добавления интерфейса универсального класса
 
      {$INCLUDE TemplateCollectionInterface}
 
      // !!! переименовываем универсальный класс
 
      TMyCollection = _COLLECTION_;
 
 implementation
 
 uses SysUtils;
 
 // !!! препроцессорная директива добавления универсального класса
 
 {$INCLUDE TemplateCollectionImplementation}
 
 procedure TMyCollectionItem.Assign (aSource : TPersistent);
 begin
  if aSource is TMyCollectionItem then
  begin
   FMyStringData  := TMyCollectionItem(aSource).FMyStringData;
   FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;
  end
  else inherited;
 end;
 
 end.
 

Вот и всё! Теперь компилятор будет делать всю работу за Вас! Если Вы измените интерфейс универсального класса, то изменения автоматически распространятся на все модули, которые он использует.

Второй пример

Давайте создадим универсальный класс для динамических массивов.

Шаг 1: Создайте текстовый файл с именем TemplateVectorInterface.pas:


 _VECTOR_INTERFACE_ = nterface
  function  GetLength : Integer;
  procedure SetLength (const aLength : Integer);
 
  function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
  procedure SetItems (const aIndex : Integer;
                      const aValue : _VECTOR_DATA_TYPE_);
 
  function  GetFirst : _VECTOR_DATA_TYPE_;
  procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);
 
  function  GetLast  : _VECTOR_DATA_TYPE_;
  procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);
 
  function  High  : Integer;
  function  Low   : Integer;
 
  function  Clear                              : _VECTOR_INTERFACE_;
  function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
  function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
 
  property  Length                         : Integer             read GetLength write SetLength;
  property  Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_  read GetItems  write SetItems; default;
  property  First                          : _VECTOR_DATA_TYPE_  read GetFirst  write SetFirst;
  property  Last                           : _VECTOR_DATA_TYPE_  read GetLast   write SetLast;
 end;
 
 _VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)
 private
  FArray : array of _VECTOR_DATA_TYPE_;
 protected
  function  GetLength : Integer;
  procedure SetLength (const aLength : Integer);
 
  function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
  procedure SetItems (const aIndex : Integer;
                      const aValue : _VECTOR_DATA_TYPE_);
 
  function  GetFirst : _VECTOR_DATA_TYPE_;
  procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);
 
  function  GetLast  : _VECTOR_DATA_TYPE_;
  procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);
 public
  function  High  : Integer;
  function  Low   : Integer;
 
  function  Clear                              : _VECTOR_INTERFACE_;
  function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
  function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
 
  constructor Create (const aLength : Integer);
 end;
 

Шаг 2: Создайте текстовый файл и сохраните его как TemplateVectorImplementation.pas:


 constructor _VECTOR_CLASS_.Create (const aLength : Integer);
 begin
  inherited Create;
 
  SetLength (aLength);
 end;
 
 function _VECTOR_CLASS_.GetLength : Integer;
 begin
  Result := System.Length (FArray);
 end;
 
 procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);
 begin
  System.SetLength (FArray, aLength);
 end;
 
 function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
 begin
  Result := FArray [aIndex];
 end;
 
 procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;
                                    const aValue : _VECTOR_DATA_TYPE_);
 begin
  FArray [aIndex] := aValue;
 end;
 
 function _VECTOR_CLASS_.High : Integer;
 begin
  Result := System.High (FArray);
 end;
 
 function _VECTOR_CLASS_.Low : Integer;
 begin
  Result := System.Low (FArray);
 end;
 
 function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;
 begin
  Result := FArray [System.Low (FArray)];
 end;
 
 procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);
 begin
  FArray [System.Low (FArray)] := aValue;
 end;
 
 function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;
 begin
  Result := FArray [System.High (FArray)];
 end;
 
 procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);
 begin
  FArray [System.High (FArray)] := aValue;
 end;
 
 function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;
 begin
  FArray := Nil;
 
  Result := Self;
 end;
 
 function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;
 begin
  System.SetLength (FArray, System.Length (FArray) + aDelta);
 
  Result := Self;
 end;
 
 function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;
 begin
  System.SetLength (FArray, System.Length (FArray) - aDelta);
 
  Result := Self;
 end;
 

Шаг 3: Создайте unit файл с именем FloatVectorUnit.pas:


 unit FloatVectorUnit;
 
 interface
 
 uses Classes; // !!! Модуль "Classes" содержит объявление класса TInterfacedObject
 
 type _VECTOR_DATA_TYPE_ = Double;       // !!! тип данных для класса массива Double
 
      {$INCLUDE TemplateVectorInterface}
 
      IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name
      TFloatVector = _VECTOR_CLASS_;     // !!! give the class a meanigful name
 
 function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция 
 
 implementation
 
 {$INCLUDE TemplateVectorImplementation}
 
 function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;
 begin
  Result := TFloatVector.Create (aLength);
 end;
 
 end.
 

Естевственно, можно дополнить универсальный класс дополнительными функциями. Всё зависит от Вашей фантазии!

Использование шаблонов

Вот пример использования нового векторного интерфейса:


 procedure TestFloatVector;
  var aFloatVector : IFloatVector;
      aIndex       : Integer;
 begin
  aFloatVector := CreateFloatVector;
 
  aFloatVector.Extend.Last := 1;
  aFloatVector.Extend.Last := 2;
 
  for aIndex := aFloatVector.Low to aFloatVector.High do
  begin
   WriteLn (FloatToStr (aFloatVector [aIndex]));
  end;
 end.
 

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

Комментарии и вопросы присылайте по адресу rossen_assenov@yahoo.com!




Конфигурирование ODBC и псевдонима

Настройка ODBC в Панели Управления

При инсталляции, Delphi устанавливает в Панель Управления апплет "ODBC" (далее - "настройка ODBC"). "Настройка ODBC" содержит доступные источники данных (драйвера), установленных для использования ODBC. Как вы можете видеть на главной странице "Data Sources", ODBC содержит внушительный набор форматов, которые могут использоваться в Delphi. Дополнительные форматы поддерживаются установленными драйверами и могут быть добавлены с помощью кнопки "Add...".

Для добавления нового или удаления существующего драйвера:

  1. В окне "Data Sources" нажмите кнопку "Drivers...". В появившемся диалоговом окне "Drivers" нажмите кнопку "Add..." и укажите путь к новому драйверу ODBC.
  2. Возвратитесь в окно "Data Sources" и добавьте доступные с новым драйвером источники данных с помощью кнопки "Add...".
  3. Для настройки конкретного источника данных используйте кнопку "Setup...". Функция кнопки "Setup..." меняется с каждым форматом данных. Частенько настройки типа рабочей директории для драйвера настраиваются как раз в этом месте.
Разделы электронной справки доступны для каждой страницы и диалогового окна "Настроки ODBC".

BDE CONFIGURATION UTILITY

После установки драйвера ODBC, запустите BDE Configuration utility для конфигурации BDE для работы с новым драйвером.

  1. На странице драйверов нажмите на кнопку "New ODBC driver".
  2. Появится диалог с заголовком "Add ODBC driver". Опция "SQL link driver" позволяет выяснить, с какими типами баз данных можно работать с помощью данного драйвера ODBC.
  3. Затем выбирайте default ODBC driver (драйвер ODBC по-умолчанию). Выпадающий список содержит список типов файлов, поддерживаемых установленными в системе драйверами ODBC.
  4. Выберите для ODBC-драйвера источник данных по-умолчанию (default data source). Имея уже установленный на шаге 3 драйвер ODBC, список этого combobox'а будет содержать имена источников данных, подходящих для использования с выбранным драйвером.
  5. Нажмите Ok.
  6. Возвратитесь на страницу драйверов, выберите File/Save из главного меню и сохраните данную конфигурацию.
Создание псевдонима в DATABASE DESKTOP

Хотя создать псевдоним ODBC можно и из BDE Configuration utility, Database Desktop предоставляет более комфортное решение.

  1. В меню "File" выберите пункт "Aliases..".
  2. В появившемся диалоге "Alias Manager" нажмите кнопку "New".
  3. Введите имя вашего нового псевдонима в поле редактирования, помеченной как "Database Alias".
  4. Используя выпадающий список "Driver Type" (типы драйверов), выберите драйвер, подходящий для данного псевдонима. Таблицы Paradox и dBase считаются STANDARD. Если в BDE Configuration utility драйвер ODBC был правильно сконфигурирован, то его имя появится в списке.
  5. Дополнительные опции опции могут появляться в зависимости от выбранного типа драйвера.
  6. После завершения всех описанных действий сохраните новый псевдоним, выбрав "Keep New". Затем нажмите "Ok". Появится подсказка, спрашивающая о необходимости сохранения псевдонима в IDAPI.CFG. Выберите "Ok".
Теперь псевдоним будет работать и в Database Desktop, и в Delphi.


Конфигурирование ODBC

Автор: Mark Nelson (Delphi Tech Support)

Представляю вашему вниманию инструкцию по конфигурированию ODBC и источника данных.

Для того, чтобы Borland Database Engine мог пользоваться драйверами ODBC, они должны быть сконфигурированы следующим образом:

  1. Инсталлируйте драйвер и установите его в Панель Управления/ODBC administrator.
    • Если это файл базового драйвера типа dBase, Paradox, Excel, FoxPro и др., то вы должны указать каталог, содержащий ваши файлы.
    • Access и Local Btrieve файлы должны указывать на конкретный файл базы данных (Btreive на File.ddf, Access должен указывать на файл с расширением .MDB).
    • Если это линк (connection) к базе данных, например Oracle, Sybase, Interbase, и др., вы должны указать на этот линк. Обычно транспорт посредством TCPIP, SPX/IPX, NetBEUI и т.п. предусматривается поставщиком программного обеспечения. Каждый драйвер работает с транспортным протоколом по-своему.
  2. Запустите Database Engine Configuration Utility. (BDECFG.EXE)
  3. Выберите New ODBC Driver.
  4. Задайте имя вашему драйверу (к имени автоматически добавится "ODBC_".)
  5. Выберите ваш ODBC Driver из списка Default ODBC Driver List.
  6. Выберите имя источника данных по умолчанию.
  7. Создайте псевдоним (alias), указывающий на установленный вами драйвер.
  8. Установите ссылку с именем псевдонима на ваш драйвер.
Примечание относительно баз данных Access 2.0: вам необходимо иметь самые последние драйверы от Microsoft. Имеющиеся драйверы позволяют работать только с базами данных Access 1.0, не выше.

Стоимость нового набора драйверов у самой Microsoft составляет $10, что эквивалентно цене носителя и пересылки.

Для работы с Access 2.0 вам необходимо использовать источник данных с именем "Microsoft Access Driver" или "Microsoft Access 2.0 Databases".

Имейте в виду, что "Access Data" и "Access Files" по умолчанию являются источниками данных только для Access 1.0. Поэтому для получения доступа к MDB-файлам Access 1.0 пользуйтесь "Access Data".

Btrieve также создает источник данных по умолчанию "Btrieve Data" и "Btrieve Files". Используйте "Btrieve Data" как ваш источник данных по умолчанию. Драйверы Btrieve позволяют использовать данные btrieve вплоть до версии 5.0. Для работы с Btrive данными более новой версии, необходим новый набор драйверов Microsoft или Intersolve Q+E.




ODBC соединения

...я обращал ваше внимание на трудности коннекта Delphi-приложений с Watcom. За исключением досадной проблемы с чуствительностью регистров у ODBC драйверов (которая пропадает после установки соответствующих заплаток), мое приложение действительно лучше соединяется с базой данных Watcom, чем LIBS. Вот функция, которую я использую для подключения к серверу:


 function TLogonForm.LogonToServer: Boolean;
 begin
   LogonToServer := FALSE;
   MyDatabase.AliasName := DatabaseEdit.Text;
   MyDatabase.Params.Values['USER NAME'] := UserIDEdit.Text;
   MyDatabase.Params.Values['PASSWORD'] := PasswordEdit.Text;
   MyDatabase.Params.Values['SERVER NAME'] := ServerName;
   try
     MyDatabase.Connected := TRUE;
     LogonToServer := TRUE;
   except
     on E: EDatabaseError do
       MessageDlg('Программа не в состоянии подключиться к
         серверу баз данных по следующей причине:
           ' + #10 + #10 + E.Message, mtError, [mbOK], 0);
   end;
 end;
 

Эта функция находится в модуле с формой диалога подключения, на которой расположены три поля редактирования: идентификатор пользователя, пароль и имя базы данных. При щелчке пользователем на кнопке OK, значение из поля с именем базы данных используется для поиска в файле ODBC.INI:


 ServerName := ODBCIni.ReadString(DatabaseEdit.Text, 'Database', '');
 

Этой строчкой мы получаем фактическое имя файла базы данных, к которому нам необходимо получить доступ ('SERVER NAME' - параметр соединения).

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

 Connected: FALSE
  DatabaseName: DCAC {это псевдоним, используемый приложением}
  KeepConnection: TRUE
  LoginPrompt: FALSE
  Name: MyDatabase
  TransIsolation: tiReadCommitted
 
AliasName, DriverName и Params в режиме проектирования остаются пусты, DriverName не используется совсем, т.к. во время выполнения приложения используется AliasName (они являются взаимоисключающими, вы можете установить что-то одно, но не оба сразу).

Вот секции Interbase и Watcom моего файла ODBC.INI:

  [DCAC_IB]
  Driver=C:\WIN\SYSTEM\BLINT04.DLL
  Description=DC Aquatics (Interbase)
  Database=D:\DCAC_IB\DCAC.GDB
 
  [DCAC_WSQL]
  Driver=D:\WSQL\wsqlodbc.dll
  Description=DC Aquatics (Watcom)
  Database=D:\DCAC_WAT\DCAC.DB
  Start=D:\wsql\db32w %d
Если мне необходимо подключиться к базе данных Watcom, все, что мне нужно сделать - изменить содержимое поля редактирования имени базы данных в диалоге подключения на 'DCAC_WSQL'. Если мне нужно использовать базу данных Interbase, я набираю 'DCAC_IB'. Работает замечательно.

Надеюсь это поможет... успехов...




Получение дескриптора ODBC соединения

Автор: Chris Fioravanti

Я как-то обращал ваше внимание на трудность получения дескриптора ODBC соединения посредством DBE. После тесного общения со службой поддержки Borland, я наконец нашел решение как это сделать. Вот этот код:


 unit Getprop;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, Grids, DBGrids, StdCtrls, DB, DBTables,
   DBIProcs, DBITypes, DBIErrs;
 
 type
   TForm1 = class(TForm)
     Table1: TTable;
     DataSource1: TDataSource;
     Button1: TButton;
     Button2: TButton;
     DBGrid1: TDBGrid;
     Edit1: TEdit;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Table1.active := True;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   hTmpDB: hDBIDb;
   iLen: word;
 
 begin
   Check(DbiGetProp(hDBIObj(Table1.DBhandle), dbNATIVEHNDL, @hTmpDB,
     sizeof(hDBIDb), iLen));
   Edit1.text := inttostr(longint(htmpdb));
 end;
 
 end.
 




Установка ODBC - Watcom SQL

Автор: Johannes M. Becher (CODATA GmbH Krefeld, Germany)

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

A) ODBCINST.INI - описание всех установленных драйверов ODBC

Секция [ODBC Drivers] в каждой строчке описывает один драйвер. Здесь прописано формальное имя драйвера, использующегося позже для идентификации драйвера.

Каждый драйвер, как вы увидите позже, имеет собственную секцию, к примеру, вот секция для Watcom :

     {1} [Watcom SQL 4.0]
     {2} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
     {3} Setup=D:\WIN31\SYSTEM\WOD40W.DLL
Строка 1 содержит имя секции драйвера из [ODBC Drivers].
Строка 2 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для доступа к базам данных Watcom.
Строка 3 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для административных целей.

Все, что имеется в файле ODBCINST.INI - теперь содержится в файле #2 (таком же легком для изучения):

B) ODBC.INI - описание всех ваших баз данных (источников данных, говоря языком ODBC)

Секция [ODBC Data Sources] в каждой строчке описывает одну базу данных; формат:
{описание базы данных} = {описание драйвера из ODBCINST.INI}
Данный файл сообщает ODBC, к каким базам данных вы хотите иметь доступ и какой драйвер для каждой конкретной базы данных для этого необходим.

Каждая база данных, как вы увидите позже, имеет собственную секцию, к примеру, вот секция PB Demo:

    {1} [Powersoft Demo DB=Watcom SQL 4.0]
     {2} DatabaseFile=E:\PB4\EXAMPLES\PSDEMO.DB
     {3} DatabaseName=PSDEMODB
     {4} UID=dba
     {5} PWD=sql
     {6} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
     {7} Start=D:\WSQL40\DBSTARTW -d -c512
Строка 1 содержит ссылку на секцию [ODBC Data Sources].
Строка 2 содержит физический путь к файлу базы данных.
Строка 3 - описание, только для вашего чтения.
Строка 4 - User ID, которое Watcom применяет для установления связи.
Строка 5 - Пароль, используемый для установления соединения.
- Это не очень секретно; если вы оставите эту строку пустой, Watcom сам спросит пароль при получении доступа к базе данных.
Строка 6 содержит имя драйвера (снова - сравните с OBDCINST.INI)
Строка 7 содержит имя движка базы данных для ее запуска (это необходимо лишь для баз данных SQL, например, в версии Client / Server).

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

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

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




Ошибка ODBC SQL Prepare

Автор: Scott Gammans

Окошко: "Программа Microsoft не совершила никакой ошибки, но по привычке будет закрыта".

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

При подключении к источнику данных ODBC, данная последовательность вызывает утечку памяти без возникновения GPF:

 Prepare->ExecSQL->ExecSQL->ExecSQL->...
C установленной Delphi это еще требует подготовку (prepare) каждого запроса:

 Prepare->ExecSQL->Unprepare->Prepare->ExecSQL->Unprepare->...



OLE и Interbase - прочесть и записать

Автор: Rob Minte


 procedure TForm1.ReadOLE;
 var
   BS:    TBlobStream;
 begin
   BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmRead);
   OLEContainer1.LoadFromStream(BS);
   BS.Free;
 end;
 


 procedure TForm1.WriteOLE;
 var
   BS:    TBlobStream;
 begin
   BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmWrite);
   OLEContainer1.SaveToStream(BS);
   BS.Free;
 end;
 




Пример работы через OLE с Excel

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


 // Маленькая процедурка -- на которой я тестировал вообще коннект к Excel
 procedure TForm1.ButtonClick(Sender: TObject);
 var
   Excel : Variant;
   WorkSheet : Variant;
   I, J  : Integer;
 begin
   if OpenDialog.Execute then begin
     Excel := CreateOleObject( InputBox('OleStr', 'CreateOleObject',
     'Excel.Application.8') );
     Excel.Visible := False;
     Excel.Workbooks.Open( OpenDialog.FileName );
     WorkSheet := Excel.Workbooks[1].WorkSheets[1];
     ListView.Columns.Clear;
     ListView.Items.Clear;
     for I := 1 to WorkSheet.Cells.CurrentRegion.Columns.Count do
        ListView.Columns.Add.Caption := VarToStr( WorkSheet.Cells[1,I] );
     for I := 1 to WorkSheet.Cells.CurrentRegion.Rows.Count do
      with ListView.Items.Add do begin
       Caption := VarToStr( WorkSheet.Cells[I,1] );
       for J := 2 to WorkSheet.Cells.CurrentRegion.Columns.Count do
         SubItems.Add( VarToStr( WorkSheet.Cells[I,J] ));
     end;
     Excel.Workbooks.Close;
     Excel.Quit;
   end;
 end;
 
 {
  Кусочки из программы, которая читала Excel и кидала дату в SQL базу,
  Прога была одаптирована к конторской конкретике, поэтому целиком е¸
  кидать бессмысленно.
 }
 
 //Коннект... С простой мыслей о том что неизвесто с какой именно
 // версией объекта придется работать
 procedure TEnemaDM.ConnectToExcelServer(FileName: String);
 var
   Reg : TRegIniFile;
 begin
   Reg := TRegIniFile.Create( 'SOFTWARE\');
   if (FileExists( FileName ))and
      (UpperCase(ExtractFileExt( FileName )) = '.XLS' ) then try
     if VarIsEmpty( Excel ) then begin
       Excel := CreateOleObject( Reg.ReadString( 'Enema','Excel',
        'Excel.Application.8' ));
     end else begin
       Excel.Workbooks.Close;
     end;
     Excel.Visible := False;
     Excel.Workbooks.Open( FileName );
   finally
     Reg.Free;
   end;
 end;
 
 procedure TEnemaDM.DisconnectExcelServer;
 begin
   try
     try
       Excel.Quit;
     except
     end;
   finally
     VarClear( Excel );
   end;
 end;
 
 
 //Пример загрузки списка листов таблицы
 // Ейный вызов MainForm.LoadLists(Excel.Workbooks[1] );
 //  -- я предпологаю что открыт 1 файл...
 procedure TMainForm.LoadLists(WorkBooks: Variant);
 var
   I : Integer;
 begin
   if not VarIsNull( WorkBooks ) then begin
     ExcelListBox.Items.Clear; // TComboBox
     for I := 1 to WorkBooks.WorkSheets.Count do begin
       ExcelListBox.Items.Add( VarToStr( WorkBooks.WorkSheets[I].Name ));
     end;
   end;
 end;
 
 
 // Сама процедура загрузки перекачивает данные в некую хранимую процедуру
 // Вызывалась как LoadExcel( Excel.Workbooks[1].WorkSheets[MainForm.CurrentList] )
 procedure TEnemaDM.LoadExcel( WorkSheet : Variant );
 var
   I : Integer;
   ErrorList : TStrings;
 begin
   with MainForm do try
     ErrorList := TStringList.Create;
     try
       for I := 1 to WorkSheet.Cells.CurrentRegion.Rows.Count do begin
         try
          ХранимаяПроцедура.ParamByName( параметр ).AsString :=
              VarToStr(
            WorkSheet.Range[наименование региона в символах Excel. см Help].Cells[I,1] );
          ХранимаяПроцедура.ExecProc;
         except
           on E : Exception do ErrorList.Add( GetErrorCurrentValue +
                           #32 + E.Message );
         end;
       end;
       if ErrorList.Count = 0 then
          MessageDlg( 'Данные успешно успешно загружены' ,
      mtInformation, [mbOk], 0 )
       else
         ФормочкаДляОшибок.SetErrorList( ErrorList );
     finally
       ErrorList.Free;
     end;
   except
     on E : Exception do MessageDlg( E.Message, mtError, [mbOk], 0 );
   end;
 end;
 
 

Коментарий от Yur Ovchinnikov


   cls_ExcelObject := 'Excel.Application';
   regData := TRegistry.Create;
   regData.RootKey := HKEY_CLASSES_ROOT;
   try
     if regData.OpenKey('\Excel.Application\CurVer', False) then
      begin
       cls_ExcelObject := regData.ReadString('')
       regData.CloseKey;
      end
   finally
     regData.Free;
   end;
 
 

Это для того, чтобы не применять локальные для каждой версии названия "Excel.Application.8", "Excel.Application.9". Ко всему прочему приведенный пример не работает с Excel95.




Не работает передача данных по OLE в русский Excel

Автор: Nomadic

Мёpтвый диск не жyжжит,
Мёpтвый сидиpом не поёт,
Мёpтвый компьютеp игpy запyскать не идёт,
Только мёpтвый компьютеp игpy запyскать не идёт...

A: (SM): Дело в том что в VCL твои команды OLE2 передаются Excel'у в русском контексте (не знаю, как это правильно назвать). Для исправления необходимо найти в файле OLEAUTO.pas в функции GetIDsOfNames строчку


 if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
 LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then
 

и заменить ее на


 if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
 ((LANG_ENGLISH+SUBLANG_DEFAULT*1024)+SORT_DEFAULT* 65536 ),
 DispIDs) <> 0 then
 

После этого у меня Excel стал понимать нормальные английские команды :)). Необходимая комбинация для установки английского языка взята из C-шных хедеров.




OLE сервер

Сервер - не суетись под клиентом!

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


 unit Unit1;
 
 interface
   function OLEfunction(x, y, z: integer): integer; cdecl; export;
 
 implementation
 
 function OLEfunction(x, y, z: integer): integer;
 begin
 
 end;
 
 procedure buildOLEstructure;
 var
   F: pointer;
 begin
   F := @OLEfunction; { Компилируется без проблем ... }
 end;
 
 end.
 

Используйте метод, приведенный ниже. Вы должны объявить одну вызывающую функцию к каждой комбинации параметров, которые вы собираетесь передавать. Затем вы вызываете вызывающую функцию (сорри) и передаете ей как указатель функцию, которую вы хотите вызвать (еще раз сорри). Непонятно? Поясню на примере:


 library Pcdecl;
 
 function olefunction(a1 : pchar; a2 : longint; x : integer )  : integer;
 
 cdecl; export;
 begin
 
 end;
 
 function callolefunction(func : pointer; a1 : pchar; a2 : longint; x :
 integer)  : integer;
 
 assembler;
 asm
 
 push        x                   { помещаем параметры в обратном порядке }
 push        word ptr a2 + 2     { если 32-битная величина передается в
                                   этих двух шагах, то начинаем с самой
                                   "высокой" (high) части }
 push        word ptr a2
 push        word ptr a1 + 2
 push        word ptr a1
 call        func
 add        sp, 10               { восстанавливаем стек добавлением вытолкнутых
                                   байтов. Обратите внимание на то, что func не
                                   была вытолкнута }
 end;
 
 procedure buildolefunction;
 var
 
 f         : pointer;
 reslt     : integer;
 begin
 
 f := @olefunction;
 { --- }
 reslt := callolefunction(f, 'Здравствуй, мир', 1000000, 25);
 { --- }
 end;
 
 begin
 
 { --- }
 end.
 

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




OLE тестер

Это ОЧЕНЬ простой тест, который я добавил к своей программе для проверки работоспособности OLE. Меня попросили добавить к моей программе поддержку OLE и мне пришлось изобретать способ проверки работоспособности моего OLE-сервера.

В данном примере в момент создания формы создается OLE-объект и после нажатия на какую-либо из кнопок вызывается определенная процедура OLE-сервера.


 unit oletestu;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     ttsesed: variant;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 uses oleauto;
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ttsesed := createoleobject('ttdewed.ttsesole');
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ttsesed.openeditfile;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   ttsesed.appshow;
 end;
 
 end.
 




Работа с Word через OLE


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   Buttons, ComCtrls, ExtCtrls, OleCtnrs;
 
 type
   TForm1 = class(TForm)
     OleContainer1: TOleContainer;
     Panel1: TPanel;
     StatusBar1: TStatusBar;
     mbLoad: TSpeedButton;
     mbPrint: TSpeedButton;
     OpenDialog1: TOpenDialog;
     procedure mbLoadClick(Sender: TObject);
     procedure mbPrintClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.mbLoadClick(Sender: TObject);
 begin
  // Покажем диалог, и если он отработал, то загрузим в контейнер
  if OpenDialog1.Execute and (OpenDialog1.FileName<>'') then
   OleContainer1.CreateObjectFromFile(OpenDialog1.FileName,false);
  // Если загрузилось что-нибудь, то покажем
  if OleContainer1.State <> osEmpty then
   OleContainer1.DoVerb(ovShow);
 end;
 
 procedure TForm1.mbPrintClick(Sender: TObject);
 var
  V : Variant;
 begin
  if OleContainer1.State = osEmpty then Begin
   MessageDlg('OLE не загружен !!', mtError, [mbOk],0);
   exit;
  end;
   // Получаем объект, который воплощает в себе WordBasic интерфейс
   V := OleContainer1.OleObject.Application.WordBasic;
   // Командуем до одурения ....
   V.FilePrint;
 end;
 end.
 
 




Как работать с файлами MS Word или таблицами MS Excel

Автор: Sergey Arkhipov

A: Воспользоваться функцией CreateOLEObject и работать с VBA (Visual Basic for Applications) или WordBasic.

NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например, FileOpen(Name := 'myname.doc');

Пример проверен только на русском Word 7.0! Может, поможет...


 unit InWord;
 interface
 uses
   ...ComCtrls; // Delphi3
 ...OLEAuto; // Delphi2
 [skip]
 
 procedure TPrintForm.MPrintClick(Sender: TObject);
 var
   W: Variant;
   S: string;
 begin
   S := VarToStr(Table1['Num']); //В D3 без промежуточной записи
   // в var у меня не пошло :(
   try // А вдруг где ошибка :)
     W := CreateOleObject('Word.Basic');
     // Создаем документ по шаблону MyWordDot
     // с указанием пути если он не в папке шаблонов Word
     W.FileNew(Template := 'C:\MyPath\DB\MyWordDot', NewTemplate := 0);
     // Отключение фоновой печати (на LJ5L без этого был пустой лист)
     W.ToolsOptionsPrint(Background := 0);
 
     // Переходим к закладке Word'a 'Num'
     W.EditGoto('Num');
     W.Insert(S);
     //Сохранение
     W.FileSaveAs('C:\MayPath\Reports\MyReport')
       W.FilePrint(NumCopies := '2'); // Печать 2-х копий
   finally
     W.ToolsOptionsPrint(Background := 1);
     W := UnAssigned;
   end;
 end;
 {.....}
 


 MyExcel:=CreateOleObject('Excel.Application');
 MyExcel.visible:=true;
 MyExcel.WorkBooks.Add;
 MyExcel.Cells(1,1):='Администрация';
 




Хитрость OnCalcFields

Событие OncalcFields генерится ОЧЕНЬ часто и может быть необязательным и занимать большое количество времени, например, у вас есть таблица с неким вычисляемым полем, и при каждом редактировании таблицы вызывается следующий код:


 MyCalcField.AsInteger := Table1Field1.AsInteger + 10;
 

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

Мой совет следующий: выключите генерацию события OnCalcFields, обработайте все поля и снова включите генерацию данного события, к примеру так:


 Procedure TForm1.BigProcessingFunction;
 begin
   Table1.OnCalcFields := nil;
   // <Включите любые по сложности вычисления в этом месте!>
   Table1.OnCalcFields := Table1OnCalcFields;
 end;
 

Поля не вычисляются в течение времени обработки, которое может быть достаточно велико, но при наличие громоздких вычислений специфического поля (или даже нескольких полей), все вычисляется за один проход!

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




OnClick для DBGrid

Вопросы ламера:
1. Почему какой-то Disconnect мешает мне сидеть в Интернете, и пробовал ли кто-нибудь подавать на него в суд?
2. Кто такой "General Failrure" и почему он считывает с моего винчестера?
3. Почему ДОС никогда не говорит "Exelent command or filename"?


 TGroothuisGrid = class(TDBGrid) {!}
 published
   property OnClick;
 end;
 

Это все! OnClick уже объявлен в TControl как защищенное свойство. Все, что вы должны сделать, это опубликовать это свойство в компоненте-наследнике, зарегистрировать его (смотри гл. 8 Руководства по созданию компонентов, Component Writer's Guide) и использовать взамен TDBGrid.




OnClick для DBGrid 2

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

Многие программисты хотели бы использовать OnClick у TDBGrid. Но TDBGrid не имеет такого события. В данном документе рассказывается о том, как обеспечить поддержку события OnClick для TDBGrid. Рассказанная здесь технология может пригодиться при добавлении других свойств к различным объектам. Если вы знаете, что сделать это мог предок, то можно заставить сделать это и наследника. Ключевым моментом здесь можно считать добавление csClickEvents к свойству-набору элемента управления ControlStyle. Это позволит элементу управления, приведенному к типу THack, получать и правильно обрабатывать системные сообщение о щелчке мышью. Назначение OnClick какого-либо элемента управления OnClick DBGrid1 позволяет воспользоваться событием OnClick для элемента управления, которое его не поддерживает.

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


 unit Udbgclk;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs,
   StdCtrls, Grids, DBGrids, DBTables, DB;
 
 type
   thack = class(tcontrol);
 
   TForm1 = class(TForm)
     DBGrid1: TDBGrid;
     Button1: TButton;
     DataSource1: TDataSource;
     Table1: TTable;
     procedure Button1Click(Sender: TObject);
     procedure FormClick(Sender: TObject);
 
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   THack(dbgrid1).controlstyle :=
     THack(dbgrid1).controlstyle + [csClickEvents];
   THack(dbgrid1).OnClick := Form1.OnClick;
 end;
 
 procedure TForm1.FormClick(Sender: TObject);
 begin
   messagebeep(0);
   application.processmessages;
 end;
 
 end.
 




Событие OnDraw для TStringGrid

Это код, который я использую для печати TMemoField в TDBGrid. Перекрываем (override) метод DrawCell:


 Canvas.FillRect(ARect);
 R := ARect;
 WITH TMemoField(Field) DO
 DrawText(Canvas.Handle, PChar(Value), Length(Value), R,
 DT_WORDBREAK OR DT_NOPREFIX);
 

Я думаю этот код, который я создал в Delphi 1.0, должен помочь вам:


 procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
   Rect: TRect; State: TGridDrawState);
 var
   bufB: array[0..79] of Char;
   algn: Word;
 begin
   algn := 0;
   if (Col = NumbColK) or (Col = PrceColK) or
     (Col = TtlColK) then
     algn := dt_Right;
   if Row = 0 then
     algn := dt_Center;
   if algn = 0 then
     Exit;
   StringGrid1.Canvas.FillRect(Rect);
   StrPCopy(bufB, StringGrid1.CellS[Col, Row]);
   Rect.Top := Rect.Top + 2;
   Rect.Right := Rect.Right - 2;
   DrawText(StringGrid1.Canvas.Handle, bufB, -1, Rect, algn);
 end;
 

  1. В первой части необходимо установить нужное вам выравнивание, и очистить старый текст.
  2. Число -1, поскольку, я думаю, bufB должен быть строкой с терминирующим нулем, в которую вы можете помещать любое число, например, 10, и он должен ограничивать вашу строку до 10, как раз то, что вы хотели.

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


 grid.cells[col,row] :=
 trimWithDots (myString, form1.canvas, grid.widths[col]-2);
 

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


 function trimWithDots (const myString: string; canvas: tCanvas;
 wid: integer): string;
 begin
   result := myString;
   while canvas.textWidth (result) > wid do
     delete (result, length(result), 1);
 end;
 

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

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




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


 {
   This example shows how to assign a OnContextPopup event
   handler to all components at runtime using SetMethodProp().
   (Here: OnContextPopup event handler)
 }
 
   private
     { Private declarations }
     procedure AssignOnContextPopupEvent;
     procedure OnContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: Boolean);
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 uses
   TypInfo;
 
 procedure TForm1.OnContextPopup(Sender: TObject; MousePos: TPoint;
   var Handled: Boolean);
 begin
   with Sender as TComponent do
     ShowMessage(Name + ' right-clicked!');
 end;
 
 procedure TForm1.AssignOnContextPopupEvent;
 var
   i: Integer;
   PropInfo: PPropInfo;
   Method: TMethod;
   PEvent: ^TContextPopupEvent;
 begin
   for i := 0 to ComponentCount - 1 do
   begin
     PropInfo := GetPropInfo(Components[i].ClassInfo, 'OnContextPopup');
     if (PropInfo <> nil) and (PropInfo^.PropType^^.Kind = tkMethod) then
     begin
       Method := GetMethodProp(Components[i], PropInfo);
       if not Assigned(Method.Code) then
       begin
         PEvent := @Method.Code;
         PEvent^ := OnContextPopup;
         Method.Data := Self;
         SetMethodProp(Components[i], PropInfo, Method);
       end;
     end;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   AssignOnContextPopupEvent;
 end;
 




Как запретить запуск второй копии программы

Биллy Гейтсy пpиписывают следyющее высказывание: "Если вы не можете сделать хоpошyю пpогpаммy, сделайте, чтобы она по кpайней меpе выглядела хоpошо".

Алгоритм, применяемый мною:

В блоке begin..end модуля .dpr:


 begin
   if HPrevInst <>0 then
   begin
     ActivatePreviousInstance;
     Halt;
   end;
 end;
 

Реализация в модуле:


 unit PrevInst;
 
 interface
 
 uses
   WinProcs,
   WinTypes,
   SysUtils;
 
 type
   PHWnd = ^HWnd;
 
 function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;
 
 procedure ActivatePreviousInstance;
 
 implementation
 
 function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
 var
   ClassName: array[0..30] of char;
 begin
   Result := true;
   if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then
   begin
     GetClassName(Wnd, ClassName, 30);
     if STRIComp(ClassName, 'TApplication') = 0 then
     begin
       TargetWindow^ := Wnd;
       Result := false;
     end;
   end;
 end;
 
 procedure ActivatePreviousInstance;
 var
   PrevInstWnd: HWnd;
 begin
   PrevInstWnd := 0;
   EnumWindows(@EnumApps, LongInt(@PrevInstWnd));
   if PrevInstWnd <> 0 then
     if IsIconic(PrevInstWnd) then
       ShowWindow(PrevInstWnd, SW_Restore)
     else
       BringWindowToTop(PrevInstWnd);
 end;
 
 end.
 




Как заблокировать старт второго экземпляра

Вирус - бесплатно распространяемая программа, которая, впрочем, ничего и не делает. Потому и бесплатно.


 program Previns;
 uses
   WinTypes,
   WinProcs,
   SysUtils,
   Forms,
   Uprevins in 'UPREVINS.PAS' {Form1};
 {$R *.RES}
 
 type
   PHWND = ^HWND;
 
 function EnumFunc(Wnd: HWND; TargetWindow: PHWND): bool; export;
 var
   ClassName: array[0..30] of char;
 begin
   Result := true;
   if GetWindowWord(Wnd, GWW_HINSTANCE) = hPrevInst then
   begin
     GetClassName(Wnd, ClassName, 30);
     if StrIComp(ClassName, 'TApplication') = 0 then
     begin
       TargetWindow^ := Wnd;
       Result := false;
     end;
   end;
 end;
 
 procedure GotoPreviousInstance;
 var
   PrevInstWnd: HWND;
 begin
   PrevInstWnd := 0;
   EnumWindows(@EnumFunc, Longint(@PrevInstWnd));
   if PrevInstWnd <> 0 then
     if IsIconic(PrevInstWnd) then
       ShowWindow(PrevInstWnd, SW_RESTORE)
     else
       BringWindowToTop(PrevInstWnd);
 end;
 
 begin
   if hPrevInst <> 0 then
     GotoPreviousInstance
   else
   begin
     Application.CreateForm(TForm1, Form1);
     Application.Run;
   end;
 end.
 




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

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

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


 ...
 uses syncobjs;
 ...
 var
   CheckEvent: TEvent;
 
 ...
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   CheckEvent := TEvent.Create(nil, false, true, 'MYPROGRAM_CHECKEXIST');
   if CheckEvent.WaitFor(10) <> wrSignaled then
   begin
     // Сюда попадаем если одна копия уже запущена.
     // Можно, например, сообщить об этом пользователю.
     Self.Close; // Здесь можно завершить программу или сделать еще что-нибудь.
   end;
 end;
 




Блокировка запуска второй копии программы

Автор: Васильев Сергей

Если программист идет в 3 часа дня на работу, то он в отпуске.


 program Project1;
 
 uses
   Forms,
   Windows,
   Unit1 in 'Unit1.pas' {Form1};
 
 {$R *.RES}
 
 var
   hwnd: THandle;
 
 begin
   hwnd := FindWindow('TForm1', 'Form1');
   if hwnd = 0 then
   begin
     Application.Initialize;
     Application.CreateForm(TForm1, Form1);
     Application.Run;
   end
   else
     SetForegroundWindow(hwnd)
 end.
 




Запрет на запуск второй копии программы

Автор: Васильев Николай

Идет колдун по базару. Нос крючком, на голове колпак, сам в халате до пят звездами расшитом. Кругом фрукты, насекомые там над ними... Вдруг на нос ему садится оса. Колдун хлоп - и убил осу. Идет дальше. На нос ему садится еще одна оса. Опять хлоп - и нет осы. На нос садится третья. Тут колдуну надоело, достал он волшебную палочку и приказал:
- Хочу, чтобы осы сами по себе дохли без всякой видимой причины! Так появилась ОС Windоws 95...


 program pds;
 
 uses
   Windows,
   Forms,
   Main in 'MAIN.PAS' {MainForm},
 
 const
   MemFileSize = 127;
   MemFileName = 'one_example';
 
 var
   MemHnd: HWND;
 
 {$R *.RES}
 
 begin
 
   MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil,
     PAGE_READWRITE, 0, MemFileSize,
     MemFileName);
   if GetLastError <> ERROR_ALREADY_EXISTS then
   begin
     Application.Initialize;
     with TForm1.Create(nil) do
     try
       Show;
       Update;
       Application.CreateForm(TMainForm, MainForm);
     finally
       Free;
     end;
     Application.Run;
   end
   else
     Application.MessageBox('Приложение уже запущено (возможно оно свернуто
       на панели задач): Нажмите кнопку ОК для продолжения работы',
       'Производственно-диспетчерская служба', MB_OK);
   CloseHandle(MemHnd);
 end.
 




Не допустим запуска копии программы

Автор: Тарасов Николай Валентинович

- Сколько программистов нужно, чтобы поменять сгоревшую лампочку?
- Двадцать. Один держит лампочку, а остальные 19 пьют пиво, пока комната не начнет сама крутиться.


 ActivatePrevInstance('TForm1','Значение Caption ');
 




Запрет старта еще одного экземпляра EXE

Автор: john@mail.enisey.ru

- "Hе" с глаголами пишется вместе или отдельно?
- Через пробел!

У меня есть элементарный вариант, проще не бывает. Предлагаемый мной модуль только определяет запущена программа или нет. Я не стал усложнять этот модуль автоматическим изменением имени семафора на случай если две программы захотят использовать этот модуль одновременно. Имея самые скромные навыки в программировании можно придумать семафору своё уникальное имя и переписать его в previnst.pas вовсе не обязательно семафор называть AbraShvabra.

Использование:
В модуле program в части Uses нужно добавить previnst и вы получаете переменную ммм: boolean которая true если копия программы уже запущена.

Пример:


 program Project1;
 
 uses
   previnst, windows, Forms,
   Unit1 in 'Unit1.pas' {Form1};
 
 {$R *.RES}
 begin
   if mmm then
   begin
     ShowWindow(FindWindow('tform1', 'Имя окна которое активизировать'),
       SW_restore);
 
     SetForegroundWindow(FindWindow('tform1', 'Имя окна которое
       активизировать'));
 
       halt; //завершить программу не создавая ничего.
   end;
 
   //Тело программы прогры
 
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end.
 

содержание модуля previnst.pas


 unit Previnst;
 
 interface
 
 uses Windows;
 
 var
   mmm: boolean; //эта переменная если true то программа уже запущена
 
 implementation
 
 var
   hMutex: integer;
 begin
   mmm := false;
   hMutex := CreateMutex(nil, TRUE, 'AbraShvabra'); // Создаем семафор
   if GetLastError <> 0 then
     mmm := true; // Ошибка семафор уже создан
   ReleaseMutex(hMutex);
 end.
 




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



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



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


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