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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Активизация предыдущего экземпляра вашей программы

Если внутренняя переменная hPrevInst не равна нулю, то она содержит дескриптор предыдущего запущенного экземпляра вашей программы. Вы просто находите открытое окно по его дескриптору и, при необходимости, выводите на передний план. Весь код расположен в файле .DPR file, НЕ в модуле. Строки, которые вам необходимо добавить к вашему .DPR-файлу, в приведенном ниже примере помечены {*}.


 program Once;
 
 uses
 {*}  WinTypes, WinProcs, SysUtils,
 
 Forms,
 Onceu in 'ONCEU.PAS' {Form1};
 
 {$R *.RES}
 {*}TYPE
 {*}  PHWND = ^HWnd;
 
 {*}  FUNCTION EnumWndProc(H : hWnd; P : PHWnd) : Integer; Export;
 {*}  VAR ClassName : ARRAY[0..30] OF Char;
 {*}  BEGIN
 {*}    {Если это окно принадлежит предшествующему экземпляру...}
 {*}    IF GetWindowWord(H, GWW_HINSTANCE) = hPrevInst THEN
 {*}      BEGIN
 {*}        {... проверяем КАКОЕ это окно.}
 {*}        GetClassName(H, ClassName, 30);
 {*}        {Если это главное окно приложения...}
 {*}        IF StrIComp(ClassName, 'TApplication') = 0 THEN
 {*}          BEGIN
 {*}            {... ищем}
 {*}{*}            P^ := H;
 {*}            EnumWndProc := 0;
 {*}          END;
 {*}      END;
 {*}  END;
 
 {*}  PROCEDURE CheckPrevInst;
 {*}  VAR PrevWnd : hWnd;
 {*}  BEGIN
 {*}    IF hPrevInst <> 0 THEN
 {*}      {Предыдущий экземпляр запущен}
 {*}      BEGIN
 {*}        PrevWnd := 0;
 {*}        EnumWindows(@EnumWndProc, LongInt(@PrevWnd));
 {*}        {Ищем дескриптор окна предыдущего}
 {*}        {экземпляра и активизируем его}
 {*}        IF PrevWnd <> 0 THEN
 {*}          IF IsIconic(PrevWnd) THEN
 {*}            ShowWindow(PrevWnd, SW_SHOWNORMAL)
 {*}          ELSE BringWindowToTop(PrevWnd);
 {*}        Halt;
 {*}      END;
 {*}  END;
 begin
 {*}  CheckPrevInst;
 
 Application.Title := 'Once';
 Application.CreateForm(TForm1, Form1);
 Application.Run;
 end.
 




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

Автор: Галимарзанов Фанис

TForm имеет свойство ActiveControl. Очень часто требуется для нескольких DBGrid на форме обеспечить обработку через общий TSpeedBar. Посмотрите, как описан код обработки события Click кнопки SpeedBar - циклический просмотр на совпадение ActiveControl.Name с именем Grid.


 procedure TfmAb.insClick(Sender: TObject); // кнопка "Новая запись"
 begin
   if ActiveControl.Name='grFio' then
     EditAbProps(true)
   else
   if ActiveControl.Name='grAbLgot' then
     EditAbLgot(grAbLgot.DataSource,true)
   else
     ............
 end;
 

или


 procedure TfmAbDelClick(Sender: TObject); // кнопка "Удалить запись"
 begin
   if ActiveControl.Name='grFio' then
     DelRec(dm.taAb)
   else
   if ActiveControl.Name='grAbLgot' then
     DelRec(dm.taAbLgot)
   else
     ............
 end;
 




ActiveControl имеет DataSet

Автор: OAmiry (Borland)

Для успешного кодирования необходимо включить typinfo в список используемых модулей. Код данного примера инвертирует логическое свойство Active набора данных, связанного с активным элементом управления при каждом нажатии пользователем клавиши ESC.


 procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 var
   PropInfo: PPropInfo;
   PropValue: TObject;
   ds: TDataSource;
 begin
   if Key = VK_ESCAPE then
     { Основной код ниже }
   try
     ds := nil;
     { Проверяем, имеет ли компонент свойство DataSource }
     PropInfo := GetPropInfo(ActiveControl.ClassInfo, 'DataSource');
     if PropInfo <> nil then
       { Свойство компонента datasource типа class (например, TDataSource) }
       if PropInfo^.PropType^.Kind = tkClass then
       begin
         PropValue := TObject(GetOrdProp(ActiveControl, PropInfo));
         { Создаем слепок найденного TDataSource }
         ds := (PropValue as DB.TDataSource);
         { Используем dataset, связанный с datasource }
         if not (ds.DataSet.State in dsEditModes) then
           ds.DataSet.Active := not ds.DataSet.Active;
       end;
   except
     on E: EInvalidCast do
       ShowMessage('Ошибка. Ожидался DataSource');
   end;
 end;
 




Связка ActiveX - Internet Explorer


Спрашиваю я детей, как то:
- А что самое главное при работе с компьютером?
А они мне отвечают:
- Главное сразу не упасть в обморок.

А знаете ли вы, что на Delphi можно писать ActiveX компоненты? Конечно знаете. А что с их помощью можно взаимодействовать с Internet Explorer? Это может быть интересно для профессиональных вебмастеров, скажете вы, но я не согласен. "Простой" программист тоже может найти массу применений этому. Здесь будет описано одно из них. Все мы лазим (ходим и т.д.) по интернету. И вы тоже - раз читаете эти строки :). А не случалось ли вам, случайно где-то побывав, что-то прочитав и благополучно забыв адрес сайта через некоторое время вдруг понять, что там было именно то, что вам сейчас срочно понадобилось? Можно конечно посмотреть History браузера, можно залезть в кэш "руками" и попытаться найти там что-то. А можно написать компонент, который бы искал слова в файлах кэша (в общем случае в любых HTML-файлах) и выводил бы на просмотр требуемые файлы. Связать этот компонент с Эксплорером - и вперед. Что удобно - вся работа происходит в эксплорере: и поиск, и,естественно, просмотр. При этом для Delphi-программиста не нужны особые знания языка HTML, скриптовых языков и т.п. Достаточно знать несколько основных конструкций (а уж справочных руководств в интернете навалом - хотя бы на http://www.citforum.ru). Написанный ActiveX-компонент вставляется в HTML-страничку. Вот пример простейшей странички


<HTML>
   <HEAD>
     <TITLE>Поиск</TITLE>
   </HEAD>
   <BODY>
     <P ALIGN=CENTER>
       <OBJECT ID="findword1" - {при помощи этого тэга компонент вставляется в страничку}
       CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
       CODEBASE="C:\PATH\FINDWORDS.OCX">
       </OBJECT>
     </P>
   </BODY>
</HTML>



В этом примере ActiveX-компонент, находящийся в файле C:\PATH\FINDWORDS.OCX вставляется в HTML-страничку. Но важно отметить, что эта страничка откроется только в Microsoft Internet Explorer версии 4 и старше. Пишут, что третий эксплорер тоже поддерживает тэг <OBJECT>, но сам не пробовал, не знаю. Браузеры Netscape, Opera и какие еще там бывают, его не поддерживают.

Итак, тэг <OBJECT> вставляет в страничку ActiveX-компонент. Его атрибут CLASSID указывает идентификатор класса нашего компонента. При создании в Delphi компонента с нуля ему автоматически присваивается этот идентификатор класса. ID="findword1" - имя объекта. Здесь можно писать любое имя. По нему мы в дальнейшем будем ссылаться на наш компонент в теле странички из скриптов-процедур обработки событий. Далее, для того, чтобы наш компонент мог использоваться прикладными программами, он должен быть зарегистрирован в реестре. Зарегистрировать его можно программой regsvr32, которая по умолчанию находится в каталоге [System]. Например так: [regsvr32 C:\PATH\FINDWORDS.OCX]. Если при открытии странички Explorer не находит в реестре указанный компонент, то он ищет его в местоположении, указанном атрибутом CODEBASE. Здесь может быть полный путь к файлу, если он находится на вашем жестком диске или даже URL-адрес (со всеми сопутствующими атрибутами, как то http:// и т.д.).Т.е, если эксплорер встретил ссылку на компонент, а этого компонента нет на вашей машине, он может загрузить его из интернета с указанного адреса. Кстати, атрибут CLASSID - обязательный, именно по нему производится "идентификация" класса. А атрибут CODEBASE - необязательный. В случае, когда он опущен, если компонент уже зарегистрирован в системе, то он отобразится в вашей страничке, если не зарегистрирован - страничка будет пустой. И наконец если эксплорер сам регистрирует компонент, он переписывает файл OCX в папку [Windows\Downloaded program files].

Для того, чтобы вручную не писать скрипты подсоединения ActiveX компонентов, я советую скачать программу Microsoft ActiveX Control Pad. Эта программа предназначена для внедрения ActiveX-компонентов в HTML-странички. После ее работы определение компонента выглядит примерно так:


<OBJECT ID="findword1"
CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
CODEBASE="C:\PATH\FINDWORDS.OCX">
<PARAM NAME="Visible" VALUE="-1">
<PARAM NAME="AutoScroll" VALUE="0">
<PARAM NAME="AutoSize" VALUE="0">
<PARAM NAME="AxBorderStyle" VALUE="1">
<PARAM NAME="Caption" VALUE="findword">
<PARAM NAME="Color" VALUE="2147483663">
<PARAM NAME="Font" VALUE="MS Sans Serif">
<PARAM NAME="KeyPreview" VALUE="0">
<PARAM NAME="PixelsPerInch" VALUE="96">
<PARAM NAME="PrintScale" VALUE="1">
<PARAM NAME="Scaled" VALUE="-1">
<PARAM NAME="DropTarget" VALUE="0">
<PARAM NAME="HelpFile" VALUE="">
<PARAM NAME="DoubleBuffered" VALUE="0">
<PARAM NAME="Enabled" VALUE="-1">
<PARAM NAME="BiDiMode" VALUE="0">
<PARAM NAME="Cursor" VALUE="0">
<PARAM NAME="filename" VALUE="nothing">
</OBJECT>



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

Теперь подходим к самому главному: как сделать сам компонент (чтобы было что вставлять в нашу страничку :). Итак, в Delphi делаем New\ActiveX\Active form. В окошке Active Form Wizard выбираем Threading model=Apartment. Другие threading models не работают с IE 4. Выглядит это так: компонент в страничке открывается, но иногда вдруг выскакивает Access violation. (обычно на событие Create). Модель же Both работает с IE 5. Флажок "Include Design-Time licence" лучше не устанавливать. Дальше открывается новая форма, где вы можете размещать свои кнопки-текстбоксы, определять реакцию на события и т.д.

Далее будут описаны некоторые хитрости. Например, нужно хранить некоторые данные во внешнем файле. Я столкнулся со следующим: мой компонент на разных машинах размещал свои файлы в разных местах: на одной в каталоге Windows, на другой - на рабочем столе. Был найден такой выход: пусть страничка по требованию компонента возвращает ему каталог, в котором она находится. Для этого на форму я поместил PageControl, сделал закладки невидимыми и на OnShow (у формы ActiveX компонента нет события OnShow) одной из страниц поставил генерацию собственного события OnWantDir. А в теле HTML-странички соответственно реакцию на него:


<SCRIPT LANGUAGE="VBScript">
<!--
Sub findword1_OnWantDir()
findword1.page_location = location.href
end sub
-->

</SCRIPT>



Далее, это событие OnShow происходит сразу после создания экземпляра компонента. Так вот, если событие OnWantDir генерировать непосредственно в нем (в OnShow), то видимо что-то в недрах Windows не успевает провернуться и машина виснет. Поэтому пришлось повесить на форму таймер, на OnShow таймер запускать, и уже на OnTimer как раз и вызывать свое событие OnWantDir. Интервал у таймера я поставил в полсекунды. Конечно можно было бы хранить свои файлы например в каталоге [Windows], но почему-то функция GetWindowsDirectory при вызове из ActiveX-компонента возвращала ошибку, хотя тут же нормально отрабатывала из обыкновенного приложения (exe). То же и с GetSystemDirectory и GetTempDirectory. Кто не знает как делать собственные свойства и события - кликайте сюда.

Как сделать компонент тиражируемым? Чтобы пользователь смог работать с ним сразу же, не запуская никаких дополнительных программ, не указывая всяких-разных путей и т.д. Вот пример HTML-странички:


<html>
 <HEAD>
  <title>Поиск</title>
  <SCRIPT LANGUAGE="VBScript">
  <!--
   Sub Procedure1()
   location.href = findword1.NewStroke
   {Получить от компонента имя файла
и открыть его для просмотра. Эта
процедура запускается при
возникновении события OnDocClick. Location - объект
Explorer'а (см. документацию по VBScript)}
   end sub
  -->

  </SCRIPT>
 </HEAD>
 <BODY>
  <SCRIPT LANGUAGE="VBScript">
  <!--
   Sub findword1_OnWantDir()
   findword1.page_location = location.href
   {Получить текущий каталог, т.е.
свойству page_location объекта присвоить
местоположение нашей странички}

   end sub
   Sub findword1_OnDocClick()
   {При возникновении события OnDocClick
вызвать процедуру Procedure1 (открыть файл
для просмотра)}
   call Procedure1()
   end sub
  -->

  </SCRIPT>
  <p align = "center">
   <OBJECT ID="findword1"
   CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
   CODEBASE="findwords.ocx">
   {Здесь просто имя файла без
пути. Explorer зарегистрирует компонент
невидимо для пользователя, взяв
его из текущего каталога (страничка
и файл OCX находятся в одном каталоге)}
   <PARAM NAME="Visible" VALUE="-1">
   <PARAM NAME="AutoScroll" VALUE="0">
   <PARAM NAME="AutoSize" VALUE="0">
   <PARAM NAME="AxBorderStyle" VALUE="1">
   <PARAM NAME="Caption" VALUE="findword">
   <PARAM NAME="Color" VALUE="2147483663">
   <PARAM NAME="Font" VALUE="MS Sans Serif">
   <PARAM NAME="KeyPreview" VALUE="0">
   <PARAM NAME="PixelsPerInch" VALUE="96">
   <PARAM NAME="PrintScale" VALUE="1">
   <PARAM NAME="Scaled" VALUE="-1">
   <PARAM NAME="DropTarget" VALUE="0">
   <PARAM NAME="DoubleBuffered" VALUE="0">
   <PARAM NAME="Enabled" VALUE="-1">
   <PARAM NAME="BiDiMode" VALUE="0">
   <PARAM NAME="Cursor" VALUE="0">
   <PARAM NAME="filename" VALUE="nothing">
   <PARAM NAME="page_location" VALUE="">
  </OBJECT>
  </p>
 </BODY>
</html>



И еще раз:

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




Управление свойством Font через сервер автоматизации

"Сервера" - это такое специальное слово, которым системные инженера называют особо мощные компьютера. А еще они частенько ищут драйвера, чтобы подключать сканера, и покупают тонера, чтобы устанавливать в принтера. За что их и уважают юзера.

Данный документ предназначен главным образом тем программистам, кто использует OLE/COM и хочет встроить объект Font (типа Delphi-го TFont) в свой сервер автоматизации. Интерфейс IFontDisp для COM будет иметь ту же функциональность, что и Delphi-ий TFont. Например, если у вас имеется клиент автоматизации, содержащий объект со свойством Font, и в сервере автоматизации для изменения атрибутов текста вы хотите иметь те же методы (наприр, имя шрифта, жирное или наклонное начертание). Для хранения и управления шрифтом сервер автоматизации может применять реализацию интерфейса IFontDisp.

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

Демонстрационный проект содержит следующие модули:

Project1_TLB: Паскалевская обертка для библиотеки типов, содержащей определение интерфейса.

Unit1: Реализация интерфейса: код, содержащий описание свойств интерфейса и реализующий его методы.

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

FontCli: Клиент автоматизации, получающий ссылку на интерфейс, и использующий его методы.

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

  1. Выберите пункт меню File|New|ActiveX|Automation Object и в Мастере Automation Object Wizard выберите в качестве имени класса MyFontServer. Создайте единственное свойство с именем MyFont и типом IFontDisp. Для получения дополнительной информции смотри Developer's Guide, chapter 42 (руководство разработчика, глава 42), там подробно описана работа с библиотеками типов и создание интерфейсов в редакторе библиотеки типов.
  2. В предыдущем шаге при добавлении интерфейса с помошью редактора библиотеки типов вы должны были получить паскалевский модуль-обертку (в нашем примере модуль имеет имя Unit1). Unit1 будет содержать обертку реализаций методов получения и назначения свойства MyFont. На данном этапе вы обеспечите хранение значений свойства MyFont в форме FFont (TFont) и добавите код реализации, наполняющий функциональностью методы получения и установки (get/set).

    Unit1 использует Unit2. Unit2 содержит форму, компонент Memo и StatusBar для отображения каждого реализованного метода, для диагностических целей.

  3. Создайте Unit2, содержащий форму с компонентами TMemo и TStatusBar. Форма используется для отображения жизнедеятельности в модуле Unit1.pas. Это шаг не является строго обязательным, он помогает понять что происходит в данный момент между клиентом автоматизации и сервером.
  4. Создайте клиент автоматизации. В нашем случае модуль имеет имя FontCli, содержит метку, показывающую текущий шрифт и кнопку, устанавливающую MyFont на сервере.

 unit Project1_TLB;
 
 { Данный файл содержит паскалевские декларации, импортированные из
 библиотеки типов. Данный файл записывается во время каждого импорта
 или обновления (refresh) в редакторе библиотеки типов. Любые изменения
 в данном файле будут потеряны в процессе очередного обновления. }
 
 { Библиотека Project1 }
 { Версия 1.0 }
 
 interface
 
 uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL;
 
 const
 
   LIBID_Project1: TGUID = '{29C7AC94-0807-11D1-B2BA-0020AFF2F575}';
 
 const
 
   { GUID'ы класса компоненты }
 
   Class_MyFontServer: TGUID = '{29C7AC96-0807-11D1-B2BA-0020AFF2F575}';
 
 type
 
   { Предварительные объявления: Интерфейсы }
 
   IMyFontServer = interface;
   IMyFontServerDisp = dispinterface;
 
   { Предварительные объявления: CoClasse'ы }
 
   MyFontServer = IMyFontServer;
 
   { Диспинтерфейс для объекта MyFontServer }
 
   IMyFontServer = interface(IDispatch)
     ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
     function Get_MyFont: IFontDisp; safecall;
     procedure Set_MyFont(const Value: IFontDisp); safecall;
     property MyFont: IFontDisp read Get_MyFont write Set_MyFont;
   end;
 
   { Объявление диспинтерфейса для дуального интерфейса IMyFontServer }
 
   IMyFontServerDisp = dispinterface
     ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
     property MyFont: IFontDisp dispid 1;
   end;
 
   { MyFontServerObject }
 
   CoMyFontServer = class
     class function Create: IMyFontServer;
     class function CreateRemote(const MachineName: string): IMyFontServer;
   end;
 
 implementation
 
 uses ComObj;
 
 class function CoMyFontServer.Create: IMyFontServer;
 begin
 
   Result := CreateComObject(Class_MyFontServer) as IMyFontServer;
 end;
 
 class function CoMyFontServer.CreateRemote(const MachineName: string):
 
 IMyFontServer;
 begin
 
   Result := CreateRemoteComObject(MachineName, Class_MyFontServer) as
     IMyFontServer;
 end;
 
 end.
 
 {--------------------------------------------------------------------}
 
 unit Unit1;
 
 interface
 
 uses
 
   ComObj, Project1_TLB, ActiveX, Graphics;
 
 type
 
   TMyFontServer = class(TAutoObject, IMyFontServer)
   private
     FFont: TFont;
   public
     procedure Initialize; override;
     destructor Destroy; override;
     function Get_MyFont: IFontDisp; safecall;
     procedure Set_MyFont(const Value: IFontDisp); safecall;
   end;
 
 implementation
 
 uses ComServ, AxCtrls, Unit2;
 
 procedure TMyFontServer.Initialize;
 begin
 
   inherited Initialize;
   FFont := TFont.Create;
 end;
 
 destructor TMyFontServer.Destroy;
 begin
 
   FFont.Free;
   inherited Destroy;
 end;
 
 function TMyFontServer.Get_MyFont: IFontDisp;
 begin
 
   FFont.Assign(Form2.Label1.Font);
   GetOleFont(FFont, Result);
 end;
 
 procedure TMyFontServer.Set_MyFont(const Value: IFontDisp);
 begin
 
   SetOleFont(FFont, Value);
   Form2.Label1.Font.Assign(FFont);
 end;
 
 initialization
 
   TAutoObjectFactory.Create(ComServer, TMyFontServer, Class_MyFontServer,
     ciMultiInstance);
 end.
 
 {--------------------------------------------------------------------}
 
 unit Unit2;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
 
   TForm2 = class(TForm)
     Label1: TLabel;
   end;
 
 var
 
   Form2: TForm2;
 
 implementation
 
 {$R *.DFM}
 
 end.
 
 {--------------------------------------------------------------------}
 
 unit FontCli1;
 
 interface
 
 uses
 
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, StdVCL, Project1_TLB;
 
 type
 
   TForm1 = class(TForm)
     Button1: TButton;
     Label1: TLabel;
     FontDialog1: TFontDialog;
     procedure Button1Click(Sender: TObject);
     procedure FormCreate(Sender: TObject);
   public
     MyFontServer: IMyFontServer;
   end;
 
 var
 
   Form1: TForm1;
 
 implementation
 
 uses ActiveX, AxCtrls;
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
 
   Temp: IFontDisp;
 begin
 
   if (FontDialog1.Execute) then
   begin
     Label1.Font.Assign(FontDialog1.Font);
     GetOleFont(Label1.Font, Temp);
     MyFontServer.Set_MyFont(Temp);
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   MyFontServer := CoMyFontServer.Create;
 end;
 
 end.
 

Так для чего нам Unit1, создающий реализацию интерфейса? Интерфейс Ole, такой как, например, IFontDisp, может считаться соглашением о том, что свойства и функции будут определены в заданном формате, а функции будут реализованы как определено (для получения дополнительной информации смотри Руководство Разработчика, главу 36, "An Overview of COM" (Обзор COM). Тот факт, что интерфейс определен, не означает, что он реализован. Например, чтобы заставить определенный вами интерфейс IFontDisp быть полезным, необходимо обеспечить хранение шрифта и механизм добавления и извлечения информации об атрибутах шрифта, таких, как имя шрифта, наклонное начертание, размер и пр.

Примечание:

GetOleFont и SetOleFont определены в AxCtrls.pas. IFontDisp определен в ActiveX.pas




Кнопка заголовка активного окна

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


 procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
 var
   R: TRect;
 begin
   inherited;
   Canvas.Handle := GetWindowDC(Handle);
   R := Bounds(GetSystemMetrics(SM_CXFRAME) +
     GetSystemMetrics(SM_CXSIZE) + 1,
     GetSystemMetrics(SM_CYFRAME),
     GetSystemMetrics(SM_CXSIZE),
     GetSystemMetrics(SM_CYSIZE));
   with Canvas do
   begin
     Brush.Color := clRed;
     Pen.Color := clLime;
     Rectangle(R.Left, R.Top, R.Right, R.Bottom);
   end;
   ReleaseDC(Handle, Canvas.Handle);
 end;
 




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

Для этого необходимо написать процедуру-обработчик для Application.OnMessage:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnMessage := AppOnMessage;
 end;
 
 procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
 var ccode: Word;
 begin
   case Msg.Message of
     WM_KEYDOWN, WM_KEYUP:
       begin
         if (GetKeyState(VK_NUMLOCK) >= 0) //NumLock не включ¸н
           and ((Msg.lparam and $1000000) = 0)
           then
         begin
           ccode := 0;
           case Msg.wparam of
             VK_HOME: ccode := VK_NUMPAD7;
             VK_UP: ccode := VK_NUMPAD8;
             VK_PRIOR: ccode := VK_NUMPAD9;
             VK_LEFT: ccode := VK_NUMPAD4;
             VK_CLEAR: ccode := VK_NUMPAD5;
             VK_RIGHT: ccode := VK_NUMPAD6;
             VK_END: ccode := VK_NUMPAD1;
             VK_DOWN: ccode := VK_NUMPAD2;
             VK_NEXT: ccode := VK_NUMPAD3;
             VK_INSERT: ccode := VK_NUMPAD0;
             VK_DELETE: ccode := VK_DECIMAL;
           end;
           if ccode <> 0 then Msg.Wparam := ccode;
         end;
       end;
   end;
 end;
 




Как подключить и отключить сетевые диски

Звонит один мужик своему интернет-провайдеру и говорит оператору:
- Алло, здраствуйте, у меня проблема! Я не могу зайти в интернет!
- А в чем, собственно говоря, дело?
- А у меня нет компьютера.

Для работы с сетевыми дисководами (и ресурсами типа LPT порта) в WIN API 16 и WIN API 32 следующие функции:

Подключить сетевой ресурс:


 WNetAddConnection(NetResourse, Password, LocalName: PChar): longint;
 

где

  1. NetResourse - имя сетевого ресурса (например '\\P166\c')
  2. Password - пароль на доступ к ресурсу (если нет пароля, то пустая строка)
  3. LocalName - имя, под которым сетевой ресурс будет отображен на данном компьютере (например 'F:')

Пример подключения сетевого диска:


 WNetAddConnection('\\P166\C', '', 'F:');
 

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые:

  • NO_ERROR - Нет ошибок - успешное завершение
  • ERROR_ACCESS_DENIED - Ошибка доступа
  • ERROR_ALREADY_ASSIGNED - Уже подключен. Наиболее часто возникает при повторном вызове данной функции с теми-же параметрами.
  • ERROR_BAD_DEV_TYPE - Неверный тип устройства.
  • ERROR_BAD_DEVICE - Неверное устройство указано в LocalName
  • ERROR_BAD_NET_NAME - Неверный сетевой путь или сетевое имя
  • ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
  • ERROR_INVALID_PASSWORD - Неверный пароль
  • ERROR_NO_NETWORK - Нет сети

Отключить сетевой ресурс


 WNetCancelConnection(LocalName: PChar; ForseMode: Boolean): Longint;
 

где

  1. LocalName - имя, под которым сетевой ресурс был подключен к данному компьютеру (например 'F:')
  2. ForseMode - режим отключения :
    • False - корректное отключение. Если отключаемый ресурс еще используется, то отключения не произойдет (например, на сетевом диске открыт файл)
    • True - скоростное некорректное отключение. Если ресурс используется, отключение все равно произойдет и может привести к любым последствиям (от отсутствия ошибок до глухого повисания)

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые:

  • NO_ERROR - Нет ошибок - успешное завершение
  • ERROR_DEVICE_IN_USE - Ресурс используется
  • ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
  • ERROR_NOT_CONNECTED - Указанное ус-во не является сетевым
  • ERROR_OPEN_FILES - На отключаемом сетевом диске имеются открытые файлы и параметр ForseMode=false

Рекомендация: при отключении следует сначала попробовать отключить ус-во с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true.




Добавляем компонент в стандартный Message Dialog

Пример показывает стандартное диалоговое окно, которое обычно используется для подтверждения дальнейших действий в любой программе с галочкой "Don't show this message again."

Используем функцию CreateMessageDialog и добавляем любой компонент до того как будет вызвана ShowModal.

Например:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   AMsgDialog: TForm;
   ACheckBox: TCheckBox;
 begin
   AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]);
   ACheckBox := TCheckBox.Create(AMsgDialog);
 
   with AMsgDialog do
     try
       Caption := 'Dialog Title' ;
       Height := 169;
 
       with ACheckBox do
       begin
         Parent := AMsgDialog;
         Caption := 'Don''t show me again.';
         top := 121;
         Left := 8;
         Width := 140;
       end;
 
       case ShowModal of
         ID_YES: ;//здесь Ваш код после того как диалог будет закрыт
         ID_NO: ;
       end;
 
       if ACheckBox.Checked then
       begin
         //...
       end;
 
     finally
       ACheckBox.Free;
       Free;
     end;
 end;
 




Добавить данные в EXE файл и получить их

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


 function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
 var
   aStream: TFileStream;
   iSize: Integer;
 begin
   Result := False;
   if not FileExists(AFileName) then
     Exit;
   try
     aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
     MemoryStream.Seek(0, soFromBeginning);
     // seek to end of File 
     // ans Ende der Datei Seeken 
     aStream.Seek(0, soFromEnd);
     // copy data from MemoryStream 
     // Daten vom MemoryStream kopieren 
     aStream.CopyFrom(MemoryStream, 0);
     // save Stream-Size 
     // die Streamgro?e speichern 
     iSize := MemoryStream.Size + SizeOf(Integer);
     aStream.Write(iSize, SizeOf(iSize));
   finally
     aStream.Free;
   end;
   Result := True;
 end;
 
 function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
 var
   aStream: TFileStream;
   iSize: Integer;
 begin
   Result := False;
   if not FileExists(AFileName) then
     Exit;
 
   try
     aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
     // seek to position where Stream-Size is saved 
     // zur Position seeken wo Streamgro?e gespeichert 
     aStream.Seek(-SizeOf(Integer), soFromEnd);
     aStream.Read(iSize, SizeOf(iSize));
     if iSize > aStream.Size then
     begin
       aStream.Free;
       Exit;
     end;
     // seek to position where data is saved 
     // zur Position seeken an der die Daten abgelegt sind 
     aStream.Seek(-iSize, soFromEnd);
     MemoryStream.SetSize(iSize - SizeOf(Integer));
     MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
     MemoryStream.Seek(0, soFromBeginning);
   finally
     aStream.Free;
   end;
   Result := True;
 end;
 
 procedure TForm1.SaveClick(Sender: TObject);
 var
   aStream: TMemoryStream;
 begin
   aStream := TMemoryStream.Create;
   Memo1.Lines.SaveToStream(aStream);
   AttachToFile('Test.exe', aStream);
   aStream.Free;
 end;
 
 procedure TForm1.LoadClick(Sender: TObject);
 var
   aStream: TMemoryStream;
 begin
   aStream := TMemoryStream.Create;
   LoadFromFile('Test.exe', aStream);
   Memo1.Lines.LoadFromStream(aStream);
   aStream.Free;
 end;
 
 {
 
 Note:
 
 You can't proof whether additional data is attached or not.
 To reach this, you would have to create a checksumm of the
 MemoryStream and attach it.
 
 }
 




Как добавить документ в меню Документы кнопки ПУСК



 uses
   ShlOBJ;
 ...
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: string;
 begin
   s := 'C:\1\DelphiWorld.html'; //Здесь указываем имя нужного файла
   SHAddToRecentDocs(SHARD_PATH, pChar(s));
 end;
 




Добавление события OnMouseLeave

Автор: Briculski

По ее голому животу бежала мышь. Ниже, ниже... но на самом интересном месте коврик кончился.

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


 procedure CMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;
 procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
 ..
 ..
 ..
 procedure MyComponent.CMMouseEnter(var msg:TMessage);
 begin
 
 inherited;
 {действия на вход мыши в область компонента}
 end;
 
 procedure MyComponent.CMMouseLeave(var msg: TMessage);
 begin
 
 inherited;
 {действия на покидание мыши области компонента}
 end;
 

Дополнение

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

  1. MouseEnter - когда событие мыши входит в пределы визуального компонента;
  2. MouseLeave - когда событие мыши оставляет его пределы.
Известно, что все Delphi объявляет эти сообщения в виде:
  1. Cm_MouseEnter;
  2. Cm_MouseLeave.

Т.е. все визуальные компоненты, которые порождены от TControl, могут отлавливать эти события. Следующий пример показывает как создать наследника от TLabel и добавить два необходимых события OnMouseLeave и OnMouseEnter.


 (*///////////////////////////////////////////////////////*)
 (*// Author: Briculski Serge
 (*// E-Mail: bserge@airport.md
 (*// Date: 26 Apr 2000
 (*///////////////////////////////////////////////////////*)
 
 unit BS_Label;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls;
 
 type
   TBS_Label = class(TLabel)
   private
     { Private declarations }
     FOnMouseLeave: TNotifyEvent;
     FOnMouseEnter: TNotifyEvent;
     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
     property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
     property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
   RegisterComponents('Custom', [TBS_Label]);
 end;
 
 { TBS_Label }
 
 procedure TBS_Label.CMMouseEnter(var Message: TMessage);
 begin
   if Assigned(FOnMouseEnter) then
     FOnMouseEnter(Self);
 end;
 
 procedure TBS_Label.CMMouseLeave(var Message: TMessage);
 begin
   if Assigned(FOnMouseLeave) then
     FOnMouseLeave(Self);
 end;
 
 end.
 




Добавить EXE файл в своё приложение и запустить его

1. Start notepad and create a .rc-file that looks like this:
Starte Notepad und erstelle ein .rc-file, das etwa so aussieht:


 TESTFILE EXEFILE C:\Windows\Notepad.exe
 

(Make sure that the Path to your Exe-File is correct!)
(Stelle sicher, dass der Pfad zur Exe-Datei korrekt ist!)

2. Save it as myres.rc
Speichere es als myres.rc

3. Compile the file with brcc32.exe
(in your Delphi-bin directory) to get myres.res
Kompiliere die Datei mit brcc32.exe
(Im Delphi-bin Verzeichnis) um die Datei myres.res zu erhalten.

4. Copy myres.res to your Project directory.
Kopiere myres.res in das entsprechende Projekt-Verzeichnis.

5. In your unit write the following:
In der unit, schreibe etwa das folgende:


 var
   Form1: TForm1;
   NOTEPAD_FILE: string;
 
 implementation
 
 {$R *.DFM}
 {$R MYRES.RES}
 
 function GetTempDir: string;
 var
   Buffer: array[0..MAX_PATH] of Char;
 begin
   GetTempPath(SizeOf(Buffer) - 1, Buffer);
   Result := StrPas(Buffer);
 end;
 
 // Extract the Resource 
 function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
 var
   Res: TResourceStream;
 begin
   Result := False;
   Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
   try
     Res.SavetoFile(ResNewName);
     Result := True;
   finally
     Res.Free;
   end;
 end;
 
 // Execute the file 
 procedure ShellExecute_AndWait(FileName: string);
 var
   exInfo: TShellExecuteInfo;
   Ph: DWORD;
 begin
   FillChar(exInfo, SizeOf(exInfo), 0);
   with exInfo do
   begin
     cbSize := SizeOf(exInfo);
     fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
     Wnd := GetActiveWindow();
     ExInfo.lpVerb := 'open';
     lpFile := PChar(FileName);
     nShow := SW_SHOWNORMAL;
   end;
   if ShellExecuteEx(@exInfo) then
   begin
     Ph := exInfo.HProcess;
   end
   else
   begin
     ShowMessage(SysErrorMessage(GetLastError));
     Exit;
   end;
   while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
     Application.ProcessMessages;
   CloseHandle(Ph);
 end;
 
 // To Test it 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then
     if FileExists(NOTEPAD_FILE) then
     begin
       ShellExecute_AndWait(NOTEPAD_FILE);
       ShowMessage('Notepad finished!');
       DeleteFile(NOTEPAD_FILE);
     end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';
 end;
 




Добавляем файлы в Recent Documents list

Предположим Вам захотелось, чтобы Ваше программа сама умела добавлять файлы "recent documents list" (для тех, кто в танке - это такая менюшка, которая появляется при нажатии на кнопку Пуск(Start) и наведении мышкой на "Документы" (Documents). Сама функция API-шная, так что применять её можно в любом компиляторе.

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


 const
 SHARD_PIDL = 1;
 SHARD_PATH = 2;
 
 procedure SHAddToRecentDocs(Flags: Word; pfname: Pointer); stdcall; external 'shell32.dll' name'SHAddToRecentDocs';
 

А так выглядит вызов этой функции:


 SHAddTorecentDocs(SHARD_PATH,pchar('C:\mydir\myprogram.exe'));
 

файл 'myprogram.exe' будет добавлен в recent documents list




Прибавить час

Тип TDateTime, используемый для передачи даты и времени, это тип double, у которого целая часть определяет день, а дробная время от полуночи. То есть, если прибавить ко времени 1, то дата изменится на один день, а время не изменится. Если прибавить 0.5, то прибавится 12 часов. Причем этот метод работает даже в том случае, когда меняется дата, месяц или год.


 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   Label1.Caption := DateTimeToStr(Time);
   Label2.Caption := DateTimeToStr(Time + 1 / 24);
 end;
 




Как добавить горизонтальную полосу прокрутки в TListBox

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


 procedure TForm1.FormCreate(Sender: TObject);
 var
   i, MaxWidth: integer;
 begin
   MaxWidth := 0;
   for i := 0 to ListBox1.Items.Count - 1 do
     if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
       MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
   SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
 end;
 

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




Пример добавления пункта в контекстное меню Windows Explorer

Как объявил недавно основатель Microsoft Билл Гейтс, его компания пожертвует 100 млн. долларов на прививки против менингита и заболеваний дыхательных путей детям в развивающихся странах. Стало также известно, что, в рамках этой благотворительной акции, на детей будет бесплатно установлен Internet Explorer 5.


 // Откройте Delphi, выберите в меню New... Dynamic link library
 // Скопируйте нижеприведенный текст DLL
 // Скомпилируйте проект.
 // Теперь нужно зарегистрировать полученную библиотеку.
 // Наберите в командной строке regsvr32.exe sendtoweb.dll
 // После этого откройте Windows Explorer и вы увидите новый
 // пункт меню...
 
 unit Sendtoweb;
 
 // Author C Pringle Cjpsoftware.com
 
 { Реализация COM объекта расширения оболочки Windows Explorer. Этот
   COM объект способен перенаправлять запросы компоненту TPopupMenu. Компонент
   TPopupMenu должен находиться  на форме MenuComponentForm.
   Вы можете модернизировать код для большей гибкости.
 
   Компонент TContextMenu регистрируется как  глобальным обработчик
   контекстного меню. Это достигается модификацией ключа реестра
   HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers.
 
   jfl
 }
 
 interface
 
 uses
 
   Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus,
   ShellAPI, SysUtils, registry;
 
 type
   TContextMenuFactory = class(TComObjectFactory)
   public
     procedure UpdateRegistry(Register: Boolean); override;
   end;
 
   TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
   private
     FFileName: string;
     function BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
       var IDCmdFirst: Integer): HMENU;
   protected
     szFile: array[0..MAX_PATH] of Char;
     // Необходимо для исключения предупреждения компилятора о неоднозначности
     function IShellExtInit.Initialize = IShellExtInit_Initialize;
   public
     { IShellExtInit }
     function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj:
       IDataObject;
       hKeyProgID: HKEY): HResult; stdcall;
     { IContextMenu }
     function QueryContextMenu(Menu: HMENU;
       indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
     function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
     function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
       pszName: LPSTR; cchMax: UINT): HResult; stdcall;
   end;
 
 var
   // Должен быть инициализирован перед регистрацией TContextMenu!
   GFileExtensions: TStringList;
 
 const
   MenuCommandStrings: array[0..3] of string = (
     '', '&STW Web Upload', '&STW FTPClient', '&STW Setup'
     );
 
 implementation
 
 { TContextMenuFactory }
 { Public }
 
 function ReadDefaultPAth: string;
 var
   path: string;
   Reg: TRegistry;
 begin
 
   Reg := TRegistry.CReate;
   try
     with Reg do
     begin
       RootKey := HKEY_LOCAL_MACHINE;
       Path := 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths';
 
       if KeyExists(Path) then
       begin
         OpenKey(Path + '\sendtoweb.exe', false);
         Result := ReadString(#0);
         closekey;
       end;
 
       // Ключ добавлен в реестр.
 
     end;
   finally
     Reg.CloseKey;
     Reg.Free;
   end;
 
 end; // Код регистрации
 
 procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
 begin
   inherited UpdateRegistry(Register);
 
   // Регистрация нашего обработчика
   if Register then
   begin
     CreateRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb', '',
       GUIDToString(Class_ContextMenu));
     CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\' +
       ComServer.ServerKey, 'ThreadingModel', 'Apartment');
   end
   else
   begin
     DeleteRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb');
   end;
 end;
 
 { TContextMenu }
 { Private }
 
 { Построение контекстного меню с использованием хэндла существующего меню.
   Если Menu =  nil, мы создаем новый хэндл меню и возвращаем его как результат
   функции. Заметьте, что обработчик не поддерживаетвложенные (рекурсивные)
   меню. }
 
 function TContextMenu.BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
   var IDCmdFirst: Integer): HMENU;
 var
   i: Integer;
   menuItemInfo: TMenuItemInfo;
 begin
   if Menu = 0 then
     Result := CreateMenu
   else
     Result := Menu;
 
   // Подготавливаем меню
   with menuitemInfo do
   begin
     cbSize := SizeOf(TMenuItemInfo);
     fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
       MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE or MIIM_CHECKMARKS;
     fType := MFT_STRING;
     fState := MFS_ENABLED;
     hSubMenu := 0;
     hbmpChecked := 0;
     hbmpUnchecked := 0;
   end;
 
   for i := 0 to High(MenuCommandStrings) do
   begin
     if i = 0 then
       menuitemInfo.fType := MFT_SEPARATOR
     else
       menuiteminfo.ftype := MFT_String;
     if i = 1 then
       menuitemInfo.fstate := MFS_ENABLED or MFS_DEFAULT
     else
       menuitemInfo.fstate := MFS_ENABLED;
 
     menuitemInfo.dwTypeData := PChar(MenuCommandStrings[i]);
     menuitemInfo.wID := IDCmdFirst;
     InsertMenuItem(Result, IndexMenu + i, True, menuItemInfo);
     Inc(IDCmdFirst);
   end;
 end;
 
 { IShellExtInit }
 
 function TContextMenu.IShellExtInit_Initialize(pidlFolder: PItemIDList;
   lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
 var
   medium: TStgMedium;
   fe: TFormatEtc;
 
 begin
   with fe do
   begin
     cfFormat := CF_HDROP;
     ptd := nil;
     dwAspect := DVASPECT_CONTENT;
     lindex := -1;
     tymed := TYMED_HGLOBAL;
   end;
   // Ошибка, если  lpdobj = Nil.
   if lpdobj = nil then
   begin
     Result := E_FAIL;
     Exit;
   end;
   Result := lpdobj.GetData(fe, medium);
   if Failed(Result) then
     Exit;
   // Если выбран только один файл, получаем его имя и сохраняем в
   // szFile. иначе - ошибка.
   if DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
   begin
     DragQueryFile(medium.hGlobal, 0, szFile, SizeOf(szFile));
     Result := NOERROR;
   end
   else
     Result := E_FAIL;
   ReleaseStgMedium(medium);
 end;
 
 { IContextMenu }
 
 function TContextMenu.QueryContextMenu(Menu: HMENU;
   indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
 var
   extension: string;
   I: Integer;
   idLastCommand: Integer;
 begin
   Result := E_FAIL;
   idLastCommand := idCmdFirst;
 
   // Получаем расширение файла и определяем, есть ли для него
   // зарегистрированный обработчик
 //  extension := UpperCase( ( FFileName ) );
 
 //for i := 0 to GFileExtensions.Count - 1 do
 //   if Pos(Lowercase(GFileExtensions[ i ]),lowercase(extension))=0 then
   //  begin
   BuildSubMenu(Menu, indexMenu, idLastCommand);
   // Return value is number of items added to context menu
   Result := idLastCommand - idCmdFirst;
   //      Exit;
   //    end;
 end;
 
 function TContextMenu.InvokeCommand(var lpici:
   TCMInvokeCommandInfo): HResult;
 var
   idCmd: UINT;
 begin
   if HIWORD(Integer(lpici.lpVerb)) <> 0 then
     Result := E_FAIL
   else
   begin
     idCmd := LOWORD(lpici.lpVerb);
     Result := S_OK;
 
     // Активизация диалога и подготовка к послке данных в Web
 
     case idCmd of
       1:
         begin
 
           ShellExecute(GetDesktopWindow, nil,
             Pchar(ExtractFileName(ReadDefaultPath)),
             Pchar('Direct' + '"' + szfile + '"'), nil, SW_SHOW);
 
         end;
       3:
         begin
           ShellExecute(GetDesktopWindow, nil,
             Pchar(ExtractFileName(ReadDefaultPath)),
             Pchar('Path'), nil, SW_SHOW);
 
         end;
       2:
         ShellExecute(GetDesktopWindow, nil,
           Pchar(ExtractFileName(ReadDefaultPath)),
           PChar(''), nil, SW_SHOW);
     else
       Result := E_FAIL;
     end;
   end;
 end;
 
 function TContextMenu.GetCommandString(idCmd, uType: UINT;
   pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
 
 begin
   //  StrCopy( pszName, 'Send To The Web') ;
 
   Result := S_OK;
 end;
 
 initialization
   { Заметьте, что в данном фрагменте мы создаем экземпляр TContextMenuFactory,
   а не TComObjectFactory. }
   TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
     'ContextMenu', 'Send To The Web', ciMultiInstance);
 
   // Инициализируем список расширений
   GFileExtensions := TStringList.Create;
   // GFileExtensions.Add( 'setup msn' );
 
 finalization
   GFileExtensions.Free;
 end.
 




Причуда AddIndex

Автор: Mike Orriss

Подведены итоги лотереи "Windows 2000":
1. Выиграла фирма MicroSoft.
2. Разыграны миллионы чайников.

При попытке использования AddIndex я получаю ошибку 'Invalid Index/Tag name. (Неверное имя Индекса/Тэга) Index: cusname'. Но у меня нет никаких проблем с этим именем при использовании DeleteIndex.

Есть глючокс с именемани индексов:


 if IndexName = Fieldname then
   ixCaseSensitive is reqd //(по умолчанию)
 if IndexName <> Fieldname then
   ixCaseInsensitive is reqd
 

Таким образом, вам нужно:


 InvTbl.AddIndex('cusname', 'name', [ixCaseInsensitive]);
 

или


 InvTbl.AddIndex('name', 'name', []);
 




Проблема с AddIndex

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

Я использую таблицу paradox на своей локальной машине.

Я использую следующие команды:


 Table.DatabaseName := 'ABC';
 Table.TableName := 'TEST';
 Table.CreateTable;
 
 {работает как часы}
 Table.AddIndex('Primary','ID',[ixPrimary]);
 {здесь я получаю ошибку времени выполнения}
 Table.AddIndex('Number_IDX','NUMBER',[ixUnique]);
 

ID - LongInt поле
NUMBER - поле типа char[15]




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

Системное меню вызывается по нажатию на иконку окна. Оно содержит такие команды как "Развернуть", "Восстановить", "Переместить" и т.д. Так вот, теперь у вас появилась возможность добавлять новые пункты к системному меню приложения и обрабатывать их нажатие! Для этого воспользуемся функцией AppendMenu(). В качестве параметров этой функции нужно указать:

  1. Дескриптор того меню, которое мы хотим изменять
  2. Флаг, контролирующий появление и поведение пункта меню. может принимать следующие значения:
    • MF_BITMAP Для использование изображение в качестве пункта меню. Тогда послежний параметр должен содержать дескриптор изображения.
    • MF_CHECKED Устанавливает контрольную метку возле пункта меню.
    • MF_DISABLED Показывает, что пункт меню будет неактивным. Его нельзя будет выделить и он приобретёт серое состояние.
    • MF_ENABLED Делает пункт меню активным.
    • MF_GRAYED Делает пункт меню недоступным.
    • MF_MENUBARBREAK Функция похожа на MF_MENUBREAK. Позволяет последующие пункты меню размещать в новой колонке, отделяемой от текущей вертикальной чертой.
    • MF_MENUBREAK Позволяет последующие пункты меню размещать в новой колонке, но не отделяет их вертикальной линией.
    • MF_OWNERDRAW Указывает, что пункт меню должен будет прорисовываться самостоятельно. До отображения меню в первый раз окно посылает сообщение WM_MEASUREITEM для того, чтобы узнать какой должна быть ширина меню. Так же посылает сообщение WM_DRAWITEM в тот момент, когда пункт меню должен обновляться.
    • MF_POPUP Характеризует меню, которое будет открывать подменю или контекстное меню. Тогда последний параметр должен содержать дескриптор этого пункта меню.
    • MF_SEPARATOR Отделительная горизонтальная линия. Линия не может становиться неактивной или активной. В данном случае последний параметр будет игнорироваться.
    • MF_STRING Показывает, что пункт меню будет содержать строку, которая должна быть указана в последнем параметре.
    • MF_UNCHECKED Снимает контрольную метку около пункта меню.
  3. Идентификатор нового пункта меню. Если значение флага MF_POPUP, тогда этот параметр должен содержать дескриптор контекстного меню.
  4. Содержание нового пункта меню. Так же зависит от значения флага. Если он содержит такие константа как MF_BITMAP, MF_OWNERDRAW или MF_STRING, тогда здесь нужно указывать: дескриптор изображения, собственную прорисовку пункта меню или строку.

Если функция выполняется успешно - она возвращает значение отличное от нуля, в противном случае - 0.

Давайте разберём пример:

Создайте новой приложение и по созданию окна [Событие OnCreate()] напишите такой код:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
   AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'Delphi World - это КРУТО!');
 end;
 

Здесь мы добавляем два новых пункта в системное меню приложения. Сначала разделительную горизонтальную линию, о чём свидетельствует значение флага MF_SEPARATOR, а затем, пункт меню, который будет содержать строку. Это видно по значению флага MF_STRING. Сама строка, как вы видите указывается в последнем пункте меню. Но это ещё не всё, так же нужно предусмотреть вариант, когда пользователь нажмёт на наш новый пункт меню. Нужно генерировать новое сообщение Windows и обрабатывать его. Для этого в частных объявлениях, т.е. в директиве private напишем такой код:


 private
   { Private declarations }
   procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
 

В разделе implementation напишем следующее:


 const
   SC_MyMenuItem = WM_USER + 1;
 
 procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
 begin
   if Msg.CmdType = SC_MyMenuItem then
     ShowMessage('Был нажат наш пункт меню!!!')
   else
     inherited;
 end;
 

Ну вот, вообщем-то и всё! Теперь компилируйте и тестируйте приложение.




Как добавить нужный язык в систему

Автор: Mekan Gara

Для этого необходимо изменить некоторые ключи в реестре. Например, необходимо добавить Туркменский язык. Конечно, Вам необходимо иметь файл KBD с раскладкой клавиатуры (Turkmen.kbd).


 procedure TTMKBD.OkClick(Sender: TObject);
 var
   reg: TRegistry;
   srs, dst: string;
 begin
   Reg := TRegistry.Create;
   with Reg do
   try
     RootKey := HKEY_LOCAL_MACHINE;
     OpenKey('\System\CurrentControlSet\Control\keyboard layouts\00000405', True);
     WriteString('layout file', 'Turkmen.kbd');
     WriteString('layout text', 'Turkmen');
     OpenKey('\System\CurrentControlSet\Control\Nls\Locale', True);
     WriteString('00000405', 'Turkmen');
     CloseKey;
   finally
     Free;
   end;
   srs := 'Turkmen.kbd';
   dst := 'c:\windows\system\Turkmen.kbd';
   Filecopy(srs, dst);
   showmessage('Well Done it all');
   close;
 end;
 




Добавление строк в Memo

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


 Memo1.Perform( WM_SETREDRAW, 0, 0 );
 // ... здесь можно добавлять строки
 Memo1.Perform( WM_SETREDRAW, 1, 0 );
 Memo1.Refresh;
 




Добавление иконки в меню


 var
 
 Bmp1 : TPicture;
 
 ...
 
 Bmp1 := TPicture.Create;
 Bmp1.LoadFromFile('c:\where\b1.BMP');
 SetMenuItemBitmaps(MenuItemTest.Handle,
   0,
   MF_BYPOSITION,
   Bmp1.Bitmap.Handle,
   Bmp1.Bitmap.Handle);
 ...
 




Подключение сетевого диска в Delphi

Автор: Josef Garvi

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

Данный код показывает как создавать кнопку 'Сеть', вызывающую диалог подключения сетевого диска и указывающего логический диск для подключаемого сетевого ресурса. Этот код создавался на Delphi 2, но и в Delphi 1 данная процедура не сильно отличается от исходной.

Создайте кнопку с именем NetBtn и drive combo box (выпадающий список с дисками) с именем DriveBox. Затем напишите следующий обработчик события OnClick кнопки:


 procedure TStartForm.NetBtnClick(Sender: TObject);
 var
   OldDrives: TStringList;
   i: Integer;
 begin
   OldDrives := TStringList.Create;
   // Запоминаем список дисков
   OldDrives.Assign(Drivebox.Items);
   // Показываем диалог подключения
   if WNetConnectionDialog(Handle, RESOURCETYPE_DISK) = NO_ERROR then
   begin
     // Обновляем список дисков
     DriveBox.TextCase := tcLowerCase;
     for i := 0 to DriveBox.Items.Count - 1 do
     begin
       // Ищем свободный логический диск
       if Olddrives.IndexOf(Drivebox.Items[i]) = -1 then
       begin
         // Показываем первый найденный логический диск
         DriveBox.ItemIndex := i;
         // Каскадируем обновление на список подключенных каталогов и др.
         DriveBox.Drive := DriveBox.Text[1];
       end;
     end;
     DriveBox.SetFocus;
   end;
   OldDrives.Free;
 end;
 

Ну и не забудьте также добавить WinProcs и WinTypes в список используемых модулей.

Самое большое неудобство заключается в том, что у DriveComboBox отсутствует функция обновления. Меняя значение свойства TextCase, мы заставляем компонент обновляться.




Подключение сетевого диска

Звонок по телефону: "Включи асю!"
Включаю асю, сообщение: "Посмотри почту!"
Смотрю почту, письмо: "Позвони мне!"
Звоню, слышу: "Включи асю!"


 //Пример открытия стандартного диалога 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WNetConnectionDialog(Handle,RESOURCETYPE_DISK)
 end;
 
 //Так же можно подключить и принтер 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   WNetConnectionDialog(Handle,RESOURCETYPE_PRINT)
 end;
 
 //либо можно использовать следующий код 
 procedure TForm1.Button2Click(Sender: TObject);
 var
 NetResource: TNetResource;
 begin
   { заполняем структуру TNetResource }
   NetResource.dwType       := RESOURCETYPE_DISK;
   NetResource.lpLocalName  := 'S:';
   NetResource.lpRemoteName := '\\myserver\public';
   NetResource.lpProvider   := '';
 
   { подключаем сетевой ресурс, используя структуру TNetResource }
   If ( WNetAddConnection2(NetResource,
                          '', {Password (if needed) or empty}
                          '', {User name (if needed) or empty}
                          CONNECT_UPDATE_PROFILE)<>NO_ERROR) Then
      Raise Excepcion.Create('unable to map drive')
   //так же существуют другие константы для определения возникшей ошибки 
   //ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, и т.д. 
 end;
 
 //так же можно и отключить сетевой ресурс... 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   if WNetCancelConnection2( 'S:',0,TRUE) <> NO_ERROR then
     Raise Exception.create('Error disconnecting map drive');
   //соответственно можно использовать другие константы для определения ошибки
   //ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, и т.д. 
 end;
 




Добавлять новые пункты меню

Обычно, когда Вы создаёте меню в приложении, то код выглядит примерно так:


 PopupMenu1 := TPopupMenu.Create(Self);
 
 Item := TMenuItem.Create(PopupMenu1);
 Item.Caption := 'First Menu';
 Item.OnClick := MenuItem1Click;
 PopupMenu1.Items.Add(Item);
 
 Item := TMenuItem.Create(PopupMenu1);
 Item.Caption := 'Second Menu';
 Item.OnClick := MenuItem2Click;
 PopupMenu1.Items.Add(Item);
 
 Item := TMenuItem.Create(PopupMenu1);
 Item.Caption := 'Third Menu';
 Item.OnClick := MenuItem3Click;
 PopupMenu1.Items.Add(Item);
 
 Item := TMenuItem.Create(PopupMenu1);
 Item.Caption := '-';
 PopupMenu1.Items.Add(Item);
 
 Item := TMenuItem.Create(PopupMenu1);
 Item.Caption := 'Fourth Menu';
 Item.OnClick := MenuItem4Click;
 PopupMenu1.Items.Add(Item);
 

Однако есть более быстрый способ! Воспользуйтесь функциями NewItem и NewLine:


 PopupMenu1 := TPopupMenu.Create(Self);
 with PopUpMenu1.Items do
 begin
   Add(NewItem('First Menu', 0, False, True, MenuItem1Click, 0, 'MenuItem1'));
   Add(NewItem('Second Menu', 0, False, True, MenuItem2Click, 0, 'MenuItem2'));
   Add(NewItem('Third Menu', 0, False, True, MenuItem3Click, 0, 'MenuItem3'));
   Add(NewLine); // Добавляем разделитель
   Add(NewItem('Fourth Menu', 0, False, True, MenuItem4Click, 0, 'MenuItem4'));
 end;
 




Добавление ODBC-драйверов в Delphi

Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличие следующих компонентов:

         Microsoft ODBC Manger
         Windows 95 или NT
         Delphi версии Developer или Client/Server
         Поставляемый производителем драйвер ODBC (уже установленный в вашей системе)
При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.

Метод A:

  1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

  2. Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.)

  3. Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK.

  4. Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле "Path" (путь), или поле "Server" (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.)
Метод B:
  1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

  2. Щелкните на закладке database, затем правой кнопкой мыши на левой панели.

  3. Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK.

  4. Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply.

  5. Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply.
Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные.

Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив ‘virtual’ отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2).




Добавляем пароль к таблице Paradox

- Алло, техотдел? Я пароль набираю - а меня не пускают.
- Значит, правильно набирать надо.
- Я правильно набираю! Пять звездочек!


 uses   Bde, SysUtils, dbtables, windows;
 
 
 function StrToOem(const AnsiStr: string): string;
 begin
   SetLength(Result, Length(AnsiStr));
   if Length(Result)  0 then
     CharToOem(PChar(AnsiStr), PChar(Result));
 end;
 
 function TablePasswort(var Table: TTable; password: string): Boolean;
 var
   pTblDesc: pCRTblDesc;
   hDb: hDBIDb;
 begin
   Result := False;
   with Table do
   begin
     if Active and (not Exclusive) then Close;
     if (not Exclusive) then Exclusive := True;
     if (not Active) then Open;
     hDB := DBHandle;
     Close;
   end;
   GetMem(pTblDesc, SizeOf(CRTblDesc));
   FillChar(pTblDesc^, SizeOf(CRTblDesc), 0);
   with pTblDesc^ do
   begin
     StrPCopy(szTblName, StrToOem(Table.TableName));
     szTblType := szParadox;
     StrPCopy(szPassword, StrToOem(Password));
     bPack      := True;
     bProtected := True;
   end;
   if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, False) DBIERR_NONE then Exit;
   if pTblDesc  nil then FreeMem(pTblDesc, SizeOf(CRTblDesc));
   Result := True;
 end;
 




Как программно добавить принтер

Чтобы программно добавить принтер, необходимо воспользоваться API функцией AddPrinter, которая имеет три параметра:

  • Имя принтера
  • Уровень печати
  • Описание принтера

Следующий пример является надстройкой для этой функции. Для этого необходимо знать Имя принтера, которое будет отображаться в Проводнике, имя порта, к которому подключён принтер (т.е. LPT1:), имя драйвера (прийдётся посмотреть вручную) и имя процессора печати (который обычно "winprint").


 unit unit_AddPrinter;
 
 interface
 
 function AddAPrinter(PrinterName, PortName,
 DriverName, PrintProcessor: string): boolean;
 
 implementation
 
 uses
   SysUtils,
   WinSpool,
   Windows;
 
 function AddAPrinter(PrinterName, PortName,
 DriverName, PrintProcessor: string):     boolean;
 var
   pName: PChar;
   Level: DWORD;
   pPrinter: PPrinterInfo2;
 begin
 
   pName := nil;
   Level := 2;
   New(pPrinter);
   pPrinter^.pServerName := nil;
   pPrinter^.pShareName := nil;
   pPrinter^.pComment := nil;
   pPrinter^.pLocation := nil;
   pPrinter^.pDevMode := nil;
   pPrinter^.pSepFile := nil;
   pPrinter^.pDatatype := nil;
   pPrinter^.pParameters := nil;
   pPrinter^.pSecurityDescriptor := nil;
   pPrinter^.Attributes := 0;
   pPrinter^.Priority := 0;
   pPrinter^.DefaultPriority := 0;
   pPrinter^.StartTime := 0;
   pPrinter^.UntilTime := 0;
   pPrinter^.Status := 0;
   pPrinter^.cJobs := 0;
   pPrinter^.AveragePPM :=0;
 
   pPrinter^.pPrinterName := PCHAR(PrinterName);
   pPrinter^.pPortName := PCHAR(PortName);
   pPrinter^.pDriverName := PCHAR(DriverName);
   pPrinter^.pPrintProcessor := PCHAR(PrintProcessor);
 
   if AddPrinter(pName, Level, pPrinter) <> 0 then
     Result := true
   else
   begin
     // ShowMessage(inttostr(GetlastError));
     Result := false;
   end;
 end;
 
 end.
 




Как открыть диалог добавления принтера


 // добавьте ShellAPI в USES
 
 begin
   ShellExecute(handle, nil, 'rundll32.exe',
     'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter',
     '', SW_SHOWNORMAL);
 end;
 




Выставляем горячие клавиши для Delphi приложения

Нажмите любую клавишу... Нет, нет, только не эту!..

Как сделать так, чтобы при минимизации приложения в Tray его можно было вызвать определённой комбинацией клавиш, например Alt-Shift-F9 ?


 //В обработчике события OnCreate
 //основной формы создаём горячую клавишу:
 
 if not RegisterHotkey(Handle, 1, MOD_ALT or MOD_SHIFT, VK_F9) then
   ShowMessage('Unable to assign Alt-Shift-F9 as hotkey.');
 
 //В событии OnClose удаляем горячую клавишу:
 UnRegisterHotkey( Handle, 1 );
 
 //Добавляем обработчик в форму для сообщения
 //WM_HOTKEY:
 
 private // в секции объявлений формы
   procedure WMHotkey( var msg: TWMHotkey ); message WM_HOTKEY;
 
 procedure TForm1.WMHotkey( var msg: TWMHotkey );
 begin
   if msg.hotkey = 1 then
   begin
     if IsIconic( Application.Handle ) then
       Application.Restore;
     BringToFront;
   end;
 end;
 




Добавление строки к файлу

Из FAQ`а по Quake (CTF).
Q: Я только что законнектился на CTF-сервер. Как узнать - голубой я или красный?
А: Если Вашу команду выеб%т - голубой, а если замочат - красный.


 procedure AddStrToFile(S:string;const FileName:string;doNextLine:boolean);
 {Добавление строки к файлу doNextLine - перевод строки}
 const
   CR=#13#10;
 var
   f:TFileStream;
 begin
   if FileExists(FileName)
   then f:=TFileStream.Create(FileName,fmOpenWrite+fmShareDenyNone)
   else f:=TFileStream.Create(FileName,fmCreate);
   f.Position:=f.Size;
   if doNextLine and (f.Size> 0)
   then f.Write(CR,2);
   f.Write(pointer(s)^,length(s));
   f.Destroy;
 end;
 




Сложение времени

Oбpaщeниe фиpмы Microsoft к пoльзoвaтeлям: B cвязи c нeзнaчитeльнoй тexничecкой проблeмoй, рeлиз oпepaциoнной cиcтeмы "Windows 2000" oтклaдывaeтcя на пepвый квapтaл 1901 годa.

Если Вы создаёте приложение, в котором пользователь вводит значения времени, то стандартные вычисления не подойдут. Проблема в том, что нужно сделать так, чтобы выражение 1.20 + 1.70 было равно НЕ 2.90 а 3.10.

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


 function sumhhmm(a, b: double): double;
 var
   h1: double;
 begin
   h1 := (INT(A) + INT(B)) * 60 + (frac(a) + frac(b)) * 100;
   result := int(h1 / 60) + (h1 - int(h1 / 60) * 60) / 100;
 end;
 
 function hhmm2hhdd(const hhmm: double): double;
 begin
   result := int(hhmm) + (frac(hhmm) / 0.6);
 end;
 
 function hhdd2hhmm(const hhdd: double): double;
 begin
   result := int(hhdd) + (frac(hhdd) * 0.6);
 end;
 
 // ************************************** //
 //             Использование:             //
 // ************************************** //
 // sumtime(1.20,1.50) => 3.10             //
 // sumtime(1.20,- 0.50) => 0.30           //
 // hhmm2hhdd(1.30) => 1.5 (1h.30m = 1.5h) //
 // hhdd2hhmm(1.50) => 1.30 (1.5h = 1h30m) //
 // ************************************** //
 




Как добавить True Type шрифт в систему

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.


 uses Registry;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   hReg: TRegistry;
   hBool : bool;
 begin
   CopyFile('C:\DOWNLOAD\FP000100.TTF',
            'C:\WINDOWS\FONTS\FP000100.TTF', hBool);
   hReg := TRegistry.Create;
   hReg.RootKey := HKEY_LOCAL_MACHINE;
   hReg.LazyWrite := false;
   hReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts',
                false);
   hReg.WriteString('TESTMICR (TrueType)','FP000100.TTF');
   hReg.CloseKey;
   hReg.free;
   //Добавляем ресурс шрифта
   AddFontResource('c:\windows\fonts\FP000100.TTF');
   SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
   //Убираем блокировку ресурса
   RemoveFontResource('c:\windows\fonts\FP000100.TTF');
   SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
 end;
 




ADO.OLEDB.JET - Access Violation при передаче неполного параметра

Автор: Дмитрий Померанцев

Проблема обнаружена под операционной системой Windows 2000 SP3, в среде Delphi6, Delphi7 (скорее всего не зависит от версии Delphi) с использованием Microsoft Jet DB Engine версия 4, SP3.

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

Пример кода:

Допустим, есть база данных в MS Access 2000, имеющая таблицу main и в ней целочисленное (INT) поле id в качестве главного ключа. Так же есть компонент ADOQuery1: TADOQuery, для доступа к базе данных. Максимальное значение поля id может быть получено следующим кодом:


 ADOQuery1.Active := false;
 ADOQuery1.SQL.Clear;
 ADOQuery1.SQL.Add('SELECT max(id)'); // -- Сбой здесь !!!
 ADOQuery1.SQL.Add('AS idmax');
 ADOQuery1.SQL.Add('FROM main');
 ADOQuery1.Active := true;
 

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

Исследование исходных текстов компонента TADOQuery показало следущее: свойство SQL, типа TStrings связано с полем FSQL: TStrings, создаваемого как экземляр класса TStringList, при этом объекту FSQL назначается обработчик события OnChange — метод QueryChanged (protected, статический), что исключает его возможную перегрузку.

Этот метод устанавливает свойство Active в False и присваивает содержимое FSQL.Text полю CommandText объекта ADO.

За отсутствием исходных текстов библиотеки Jet, дальнейшее исследование пришлось прекратить, но можно сделать несколько выводов:

Корни проблемы в невполне корректном поведении как кода от Borland, так и от Microsoft. Компонент TADOQuery передает в ADO неоконченный SQL-запрос, а Jet начинает анализировать этот запрос до того, как он полностью поступит. Возможно, Microsoft пытался реализовать упреждающее выполнение запросов, чтобы снизить время обработки запроса после получения команды на выполнение.

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

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

Данный код не прерывает выполнения при возникновении exception, т.е. теоретически даже try..except не нужен. Похоже, это происходит из-за того, что jet является COM-объектом, а их методы вызываются как safecall. Дальнейшие тесты подтвердили это предположение — при снятии галочки Stop on Delphi Exceptions и в варианте exe-файла ошибка не проявлялась. Таким образом, ситуация несколько меняется — исключение возникает только в среде разработки, что, правда, является слабым утешением, т.к. многие програмисты работают с настройками по-умолчанию, и в случае его возникновения могут долго ломать голову, ища свою ошибку там где ее нет.

ТИПОВЫЕ РЕШЕНИЯ

1. Передавать запрос целиком — одной строкой. Пример:


 ADOQuery1.Active := false;
 ADOQuery1.SQL.Text := 'SELECT max(id) AS idmax FROM main;';
 ADOQuery1.Active := true;
 

2. Отключить галочку Tools->Debugger Options->Language Exceptions->Stop on Delphi Exceptions

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

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

КОММЕНТАРИЙ:

Компонент TADOQuery от Delphi 5 содержит аналогичный код (метод QueryChanged), приводящий к ошибке.

Еще один вариант решения - использовать стандартные возможности TStrings по управлению обновлением:


 ADOQuery1.SQL.BeginUpdate;
 try
   ADOQuery1.SQL.Clear;
   ADOQuery1.SQL.Add('SELECT max(id)');
   ADOQuery1.SQL.Add('AS idmax');
   ADOQuery1.SQL.Add('FROM main');
 finally
   ADOQuery1.SQL.EndUpdate;
 end;
 

В этом случае событие OnChange произойдет только при выполнении EndUpdate.




Как работать из Delphi напрямую с ADO

Автор: Nomadic

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:


 var
   OptionalParam: OleVariant;
   VarData: PVarData;
 begin
   OptionalParam := DISP_E_PARAMNOTFOUND;
   VarData := @OptionalParam;
   VarData^.VType := varError;
 

после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.

Далее, самый приятный способ получения Result sets:

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


 var
   MyConn: _Connection;
   MyComm: _Command;
   MyRecSet: _Recordset;
   prm1: _Parameter;
 begin
   MyConn := CoConnection.Create;
   MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;'; MyConn.Open( '', '', '', -1 );
   MyCommand := CoCommand.Create;
   MyCommand.ActiveConnection := MyConn;
   MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'
   Prm1 := MyCommand.CreateParameter( 'Id', adInteger.adParamInput, -1, <value> );
   MyCommand.AppendParameter( Prm1 );
   MyRecSet := CoRecordSet.Create;
   MyRecSet.Open( MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText );
 

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

Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь.

Из вкусностей ADO - их легко можно использовать во всяких многопоточных приложениях, где BDE порой сбоит, если, конечно, ODBC драйвер грамотно сделан...

Ну и еще можно использовать для доступа к данным всяких там "нестандартных" баз типа MS Index Server или MS Active Directory Services.

В Delphi (как минимум в 4 версии) существует "константа" EmptyParam, которую можно подставлять в качестве пустого параметра.




Передача параметров ADO запросу


 CONECT_STR='Provider=Microsoft.Jet.OLEDB.4.0;Password=" " ;User ID=Admin;'+{Data Source=D:\ExBd\ТЕРМО\Bd0.mdb;}
    'Data Source=%s; Mode=Read|Write|Share Deny None;Extended Properties=" " ;'+
    'Locale Identifier=1049;Persist Security Info=True;Jet OLEDB:System database=" " ;'+
    'Jet OLEDB:Registry Path=" " ;Jet OLEDB:Database Password=" " ;Jet OLEDB:Engine Type=4;'+
    'Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;'+
    'Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" " ;'+
    'Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;'+
    'Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False';
 
 function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer;
  var qu: TADOQuery;
    S: String;
 begin
  qu:=TADOQuery.Create(nil);
  try
    S:=FormatDateTime('dd.mm.yy',LastDate);
    qu.ConnectionString:=WideString(Format(CONECT_STR,[db_file]));
    qu.SQL.Text:='select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan';
    qu.Parameters[0].Value:=LastDate;
    qu.Parameters[1].Value:=IsPlan;
    qu.Open;
    Result:=qu.Fields[0].AsInteger;
  finally
    qu.Free;
  end;
 end;
 




Быстрый доступ к ADO


 unit ADO;
 {This unit provides a quick access into ADO
       It handles all it's own exceptions
       It assumes it is working with SQL Server, on a PLC Database
          If an exception is thrown with a [PLCErr] suffix:
                the suffix is removed, and ErrMsg is set to the remaining string
              otherwise
                the whole exception is reported in ErrMsg
              Either way, the function call fails.
 
       Globals: adocn     - connection which all other ADO objects use
                adors     - Recordset
                adocmd    - Command Object
                adocmdprm - Command Object set aside for Parametric querying
                ConnectionString
                          - Connection String used for connecting
 
                ErrMsg    - Last Error Message
                ADOActive - Indicator as to whether ADO has been started yet
 
 Functions:
 General ADO
            ADOStart:Boolean;
            ADOReset:Boolean;
            ADOStop:Boolean;
 
 Recordsets
            RSOpen(SQL:string;adRSType,adLockType,adCmdType:integer;UseServer:Boolean):Boolean;
            RSClose:Boolean;
 
 Normal Command Procedures
            CMDExec(SQL:string;adCmdType:integer):Boolean;
 
 Parametric Procedures
            PRMClear:Boolean;
            PRMSetSP(StoredProcedure:string;WithClear:Boolean):Boolean;
            PRMAdd(ParamName:string;ParamType,ParamIO,ParamSize:integer;Val:variant):Boolean;
            PRMSetParamVal(ParamName:string;val:variant):Boolean;
            PRMGetParamVal(ParamName:string;var val:variant):Boolean;
 
 Field Operations
            function SQLStr(str:string;SQLStrType:TSQLStrType);
            function SentenceCase(str:string):string;
 
            --to convert from 'FIELD_NAME' -> 'Field Name' call
            SQLStr(SentenceCase(txt),ssFromSQL);
 }
 
 interface
 
 uses OLEAuto, sysutils;
 
 const
   {Param Data Types}
   adInteger = 3;
   adSingle = 4;
   adDate = 7;
   adBoolean = 11;
   adTinyInt = 16;
   adUnsignedTinyInt = 17;
   adDateTime = 135;
   advarChar = 200;
 
   {Param Directions}
   adParamInput = 1;
   adParamOutput = 2;
   adParamReturnValue = 4;
 
   {Command Types}
   adCmdText = 1;
   adCmdTable = 2;
   adCmdStoredProc = 4;
   adCmdTableDirect = 512;
   adCmdFile = 256;
 
   {Cursor/RS Types}
   adOpenForwardOnly = 0;
   adOpenKeyset = 1;
   adOpenDynamic = 2;
   adOpenStatic = 3;
 
   {Lock Types}
   adLockReadOnly = 1;
   adLockOptimistic = 3;
 
   {Cursor Locations}
   adUseServer = 2;
   adUseClient = 3;
 
 function ADOReset: Boolean;
 function ADOStop: Boolean;
 
 function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer;
   UseServer: Boolean): Boolean;
 function RSClose: Boolean;
 
 function CMDExec(SQL: string; adCmdType: integer): Boolean;
 
 function PRMClear: Boolean;
 function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean;
 function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
   variant): Boolean;
 function PRMSetParamVal(ParamName: string; val: variant): Boolean;
 function PRMGetParamVal(ParamName: string; var val: variant): Boolean;
 
 type
   TSQLStrType = (ssToSQL, ssFromSQL);
 function SQLStr(str: string; SQLStrType: TSQLStrType): string;
 function SentenceCase(str: string): string;
 
 var
   adocn, adors, adocmd, adocmdPrm: variant;
   ConnectionString, ErrMsg: string;
   ADOActive: boolean = false;
 
 implementation
 
 var
   UsingConnection: Boolean;
 
 function ADOStart: Boolean;
 begin
   //Get the Object References
   try
     adocn := CreateOLEObject('ADODB.Connection');
     adors := CreateOLEObject('ADODB.Recordset');
     adocmd := CreateOLEObject('ADODB.Command');
     adocmdprm := CreateOLEObject('ADODB.Command');
     result := true;
   except
     on E: Exception do
     begin
       ErrMsg := e.message;
       Result := false;
     end;
   end;
   ADOActive := result;
 end;
 
 function ADOReset: Boolean;
 begin
   Result := false;
   //Ensure a clean slate...
   if not (ADOStop) then
     exit;
 
   //Restart all the ADO References
   if not (ADOStart) then
     exit;
 
   //Wire up the Connections
   //If the ADOconnetion fails, all objects will use the connection string
   //                               directly - poorer performance, but it works!!
   try
     adocn.ConnectionString := ConnectionString;
     adocn.open;
     adors.activeconnection := adocn;
     adocmd.activeconnection := adocn;
     adocmdprm.activeconnection := adocn;
     UsingConnection := true;
   except
     try
       adocn := unassigned;
       UsingConnection := false;
       adocmd.activeconnection := ConnectionString;
       adocmdprm.activeconnection := ConnectionString;
     except
       on e: exception do
       begin
         ErrMsg := e.message;
         exit;
       end;
     end;
   end;
   Result := true;
 end;
 
 function ADOStop: Boolean;
 begin
   try
     if not (varisempty(adocn)) then
     begin
       adocn.close;
       adocn := unassigned;
     end;
     adors := unassigned;
     adocmd := unassigned;
     adocmdprm := unassigned;
     result := true;
   except
     on E: Exception do
     begin
       ErrMsg := e.message;
       Result := false;
     end;
   end;
   ADOActive := false;
 end;
 
 function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer;
   UseServer: Boolean): Boolean;
 begin
   result := false;
   //Have two attempts at getting the required Recordset
   if UsingConnection then
   begin
     try
       if UseServer then
         adors.CursorLocation := adUseServer
       else
         adors.CursorLocation := adUseClient;
       adors.open(SQL, , adRSType, adLockType, adCmdType);
     except
       if not (ADOReset) then
         exit;
       try
         if UseServer then
           adors.CursorLocation := adUseServer
         else
           adors.CursorLocation := adUseClient;
         adors.open(SQL, , adRSType, adLockType, adCmdType);
       except
         on E: Exception do
         begin
           ErrMsg := e.message;
           exit;
         end;
       end;
     end;
   end
   else
   begin
     //Use the Connetcion String to establish a link
     try
       adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType);
     except
       if not (ADOReset) then
         exit;
       try
         adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType);
       except
         on E: Exception do
         begin
           ErrMsg := e.message;
           exit;
         end;
       end;
     end;
   end;
   Result := true;
 end;
 
 function RSClose: Boolean;
 begin
   try
     adors.Close;
     result := true;
   except
     on E: Exception do
     begin
       ErrMsg := e.message;
       result := false;
     end;
   end;
 end;
 
 function CMDExec(SQL: string; adCmdType: integer): Boolean;
 begin
   result := false;
   //Have two attempts at the execution..
   try
     adocmd.commandtext := SQL;
     adocmd.commandtype := adCmdType;
     adocmd.execute;
   except
     try
       if not (ADOReset) then
         exit;
       adocmd.commandtext := SQL;
       adocmd.commandtype := adCmdType;
       adocmd.execute;
     except
       on e: exception do
       begin
         ErrMsg := e.message;
         exit;
       end;
     end;
   end;
   result := true;
 end;
 
 function PRMClear: Boolean;
 var
   i: integer;
 begin
   try
     for i := 0 to (adocmdprm.parameters.count) - 1 do
     begin
       adocmdprm.parameters.delete(0);
     end;
     result := true;
   except
     on e: exception do
     begin
       ErrMsg := e.message;
       result := false;
     end;
   end;
 end;
 
 function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean;
 begin
   result := false;
   //Have two attempts at setting the Stored Procedure...
   try
     adocmdprm.commandtype := adcmdStoredProc;
     adocmdprm.commandtext := StoredProcedure;
     if WithClear then
       if not (PRMClear) then
         exit;
     result := true;
   except
     try
       if not (ADOReset) then
         exit;
       adocmdprm.commandtype := adcmdStoredProc;
       adocmdprm.commandtext := StoredProcedure;
       //NB: No need to clear the parameters, as an ADOReset will have done this..
       result := true;
     except
       on e: exception do
       begin
         ErrMsg := e.message;
       end;
     end;
   end;
 end;
 
 function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
   variant): Boolean;
 var
   DerivedParamSize: integer;
 begin
   //Only try once to add the parameter (a call to ADOReset would reset EVERYTHING!!)
   try
     case ParamType of
       adInteger: DerivedParamSize := 4;
       adSingle: DerivedParamSize := 4;
       adDate: DerivedParamSize := 8;
       adBoolean: DerivedParamSize := 1;
       adTinyInt: DerivedParamSize := 1;
       adUnsignedTinyInt: DerivedParamSize := 1;
       adDateTime: DerivedParamSize := 8;
       advarChar: DerivedParamSize := ParamSize;
     end;
     adocmdprm.parameters.append(adoCmdPrm.createparameter(ParamName, ParamType,
       ParamIO, DerivedParamSize, Val));
   except
     on e: exception do
     begin
       ErrMsg := e.message;
     end;
   end;
 end;
 
 function PRMSetParamVal(ParamName: string; val: variant): Boolean;
 begin
   //Only try once to set the parameter (a call to ADOReset would reset EVERYTHING!!)
   try
     adocmdprm.Parameters[ParamName].Value := val;
     result := true;
   except
     on e: exception do
     begin
       ErrMsg := e.message;
       result := false;
     end;
   end;
 end;
 
 function PRMGetParamVal(ParamName: string; var val: variant): Boolean;
 begin
   //Only try once to read the parameter (a call to ADOReset would reset EVERYTHING!!)
   try
     val := adocmdprm.Parameters[ParamName].Value;
     result := true;
   except
     on e: exception do
     begin
       ErrMsg := e.message;
       result := false;
     end;
   end;
 end;
 
 function SQLStr(str: string; SQLStrType: TSQLStrType): string;
 var
   FindChar, ReplaceChar: char;
 begin
   {Convert ' '->'_' for ssToSQL (remove spaces)
   Convert '_'->' ' for ssFromSQL (remove underscores)}
   case SQLStrType of
     ssToSQL:
       begin
         FindChar := ' ';
         ReplaceChar := '_';
       end;
     ssFromSQL:
       begin
         FindChar := '_';
         ReplaceChar := ' ';
       end;
   end;
 
   result := str;
   while Pos(FindChar, result) > 0 do
     Result[Pos(FindChar, result)] := ReplaceChar;
 end;
 
 function SentenceCase(str: string): string;
 var
   tmp: char;
   i {,len}: integer;
   NewWord: boolean;
 begin
   NewWord := true;
   result := str;
   for i := 1 to Length(str) do
   begin
     if (result[i] = ' ') or (result[i] = '_') then
       NewWord := true
     else
     begin
       tmp := result[i];
       if NewWord then
       begin
         NewWord := false;
         result[i] := chr(ord(result[i]) or 64); //Set bit 6 - makes uppercase
       end
       else
         result[i] := chr(ord(result[i]) and 191); //reset bit 6 - makes lowercase
     end;
   end;
   {This was the original way of doing it, but I wanted to look for spaces or '_'s,
         and it all seemed problematic - if I find a better way another day, I'll alter the above...
        if str<>'' then
           begin
                tmp:=LowerCase(str);
                len:=length(tmp);
                tmp:=Uppercase(copy(tmp,1,1))+copy(tmp,2,len);
                i:=pos('_',tmp);
                while i<>0 do
                      begin
                           tmp:=copy(tmp,1,i-1)+' '+Uppercase(copy(tmp,i+1,1))+copy(tmp,i+2,len-i);
                           i:=pos('_',tmp);
                      end;
           end;
        result:=tmp;}
 end;
 
 end.
 




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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   SL: TStrings;
   index: Integer;
 begin
   SL := TStringList.Create;
   try
     ADOConnection1.GetTableNames(SL, False);
     for index := 0 to (SL.Count - 1) do begin
       Table1.Insert;
       Table1.FieldByName('Name').AsString := SL[index];
       ADOTable1.TableName := SL[index];
       ADOTable1.Open;
       Table1.FieldByName('Records').AsInteger :=
         ADOTable1.RecordCount;
       Table1.Post;
     end;
   finally
     SL.Free;
     ADOTable1.Close;
   end;
 end;
 




Узнаём установленную версию ADO


 function GetADOVersion: Double;
 var
   ADO: OLEVariant;
 begin
   try
     ADO    := CreateOLEObject('adodb.connection');
     Result := StrToFloat(ADO.Version);
     ADO    := Null;
   except
     Result := 0.0;
   end;
 end;
 
 // To use this function try something like: 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   ADOVersionNeeded = 2.5;
 begin
   if GetADOVersion then
     ShowMessage('Need to install MDAC version 2.7')
   else
     ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
 end;
 




Соглашения о вызовах DLL

Автор: David Berg

Кто-нибудь может мне сказать, почему мои перекомпилированные DLL-ки не грузятся? Передаются только данные, имеющие тип pchars и integer.

Одно отличие между 16- и 32-битной версией Delphi - соглашение о вызове. 16-битная версия использует по умолчанию вызов PASCAL (перекрываемый CDECL). 32-битная использует по умолчанию FASTCALL, но может перекрываться CDECL, PASCAL или STDCALL.

Я не уверен в том, что сейчас использует VB (в 16-битном Windows API был Pascal, в 32-битном - STDCALL). Я добавляю ко всем экспортируемым функциям ключевое слово "PASCAL". Если это не решает проблему, попробуйте использовать "STDCALL".




Соглашения о вызовах DLL 2

Автор: Dave Berg

CDECL - Порядок вызова справа налево, за выгрузку стека отвечает вызывающая подпрограмма.

PASCAL - Порядок вызова слева направо, за выгрузку стека отвечает вызываемая подпрограмма.

STDCALL - Порядок вызова справа налево, за выгрузку стека отвечает вызываемая подпрограмма.

FASTCALL - Первые три параметра по возможности передаются через регистры процессора. Если аргументов три или меньше и при отсутствии локальных переменных вызываемая подпрограмма не создает кадров стека.

STDCALL был добавлен Microsoft для Win32. В нем скомбинированы лучшие черты Pascal (очистка стека вызываемой подпрограммой) и CDECL (аргументы выталкиваются слева направа - первый аргумент находится на вершине стека - делает простым использование счетчика переменного количества аргументов). Перед STDCALL Windows всегда использовался PASCAL, а для вызовов всех переменных аргументов использовался CDECL. Теперь для всего этого всегда используется STDCALL.

FASTCALL реально доступен в 16-битных BC, но его используют не так много программистов. Тем не менее, для вызова небольших быстрых подпрограмм, не организующих выталкивание и помещение аргументов и не строящих кадры стека, кадры могут быть расширены. Для примера, подпрограмма MIN/MAX выполняющая около 15 инструкций, выполняет 5, плюс дополнительные инструкции, по большей части для работы с регистрами, где старые инструкции работали с памятью. Это не дало бы такого эффекта в C поскольку: (a) такие простые программы реализовываются на уровне макросов, и/или (b) компилятор имел тенденцию работать во всяком случае с inline.




Псевдонимы

Попробуйте следующий код:


 var
   theStrList: TStringList;
   GPath: String;
 begin
   theStrList := TStringList.Create;
   {Используем GetAliasParams для получения псевдонимов и ассоциированных с ними путей}
   Session.GetAliasParams(<Здесь псевдоним из выпадающего списка>,theStrList);
   {Удаляем первые шесть символов, которые всегда равны "PATH="}
   GPath := copy(theStrList[0],6,length(theStrList[0]))
   theStrList.Free;
 end;
 




Информация о псевдонимах BDE


 var
   MyAliasPath: string;
 const
   AliasName = 'MyAlias';
 
   {**** Получаем из BDE путь MyAlias}
 
   ParamsList := TStringList.Create;
 
 try
   with Session do
   begin
     Session.GetAliasNames(ParamsList);
     Session.GetAliasParams(AliasName, ParamsList);
     MyAliasPath := Copy(ParamsList[0], 6, 50) + '\';
   end;
 finally
   ParamsList.Free;
 end;
 

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

Обратите внимание на метод GetAliasParams класса TSession.

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

Я пользуюсь следующей функцией:


 uses DbiProcs, DBiTypes;
 
 function GetDataBaseDir(const Alias: string): string;
 (* Возвращает каталог расположения базы данных по заданному псевдониму
 (без обратного слеша) *)
 var
   sp: PChar;
   Res: pDBDesc;
 begin
   try
     New(Res);
     sp := StrAlloc(length(Alias) + 1);
     StrPCopy(sp, Alias);
     if DbiGetDatabaseDesc(sp, Res) = 0 then
       Result := StrPas(Res^.szPhyName)
     else
       Result := '';
   finally
     StrDispose(sp);
     Dispose(Res);
   end;
 end;
 




Имитация псевдонима PdoxWIN PRIV

Автор: Eryk Bottomley


 var
   d : TDataBase;
 begin
   d := TDataBase.Create(Application);
   d.DataBaseName := 'PRIV';
   d.DriverName := 'STANDARD';
   d.Params.Add('PATH='+Session.PrivateDir);
   d.Connected := True;
 end;
 

...теперь вы имеете псевдоним с именем 'PRIV', указывающий на частный каталог.




Псевдоним на лету

Попробуйте это:


 type
   TDataMod = class(TDataModule)
     Database: TDatabase;
   public
     procedure TempAlias(NewAlias, NewDir: string);
   end;
 
 procedure TDataMod.TempAlias(NewAlias, NewDir: string);
 begin
   with Session do
     if not IsAlias(NewAlias) then
     begin
       ConfigMode := cmSession; (* NewAlias будет ВРЕМЕННЫМ *)
       try
         AddStandardAlias(NewAlias, NewDir, 'PARADOX');
         Database.Close;
         Database.AliasName := NewAlias;
         Database.Open;
       finally
         ConfigMode := cmAll;
       end;
     end;
 end;
 

Комментарии:

a) Поместите компонент Database на форму DataModule;
b) Задайте свойству DatabaseName имя базы данных, например, 'TempDB';
c) Задайте свойству DatabaseName компонента TTable значение = 'TempDB'
d) Для получения дополнительной информации ознакомьтесь с примером MastApp, поставляемым вместе с D2.




Разрешить длинные строки (более 32 кб)

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


 implementation
 
 {$R *.DFM}
 {$LONGSTRINGS ON}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   F: TextFile;
   i: integer;
   s, buf: string;
 begin
   if OpenDialog1.Execute = false then
     Exit;
   AssignFile(F, OpenDialog1.FileName);
   Reset(F);
   while not EOF(F) do
   begin
     ReadLn(F, buf);
     s := s + buf;
   end;
   Rewrite(F);
   for i := 1 to Length(s) do
     s[i] := chr(ord(s[i]) + 1);
   for i := 1 to (Length(s) + 99) div 100 do
     WriteLn(F, copy(s, (i - 1) * 100, 100));
   CloseFile(F);
 end;
 




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


 if ParamCount > 0 then
 begin
   // Сюда поместите Ваш код, анализирующий ParamStr(1)
 end
 else
 begin
   // а здесь укажите, что делать если парамер не был введен.
   // Это может быть, например, установка параметров по умолчанию
   // или
   // halt // если без введенных параметров программа
   // вообще не должна выполняться
 end;
 application.run;
 




Как заставить формы минимизироваться на панель задач с анимацией

Автор: Nomadic

Дело-то вот в чем: Главным окном программы дельфийской является не главная форма, а окно TApplication, которое имеет нулевые размеры, поэтому его не видно. Именно для него показывается иконка на панели задач. Когда пользователь нажимает кнопку минимизации на главной форме, команда минимизации передается этому окну, и сворачивается именно оно, а для остальных просто делается hide. А так как окно TApplication имеет нулевые размеры, то и анимации никакой не видно.

А чтобы этого избежать, необходимо:

В исходном тесте модуля проекта после вызова Application.Initialize выполнить вызов


 // В исходном тесте модуля проекта после вызова Application.Initialize
 SetWindowLong(Application.Handle, GWL_EXSTYLE,
 GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
 

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


 // // В классе формы
 // Интерфейс
 
 protected
 procedure CreateParams(var p: TCreateParams); override;
 procedure WMSysCommand(var m: TMessage); message WM_SYSCOMMAND;
 


 // Реализация
 procedure TMainForm.CreateParams(var p: TCreateParams);
 begin
 
 inherited;
 p.WndParent := 0;
 end;
 
 procedure TMainForm.WMSysCommand(var m: TMessage);
 begin
 
 m.Result := DefWindowProc(Handle, m.Msg, m.wParam, m.lParam);
 end;
 

Вместо SetWindowLong в MDI-приложениях лучше использовать


 ShowWindow(Application.Handle, SW_HIDE);
 




Анимация без DirectX

Автор: http://sunsb.dax.ru

При попытке изобразить некую анимацию использую только средства TCanvas, на экране получается черте-чего. Все мельтешит, дергается, одним словом - не годится.

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

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

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

TRect я использую, на сучай если размер отображаемой картинки может изменяться.

Стандартным подходом является написание двух процедур - Hide и Show, одна из которых прячет картинку в старой позиции, выводя участок фона поверх нее, а вторая выводит в новой позиции.

Такой вариант не проходит и приводит к мерцанию изображения.

Я предлагаю оставить процедуру Hide в покое, и пользоваться ей только если картинку нужно совсем убрать с экрана.

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

Тут возможны два варианта.

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

Второй - старый и новый прямоугольники не пересекаются. В этом случае мы просто копируем прямоугольник old с невидимой копии фона на экран ( процедура Hide ), и рисуем нужную картинку в прямоугольнике new.

При таком подходе мы избегаем двойной перерисовки экрана, что исключает мерцание.

Ниже программа которая все это делает.


 var wsrf: TPaintBox; // видимый экран
 var ssrf: TBitmap;   // скрытый неизменяемый фон
 var bmp : TBitmap;   // картинка для анимации
 var tmp : TBitmap;   // временное хранилище
 
 function hasIntersect( const A,B : TRect): boolean;
 var R: trect; // пересекаются ли прямоугольники
 begin
    result  := false;
    R.Left  := max( A.Left,   B.Left   );
    R.Right := min( A.Right,  B.Right  );
    if R.Left > = R.Right then exit;
    R.Top   := max( A.Top,    B.Top    );
    R.Bottom:= min( A.Bottom, B.Bottom );
    if R.Top  > = R.Bottom then exit;
    result := true;
 end;
 
 function Union( A, B: TRect ):TRect;
 begin // результат - объединение
    if EmptyRect( A ) then result := B
    else if EmptyRect( B ) then result := A
         else begin
          Result.Left  := min( A.Left,   B.Left   );
          Result.Top   := min( A.Top,    B.Top    );
          Result.Right := max( A.Right,  B.Right  );
          Result.Bottom:= max( A.Bottom, B.Bottom );
       end;
 end;
 
 procedure TOneTooth.Hide;
 begin
   tmp.Width := bmp.Width;
   tmp.Height:= bmp.Height;
   tmp.Canvas.CopyRect( bmpRect(tmp), ssrf.Canvas, old );
   wsrf.Canvas.Draw( old.Left, old.Top, tmp );
 end;
 
 procedure TOneTooth.Show;
 var R, R1 : TRect;
 begin
   now.Right  := now.Left + bmp.Width ;
          //корректировка now на случай
   now.Bottom := now.Top  + bmp.Height;
          //изменения размеров bmp
   if hasIntersect( old, now ) then begin
     R := Union( old, now );
     tmp.Width := R.Right-R.Left;
     tmp.Height:= R.Bottom-R.Top;
     tmp.Canvas.CopyRect( bmpRect(tmp), ssrf.Canvas, R );
        // фон
     tmp.Canvas.Draw( now.left-r.left, now.Top-r.top, bmp )
        // фон + картинка
   end else begin
     Hide;
     tmp.Canvas.CopyRect( bmpRect(bmp), ssrf.Canvas, now );
        // фон
     tmp.Canvas.Draw( 0, 0, bmp ); // фон + картинка
     R:=now;
   end;
   wsrf.Canvas.Draw( R.Left, R.Top, tmp );
   old := now;
 end;
 




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



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



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


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