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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Подключиться к Интернету, определить активные соединения, сохранить параметры соединения

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

как из Вашей программы подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения. Все эти функции находятся в rasapi32.dll. Описания этих функций для Delphi есть в модуле res.pas. Его можно скачать на сайте program.dax.ru (14 Кбайт).

Эта программа заполняет ListBox1 всеми соединениями, ListView1 - всеми активными соединениями. При двойном щелчке по соединению в Edit1 и Edi2 кладутся имя пользователя и пароль (если он сохранен). Кнопка "Dial Up" устанавливает соединение, "Save" сохраняет имя пользователя и пароль. "Hang Up" разрывает соединение. "Update Entries" и "Udate Conns" обновляют информацию о соединениях. В том случае, если связь разорвалась сама, для установления соединения необходимо сначала нажать "Hang Up".

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru. Дустапны проекты для Delphi3 и для Delphi5.


 uses Ras;
 
 var
   CurrentState: string = '';
 
 { Эта функция возвращает строку с
   рассшифровкой значений state и error: }
 function StateStr(state: TRasConnState; error: longint): string;
 var buf: array [0..511] of char; { В рelp-е написано,
                                    что 512 байт хватит всегда }
 begin
   if error <> 0 then begin
     case RasGetErrorString(error, @buf, sizeof(buf)) of
       0: result := buf;
       ERROR_INVALID_PARAMETER: result := 'Invalid parameter';
       else result := 'Error code: ' + IntToStr(error);
     end;
   end else case state of
     RASCS_OpenPort: result := 'Opening port';
     RASCS_PortOpened: result := 'Port opened';
     RASCS_ConnectDevice: result := 'Connecting device';
     RASCS_DeviceConnected: result := 'Device connected';
     RASCS_AllDevicesConnected: result := 'All devices connected';
     RASCS_Authenticate: result := 'Start authenticating';
     RASCS_AuthNotify: result := 'Authentication: notify';
     RASCS_AuthRetry: result := 'Authentication: retry';
     RASCS_AuthCallback: result := 'Authentication: callback';
     RASCS_AuthChangePassword: result := 'Authentication: change password';
     RASCS_AuthProject: result := 'Authentication: projecting';
     RASCS_AuthLinkSpeed: result := 'Authentication: link speed';
     RASCS_AuthAck: result := 'Authentication: acknowledge';
     RASCS_ReAuthenticate: result := 'Authentication: reauthenticate';
     RASCS_Authenticated: result := 'Authenticated';
     RASCS_PrepareForCallback: result := 'Preparing for callback';
     RASCS_WaitForModemReset: result := 'Waiting for modem reset';
     RASCS_WaitForCallback: result := 'Waiting for callback';
     RASCS_Projected: result := 'Projected';
     RASCS_StartAuthentication: result := 'Start authentication';
     RASCS_CallbackComplete: result := 'Callback complete';
     RASCS_LogonNetwork: result := 'Logging on network';
 
     RASCS_Interactive: result := 'Interactive';
     RASCS_RetryAuthentication: result := 'Retry Authentication';
     RASCS_CallbackSetByCaller: result := 'Callback set by caller';
     RASCS_PasswordExpired: result := 'Password expired';
 
     RASCS_Connected: result := 'Connected';
     RASCS_Disconnected: result := 'Disconnected';
     else result := 'Unknown state';
   end;
 end;
 
 // Заполнение s всеми соединениями:
 procedure FillEntries(s: TStrings);
 var
   EntryCount, bufsize: longint;
   entries: LPRasEntryName;
   i: integer;
 begin
   s.Clear;
   s.BeginUpdate;
   bufsize := 0;
   // Определение количества соединений:
   RasEnumEntries(nil, nil, nil, bufsize, EntryCount);
   if EntryCount > 0 then begin
     // Выделение памяти под информацию о соединениях:
     GetMem(entries, bufsize);
     FillChar(entries^, bufsize, 0);
     entries^.dwSize := sizeof(TRasEntryName);
     // Получение информации о соединениях:
     RasEnumEntries(nil, nil, entries, bufsize, EntryCount);
     // Заполнение s названиями соединений:
     for i := 0 to EntryCount - 1 do begin
       s.Add(entries^.szEntryName);
       inc(entries);
     end;
     // Освобождение памяти:
     dec(entries, EntryCount);
     FreeMem(entries);
   end;
   s.EndUpdate;
 end;
 
 // Заполнение items всеми активными соединениями:
 procedure FillConnections(items: TListItems);
 var
   conns: LPRasConn;
   ConnCount, bufsize: longint;
   li: TListItem;
   i: integer;
   status: TRASCONNSTATUS;
 begin
   items.BeginUpdate;
   items.Clear;
   bufsize := 0;
   // Определение количества активных соединений:
   RasEnumConnections(nil, bufsize, ConnCount);
   if ConnCount > 0 then begin
     // Выделение памяти:
     GetMem(conns, bufsize);
     conns^.dwSize := sizeof(TRasConn);
     // Заполнение conns информацией об активных соединениях:
     RasEnumConnections(conns, bufsize, ConnCount);
     status.dwSize := sizeof(TRasConnStatus);
     // Заполнение items названиями соединений:
     for i := 0 to ConnCount - 1 do begin
       li := items.Add;
       li.Data := pointer(conns^.hrasconn);
       li.Caption := conns^.szEntryName;
       li.SubItems.Add(conns^.szDeviceType);
       li.SubItems.Add(conns^.szDeviceName);
       RasGetConnectStatus(conns^.hrasconn, status);
       li.SubItems.Add(StateStr(status.rasconnstate, status.dwError));
       inc(conns);
     end;
     // Освобождение памяти:
     dec(conns, ConnCount);
     FreeMem(conns);
   end;
   items.EndUpdate;
 end;
 
 { Процедура разрывает соединение и
   дожидается завершения операции: }
 procedure HangUpAndWait(conn: integer);
 var
   status: TRasConnStatus;
 begin
   RasHangUp(conn); // Разрыв соединения
   status.dwSize := sizeof(TRasConnStatus);
   // Ожидание уничтожения соединения:
   repeat
     Application.ProcessMessages;
     sleep(0);
   until RasGetConnectStatus(conn, status) = ERROR_INVALID_HANDLE;
 end;
 
 { Эта процедура будет вызываться при любых изменениях в
   соединении: }
 procedure RasNotifier(msg: integer; state: TRasConnState;
   error: Cardinal); stdcall;
 begin
   CurrentState := StateStr(state, error);
   Form1.ListBox2.Items.Add(CurrentState);
   // Обновление информации об актывных соединениях:
   FillConnections(Form1.ListView1.Items);
   if error <> 0 then begin
     Form1.Timer1.Enabled := false;
     Form1.Caption := CurrentState;
   end else begin
     Form1.Timer1.Enabled := false;
     Form1.Timer1.Enabled := true;
     Form1.Timer1.Tag := 0;
   end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   { Установка свойств компонентов (может быть реализована
     через ObjectInspector: }
   Timer1.Enabled := false;
   Button1.Caption := 'Update Entries';
   Button2.Caption := 'Update Conns';
   Button3.Caption := 'Hang Up';
   Button4.Caption := 'Dial Up';
   Button5.Caption := 'Save';
   ListView1.ViewStyle := vsReport; // Вид таблицы
   // Добавление колонок:
   ListView1.Columns.Add.Caption := 'Name';
   ListView1.Columns.Add.Caption := 'Device Type';
   ListView1.Columns.Add.Caption := 'Device Name';
   ListView1.Columns.Add.Caption := 'State';
   // Заполнение компонентов информацией:
   FillEntries(ListBox1.Items);
   FillConnections(ListView1.Items);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // Обновление списка соединений:
   FillEntries(ListBox1.Items);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   // Обновление информации об актывных соединениях:
   FillConnections(ListView1.Items);
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin
   { Если соединений нет - выход, если одно - выделить его, если
     несколько, но ни одно не выделено - выход }
   case ListView1.Items.Count of
     0: Exit;
     1: ListView1.Selected := ListView1.Items[0];
     else if ListView1.Selected = nil then Exit;
   end;
   // Разрыв соединения:
   HangUpAndWait(longint(ListView1.Selected.Data));
   // Обновление информации об актыв  FillConnections(ListView1.Items);
 end;
 
 procedure TForm1.Button4Click(Sender: TObject);
 var
   params: TRasDialParams;
   hRas: THRasConn;
 begin
   if ListBox1.ItemIndex < 0 then Exit;
   ListBox2.Clear;
 
   // Заполнение params
   FillChar(params, sizeof(TRasDialParams), 0);
   params.dwSize := sizeof(TRasDialParams);
   StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
   StrPCopy(params.szUserName, Edit1.Text);
   StrPCopy(params.szPassword, Edit2.Text);
   // Установка связи:
   RasDial(nil, nil, params, 0, @RasNotifier, hRas);
 end;
 
 procedure TForm1.Button5Click(Sender: TObject);
 var params: TRasDialParams;
 begin
   // Сохранение имени пользователя и пароля:
   params.dwSize := sizeof(TRasDialParams);
   StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
   StrPCopy(params.szUserName, Edit1.Text);
   StrPCopy(params.szPassword, Edit2.Text);
   RasSetEntryDialParams(nil, params, false);
 end;
 
 procedure TForm1.ListBox1DblClick(Sender: TObject);
 var
   params: TRasDialParams;
   passw: longbool;
 begin
   if ListBox1.ItemIndex < 0 then Exit;
   // Определение имени пользователя и пароля:
   fillchar(params, sizeof(TRasDialParams), 0);
   params.dwSize := sizeof(TRasDialParams);
   StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
   RasGetEntryDialParams(nil, params, passw);
   Edit1.Text := params.szUserName;
   if passw then begin
     // Пароль доступен
     Edit2.Text := params.szPassword;
     Button4.SetFocus;
   end else begin
     // Пароль не доступен
     Edit2.Text := '';
     Edit2.SetFocus;
   end;
 end;
 
 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   { Если действие происходит дольше секунды - в заголовок окна
     помещается информация о действии и время, которое оно
     происходит }
   Form1.Caption := CurrentState + ' - ' + IntToStr(Timer1.Tag);
   Timer1.Tag := Timer1.Tag + 1;
 end;
 




Как сделать обмен файлами

Сначала Катя искала мужа через Интернет, потом через Интерпол.

Посмотри спецификацию протокола на
http://slavanap2.sourceforge.net/nap.txt или
http://opennap.sourceforge.net/napster.txt

Также есть следующие исходники:
- SlavaNap (Delphi 4) http://slavanap2.sourceforge.net
- OpenNap (C, console app) http://opennap.sourceforge.net
- TekNap (C, console app) http://www.teknap.com
Возможно, что существуют другие исходники. Это можно выяснить в napigator форумах (http://forums.napigator.com)

Кроме того есть mailing list для разработчиков napster-совместимых программ:
http://www.onelist.com/community/napdev
Там также есть архив группы napdev.
Или пошли пустое письмо на napdev-subscribe@yahoogroups.com




Использование Internet-функций Win32 API

Когда собаке нечего делать, она лижет яйца. Когда человеку нечего делать, он бродит по Интернету.

Internet так сильно вошел в нашу жизнь, что программа, так или иначе не использующая его возможности, обречена на “вымирание” почти как динозавры. Поэтому всех программистов, вне зависимости от квалификации и специализации так и тянет дописать до порой уж е готовой программы какой-то модуль для работы с Internet. Но тут и встает вопрос – как это сделать? Давайте рассмотрим, что нам предлагает среда Borland Delphi и Win32 API.

Во-первых, можно использовать компоненты с вкладки FastNet. Все они написаны фирмой NetMasters и поставляются без исходного кода. По многочисленным откликам различных разработчиков можно сказать, что большинство из них не выдерживает никакой критики, особ енно “отличились” компоненты для работы с почтой. Большинство проблем можно было бы исправить, но так как исходные тексты закрыты, то это вряд ли удастся. Даже если вы будете использовать такие вроде бы надежные компоненты как TNMHTTP, TNMFTP, то в случае распространения готовой программы перед вами встает проблема: для полноценной работы программа с этими компонентами требует наличия ряда динамических библиотек. Значит, их надо отыскать, потом поставлять вместе с приложением, копировать в системные папки … Короче говоря, все слишком запутано.

Если вам не требуется всей функциональности этих компонент, например, надо только реализовать функции GET или POST протокола HTTP, то можно поискать на сайтах с компонентами, вроде torry.ru – там обязательно сыщется много различных библиотек, по большей ч асти бесплатных, и с исходным кодом.

Но зачем нам что-то использовать, когда есть доступ к Win32 API ? Если приглядеться, то все эти компоненты всего лишь оболочка для вызова функций более низкого порядка. А раз так, то можно сразу их использовать. Кроме полного контроля над реализацией сете вых функций вы будете иметь и более компактный и быстрый код, так как устраняется прослойка между программой и API. Так что же такое Internet- функции Win32 API?

Все Internet- функции разбиты на категории:

  • General Win32 Internet Functions - общие функции.
  • Automatic Dialing Functions – функции для автодозвона.
  • Uniform Resource Locator (URL) Functions – функции для работы с URL.
  • FTP Functions – FTP- функции.
  • Gopher Functions - Gopher- функции.
  • HTTP Functions - HTTP- функции.
  • Cookie Functions – Работа и управление файлами cookie.
  • Persistent URL Cache Functions - работа с офф-лайном и кешем.

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


 // InternetCheckConnection
 // позволяет узнать, есть ли уже соединение с Internet.
 
 // Синтаксис:
 
 function InternetCheckConnection(lpszUrl: PAnsiChar;
                                  dwFlags: DWORD;
                                  dwReserved: DWORD): BOOL; stdcall;
 

Если нужно проверить, есть ли соединение по конкретному URL, то параметр lpszUrl должен содержать нужный URL; если интересует, есть ли соединение вообще, установите его в nil. DwFlags может иметь значение только FLAG_ICC_FORCE_CONNECTION. Он делает следующее: если первый параметр не nil, то происходит попытка пропинговать указанный хост. Если параметр lpszUrl установлен в nil и есть соединение с другим сервером, то пингуется эт от хост.

Последнее значение , dwReserved, зарезервировано, и должно быть установлено в 0.

К сожалению, я не проверял эту функцию, когда писал статью... а жаль... вот что получаеться: константа FLAG_ICC_FORCE_CONNECTION вообще не описана в Дельфи. более того - ее нет ни в Microsoft Visual C++ 5 (!!!!), VBasic 5 тоже! едва нашел в C++ Builder 5.

Вот описание - const FLAG_ICC_FORCE_CONNECTION $00000001

Но! Даже с описанной константой ничего не работает так, как надо! Вот пример:


 procedure TForm1.Button1Click(Sender: TObject);
 var
  h:boolean;
 begin
  h:= wininet.InternetCheckConnection(nil,$00000001,0);
  if
   h = True then
    Label1.Caption:='Соеденение с сервером 127.0.0.1 установлено.'
  else
   if h = false
    then
      Label1.Caption:='Соеденения с сервером 127.0.0.1 нет.';
 end;
 
 

Запускаю вместе с сервером - вроде должно пинговать его. Но первый раз функция показывает что соеденение есть несмотря на то, стоит ли сервер, или нет. Потом все время выдает false. Если кто из читателей может пролить некоторый свет на проблему этой функции, очень прошу написать мне. Благодарю Суркиза Максима, который впервые обратил мое внимание на проблему.

InternetOpen

Функция возвращает значение TRUE, если компьютер соединен с Internet, и FALSE - в противном случае. Для получения более подробной информации о причинах неудачного выполнения функции вызовите GetLastError, которая возвратит код ошибки. Например, значение E RROR_NOT_CONNECTED информирует нас, что соединение не может быть установлено или компьютер работает в off-line.


 // Далее рассмотрим одну из самых важных функций. Ее вы будете
 // использовать всякий раз, когда нужно получить доступ к любому
 // из серверов – будь то HTTP, FTP или Gopher. Речь идет о InternetOpen .
 
 //Синтаксис:
 
 function InternetOpen(lpszAgent: PChar;
                       dwAccessType: DWORD;
                       lpszProxy, lpszProxyBypass: PChar;
                       dwFlags: DWORD): HINTERNET; stdcall;
 
 

Параметры:

lpszAgent
– строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос.

dwAccessType
- задает необходимые параметры доступа. Принимает следующие значения:

  • INTERNET_OPEN_TYPE_DIRECT – обрабатывает все имена хостов локально.
  • INTERNET_OPEN_TYPE_PRECONFIG – берет установки из реестра.
  • INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY - берет установки из реестра и предотвращает запуск Jscript или Internet Setup (INS) файлов.
  • INTERNET_OPEN_TYPE_PROXY – использование прокси-сервера. В случае неудачи использует INTERNET_OPEN_TYPE_DIRECT. LpszProxy – адрес прокси-сервера. Игнорируется только если параметр dwAccessType отличается от INTERNET_OPEN_TYPE_PROXY. LpszProxyBypass - спис ок имен или IP- адресов, соединяться с которыми нужно в обход прокси-сервера. В списке допускаются шаблоны. Так же, как и предыдущий параметр, не может содержать пустой строки. Если dwAccessType отличен от INTERNET_OPEN_TYPE_PROXY, то значения игнорируютс я, и параметр можно установить в nil. DwFlags – задает параметры, влияющие на поведение Internet- функций . Возможно применение комбинации из следующих разрешенных значений: INTERNET_FLAG_ASYNC, INTERNET_FLAG_FROM_CACHE, INTERNET_FLAG_OFFLINE.

Функция инициализирует использование Internet- функций Win32 API. В принципе, ваше приложение может неоднократно вызывать эту функцию, например, для доступа к различным сервисам, но обычно ее достаточно вызвать один раз. При последующих вызовах других фун кций возвращаемый указатель HINTERNET должен передаваться им первым. Таким образом, можно дважды вызвать InternetOpen, и, имея два разных указателя HINTERNET, работать с HTTP и FTP параллельно. В случае неудачи, она возвращает nil, и для более детального анализа следует вызвать GetLastError.


 // Непосредственно с этой функцией связанна и еще одна, не
 // менее важная: InternetCloseHandle.
 
 // InternetCloseHandle
 
 // Синтаксис: 
 
 function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;
 
 

Как единственный параметр, она принимает указатель, полученный функцией InternetOpen, и закрывает указанное соединение. В случае успешного закрытия сессии возвращается TRUE, иначе - FALSE. Если поток блокирует возможность вызова Wininet.dll, то другой пот ок приложения может вызвать функцию с тем же указателем, чтобы отменить последнюю команду и разблокировать поток.


 // Мы уже установили соединение и знаем, как его закрыть. Теперь
 // нам нужно соединиться с конкретным сервером, используя нужный
 // протокол. В этом нам помогут следующие функции: InternetConnect 
 
 function InternetConnect (hInet: HINTERNET;
                           lpszServerName: PChar;
                           nServerPort: INTERNET_PORT;
                           lpszUsername: PChar;
                           lpszPassword: PChar;
                           dwService: DWORD;
                           dwFlags: DWORD;
                           dwContext: DWORD): HINTERNET; stdcall;
 
 

Функция открывает сессию с указанным сервером, используя протокол FTP, HTTP, Gopher. Параметры:

  • HInet – указатель, полученный после вызова InternetOpen.
  • LpszServerName – имя сервера, с которым нужно установить соединение. Может быть как именем хоста – domain.com.ua, так и IP- адресом – 134.123.44.66.
  • NServerPort – указывает на TCP/IP порт, с которым нужно соединиться. Для задания стандартных портов служат константы: NTERNET_DEFAULT_FTP_PORT (port 21), INTERNET_DEFAULT_GOPHER_PORT (port 70), INTERNET_DEFAULT_HTTP_PORT (port 80), INTERNET_DEFAULT_HTTPS_ PORT (port 443), INTERNET_DEFAULT_SOCKS_PORT (port 1080), INTERNET_INVALID_PORT_NUMBER – порт по умолчанию для сервиса, описанного в dwService. Стандартные порты для различных сервисов находятся в файле SERVICES в директории Windows.
  • LpszUsername – имя пользователя, желающего установить соединение. Если установлено в nil , то будет использовано имя по умолчанию, но для HTTP это вызовет исключение.
  • LpszPassword – пароль пользователя для доступа к серверу. Если оба значения установить в nil, то будут использованы параметры по умолчанию.
  • DwService – задает сервис, который требуется от сервера. Может принимать значения INTERNET_SERVICE_FTP, INTERNET_SERVICE_GOPHER, INTERNET_SERVICE_HTTP.
  • DwFlags - Задает специфические параметры для соединения. Например, если DwService установлен в INTERNET_SERVICE_FTP, то можно установить в INTERNET_FLAG_PASSIVE для использования пассивного режима.

Функция возвращает указатель на установленную сессию или nil в случае невозможности ее установки.

Итак, мы имеем связь с сервером, нужный нам порт открыт. Теперь следует открыть соответствующй файл. Для этого определена функция InternetOpenUrl. Она принимает полный URL файла и возвращает указатель на него. Кстати, перед ее использованием не нужно вызы вать InternetConnect.

InternetOpenUrl

Синтаксис:


 function InternetOpenUrl(hInet: HINTERNET;
                          lpszUrl: PChar;
                          lpszHeaders: PChar;
                          dwHeadersLength: DWORD;
                          dwFlags: DWORD;
                          dwContext: DWORD): HINTERNET; stdcall;
 

Параметры:

  • HInet – указатель, полученный после вызова InternetOpen.
  • LpszUrl – URL , до которого нужно получить доступ. Обязательно должен начинаться с указания протокола, по которому будет происходить соединение. Поддерживаются следующие протоколы - ftp:, gopher:, http:, https:.
  • LpszHeaders – содержит заголовок HTTP запроса.
  • DwHeadersLength – длина заголовка. Если заголовок nil, то можно установить значение –1, и длина будет вычислена автоматически.
  • DwFlags – флаг, задающий дополнительные параметры перед выполнением функции. Вот некоторые его значения: INTERNET_ FLAG_EXISTING_CONNECT, INTERNET_FLAG_HYPERLINK, INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP, INTERNET_FLAG_NO_AUTO_REDIRECT, INTERNET_FLAG_NO_CACH E_WRITE, INTERNET_FLAG_NO_COOKIES.

Возвращается значение TRUE, если соединение успешно, или FELSE - в противном случае. Теперь можно спокойно считывать нужный файл функцией InternetReadFile.

InternetReadFile

Синтаксис:


 function InternetReadFile(hFile: HINTERNET;
                           lpBuffer: Pointer;
                           dwNumberOfBytesToRead: DWORD;
                           var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall;
 

Параметры:

  • HFile – указатель на файл, полученный после вызова функции InternetOpenUrl.
  • LpBuffer – указатель на буфер, куда будут заноситься данные.
  • DwNumberOfBytesToRead - число байт, которое нужно причитать.
  • lpdwNumberOfBytesRead - содержит количество прочитанных байтов. Устанавливается в 0 перед проверкой ошибок.

Функция позволяет считывать данные, используя указатель, полученный в результате вызова InternetOpenUrl, FtpOpenFile, GopherOpenFile, или HttpOpenRequest. Так же, как и все остальные функции, возвращает TRUE или FALSE. После завершения работы функции нужно освободить указатель Hfile, вызвав InternetCloseHandle(hUrlFile) .

Вот, в принципе, и все об самых основных функциях. Для простейшего приложения можно определить примерно такой упрощенный алгоритм использования Internet- функций Win32 API взамен стандартным компонентов. HSession:= InternetOpen - открывает сессию.

HConnect:= InternetConnect - устанавливает соединение.

hHttpFile:=httpOpenRequest

HttpSendRequest - HttpOpenRequest и HttpSendRequest используются вместе для получения доступа к файлу по HTTP- протоколу. Вызов HttpOpenRequest создает указатель и определяет необходимые параметры, а HttpOpenRequest отсылает запрос HTTP серверу, используя эти параметры.


 function HttpOpenRequest(hConnect: HINTERNET;
                          lpszVerb: PChar;
                          lpszObjectName: PChar;
                          lpszVersion: PChar;
                          lpszReferrer: PChar;
                          lplpszAcceptTypes: PLPSTR;
                          dwFlags: DWORD;
                          dwContext: DWORD): HINTERNET; stdcall;
 
 function HttpSendRequest(hRequest: HINTERNET;
                          lpszHeaders: PChar;
                          dwHeadersLength: DWORD;
                          lpOptional: Pointer;
                          dwOptionalLength: DWORD): BOOL; stdcall;
 
 // HttpQueryInfo – используется для получения информации о файле.
 // Вызывается после вызова HttpOpenRequest.
 
 function HttpQueryInfo(hRequest: HINTERNET;
                        dwInfoLevel: DWORD;
                        lpvBuffer: Pointer;
                        var lpdwBufferLength: DWORD;
                        var lpdwReserved: DWORD): BOOL; stdcall;
 
 

  • InternetReadFile - считывает нужный файл.
  • InternetCloseHandle(hHttpFile) – освобождает указатель на файл.
  • InternetCloseHandle(hConnect) - освобождает указатель на соединение.
  • InternetCloseHandle(hSession) - освобождает указатель на сессию.

Объем статьи не позволяет подробно рассмотреть все множество функций, предоставляемых Win32 API. Это введение показало вам только вершину айсберга, а дальше дело за вами – внутренний мир WinAPI очень богат и большинство из того, что обеспечивают сторонние компоненты, можно отыскать в его недрах. Удачи вам!




Как заставить TMediaPlayer проигрывать одно и тоже бесконечно (AVI например)

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


 procedure TForm1.MediaPlayer1Notify(Sender: TObject);
 begin
   with MediaPlayer1 do
     if NotifyValue = nvSuccessful then
     begin
       Notify := True;
       Play;
     end;
 end;
 




Показ даты, времени и состояния клавиш в строке состояния

Предположим, у вас есть StatusBar с 4-мя панелями, плюс таймер. Тогда вы можете сделать:


 procedure TForm1.Timer1Timer(Sender: TObject);
 begin
   with StatusBar1 do
   begin
     if GetKeyState(VK_CAPITAL) <> 0 then
       panels[0].text := ' CAP'
     else
       panels[0].text := '';
     if GetKeyState(VK_NUMLOCK) <> 0 then
       panels[1].text := ' NUM'
     else
       panels[1].text := '';
     if GetKeyState(VK_SCROLL) <> 0 then
       panels[2].text := ' SCRL'
     else
       panels[2].text := '';
     panels[3].text := ' ' + DateTimeToStr(now);
   end;
 end;
 

О том, как можно изменить формат вывода даты, доходчиво и с примерами изложено в электронной справке, в разделе, посвященный датам (Date). Обратите внимание на то, что свойство Text имеет тип строки, поэтому вы не можете написать panels[0].text := DateTime(now), т.к. дата/время имеет тип Double.


 unit Status;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, Menus, Gauges;
 
 type
 
   TStatus = class(TCustomPanel)
   private
     FDate: Boolean;
     FKeys: Boolean;
     FTime: Boolean;
     FResources: Boolean;
     DateTimePanel: TPanel;
     ResPanel: TPanel;
     ResGauge: TGauge;
     CapPanel: TPanel;
 
     NumPanel: TPanel;
     InsPanel: TPanel;
     HelpPanel: TPanel;
     UpdateWidth: Boolean;
     FTimer: TTimer;
     procedure SetDate(A: Boolean);
     procedure SetKeys(A: Boolean);
     procedure SetTime(A: Boolean);
     procedure SetResources(A: Boolean);
     procedure SetCaption(A: string);
     function GetCaption: string;
     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
 
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure SetupPanelFields(ThePanel: TPanel);
     procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
     procedure UpdateStatusBar(Sender: TObject);
   published
     property ShowDate: Boolean read FDate write SetDate default True;
     property ShowKeys: Boolean read FKeys write SetKeys default True;
 
     property ShowTime: Boolean read FTime write SetTime default True;
     property ShowResources: Boolean read FResources write SetResources
       default True;
 
     property BevelInner;
     property BevelOuter;
     property BevelWidth;
     property BorderStyle;
     property BorderWidth;
     property Caption: string read GetCaption write SetCaption;
 
     property Color;
     property Ctl3D;
     property DragCursor;
     property DragMode;
     property Enabled;
     property Font;
     property ParentColor;
     property ParentCtl3d;
     property ParentFont;
     property ParentShowHint;
     property PopUpMenu;
     property ShowHint;
     property Visible;
   end;
 
 procedure Register;
 implementation
 
 procedure Register;
 begin
 
   RegisterComponents('Additional', [TStatus]);
 end;
 
 procedure TStatus.SetupPanelFields(ThePanel: TPanel);
 begin
 
   with ThePanel do
   begin
     Alignment := taCenter;
     Caption := '';
     BevelInner := bvLowered;
     BevelOuter := bvNone;
     {Установите все в True, чтобы все это отразилось на TStatus}
     ParentColor := True;
     ParentFont := True;
 
     ParentCtl3D := True;
   end;
 end;
 
 procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
 begin
 
   SetupPanelFields(ThePanel);
   with ThePanel do
   begin
     Width := Canvas.TextWidth(WidthMask);
     Align := alRight;
   end;
 end;
 
 constructor TStatus.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   Parent := TWinControl(AOwner);
 
   FTime := True;
   FDate := True;
   FKeys := True;
   FResources := True;
   {Заставляем строку состояния выровняться по нижнему краю}
   Align := alBottom;
   Height := 19;
   BevelInner := bvNone;
   BevelOuter := bvRaised;
   {Если UpdateWidth равен TRUE, StatusBar пересчитывает только ширину панелей}
   UpdateWidth := True;
   Locked := True;
   TabOrder := 0;
   ;
   TabStop := False;
   Font.Name := 'Arial';
   Font.Size := 8;
   {Создаем панель, которая будет отображать дату и время}
 
   DateTimePanel := TPanel.Create(Self);
   DateTimePanel.Parent := Self;
   SetupPanel(DateTimePanel, '  00/00/00 00:00:00 дп  ');
   {СОздаем панель, которая будет содержать графику ресурсов}
   ResPanel := TPanel.Create(Self);
   ResPanel.Parent := Self;
   SetupPanel(ResPanel, '                    ');
   {Создаем 2 Gauges, которые размещаем на Resource Panel}
   ResGauge := TGauge.Create(Self);
   ResGauge.Parent := ResPanel;
   ResGauge.Align := alClient;
 
   ResGauge.ParentFont := True;
   ResGauge.BackColor := Color;
   ResGauge.ForeColor := clLime;
   ResGauge.BorderStyle := bsNone;
   {Создаем панель, которая будет отображать состояние CapsLock}
   CapPanel := TPanel.Create(Self);
   CapPanel.Parent := Self;
   SetupPanel(CapPanel, '  Cap  ');
   {Создаем панель, которая будет отображать состояние NumLock}
   NumPanel := TPanel.Create(Self);
   NumPanel.Parent := Self;
   SetupPanel(NumPanel, '  Num  ');
 
   {Создаем панель, которая будет отображать состояние Insert/Overwrite}
   InsPanel := TPanel.Create(Self);
   InsPanel.Parent := Self;
   SetupPanel(InsPanel, '  Ins  ');
   {Создаем панель, которая будет отображать текст состояния}
   HelpPanel := TPanel.Create(Self);
   HelpPanel.Parent := Self;
   SetupPanelFields(HelpPanel);
   {Имеем вспомогательную панель, занимающую все остальное пространство}
   HelpPanel.Align := alClient;
   HelpPanel.Alignment := taLeftJustify;
 
   {Это таймер, который регулярно обновляет строку состояния}
   FTimer := TTimer.Create(Self);
   if FTimer <> nil then
   begin
     FTimer.OnTimer := UpdateStatusBar;
     {Обновление происходит дважды в секунду}
     FTimer.Interval := 500;
     FTimer.Enabled := True;
   end;
 end;
 
 destructor TStatus.Destroy;
 begin
 
   FTimer.Free;
   HelpPanel.Free;
 
   InsPanel.Free;
   NumPanel.Free;
   CapPanel.Free;
   ResGauge.Free;
   ResPanel.Free;
   DateTimePanel.Free;
   inherited Destroy;
 end;
 
 procedure TStatus.SetDate(A: Boolean);
 begin
 
   FDate := A;
   UpdateWidth := True;
 end;
 
 procedure TStatus.SetKeys(A: Boolean);
 begin
 
   FKeys := A;
   UpdateWidth := True;
 end;
 
 procedure TStatus.SetTime(A: Boolean);
 begin
 
   FTime := A;
   UpdateWidth := True;
 end;
 
 procedure TStatus.SetResources(A: Boolean);
 begin
 
   FResources := A;
   UpdateWidth := True;
 end;
 
 {Если мы получаем или устанавливаем заголовок TStatus, то вместо этого задаем
 заголовок HelpPanel}
 
 procedure TStatus.SetCaption(A: string);
 begin
 
   HelpPanel.Caption := ' ' + A;
 end;
 
 function TStatus.GetCaption: string;
 begin
 
   GetCaption := HelpPanel.Caption;
 end;
 
 {Данная процедура устанавливает соответствующие заголовки}
 
 procedure TStatus.UpdateStatusBar(Sender: TObject);
 begin
 
   if ShowDate and ShowTime then
     DateTimePanel.Caption := DateTimeToStr(Now)
   else if ShowDate and not ShowTime then
     DateTimePanel.Caption := DateToStr(Date)
   else if not ShowDate and ShowTime then
 
     DateTimePanel.Caption := TimeToStr(Time)
   else
     DateTimePanel.Caption := '';
   if UpdateWidth then
     with DateTimePanel do
       if ShowDate or ShowTime then
         Width := Canvas.TextWidth(' ' + Caption + ' ')
       else
         Width := 0;
   if ShowResources then
   begin
     ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
 
     if ResGauge.Progress < 20 then
       ResGauge.ForeColor := clRed
     else
       ResGauge.ForeColor := clLime;
   end;
   if UpdateWidth then
     if ShowResources then
       ResPanel.Width := Canvas.TextWidth('                    ')
     else
       ResPanel.Width := 0;
   if ShowKeys then
   begin
     if (GetKeyState(vk_NumLock) and $01) <> 0 then
 
       NumPanel.Caption := '  Num  '
     else
       NumPanel.Caption := '';
     if (GetKeyState(vk_Capital) and $01) <> 0 then
       CapPanel.Caption := '  Cap  '
     else
       CapPanel.Caption := '';
     if (GetKeyState(vk_Insert) and $01) <> 0 then
       InsPanel.Caption := '  Ins  '
     else
       InsPanel.Caption := '';
   end;
   if UpdateWidth then
     if ShowKeys then
 
     begin
       NumPanel.Width := Canvas.TextWidth(' Num ');
       InsPanel.Width := Canvas.TextWidth(' Ins ');
       CapPanel.Width := Canvas.TextWidth(' Cap ');
     end
     else
     begin
       NumPanel.Width := 0;
       InsPanel.Width := 0;
       CapPanel.Width := 0;
     end;
   UpdateWidth := False;
 end;
 
 {Позволяем изменять шрифты, используемые панелями для вывода текста}
 
 procedure TStatus.CMFontChanged(var Message: TMessage);
 begin
 
   inherited;
   UpdateWidth := True;
 end;
 
 end.
 
 interface
 
 implementation
 
 end.
 




Как указать системе на необходимость сбросить буфер INI-файла на диск


 procedure FlushIni(FileName: string);
 var
   {$IFDEF WIN32}
   CFileName: array[0..MAX_PATH] of WideChar;
   {$ELSE}
   CFileName: array[0..127] of Char;
   {$ENDIF}
 begin
   {$IFDEF WIN32}
   if (Win32Platform = VER_PLATFORM_WIN32_NT) then
     WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
     CFileName, MAX_PATH))
   else
     WritePrivateProfileString(nil, nil, nil, PChar(FileName));
   {$ELSE}
   WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
   FileName, SizeOf(CFileName) - 1));
   {$ENDIF}
 end;
 




Проблемы ini-файла

Автор: Tony Chang

Кто-нибудь имел какие-нибудь проблемы при использовании модуля TIniFile? Я думаю здесь какая-то детская проблема с кэшированием!!!

Вот что я делал:


 (* c:\test.ini уже существует *)
 myIni := TIniFile.Create('c:\test.ini');
 With myIni do
 begin
   // .... (добавляем новую секцию в test.ini
 end;
 myIni.Free;
 RenameFile('c:\test.ini', 'c:\test1.ini');
 

Что я получил:

  1. test1.ini НЕ ИМЕЕТ добавленной мною секции;
  2. всякий раз при создании или открытии нового файла в том же самом каталоге с помощью File Manager, 'c:\test.ini' появляется вновь, и у него СУЩЕСТВУЕТ секция, которую я добавлял.

Я решил эту проблему добавлением следующей строки перед IniFile.Free:


 WritePrivateProfileString(nil, nil, nil, PChar(IniFileName));
 

Для получения дополнительной информации обратитесь к электронной справке к разделу 'WritePrivateProfileString'.




Как создать Ini-файл в директории программы

По умолчанию ini-файл создается в Windows-директории (например: TIniFile.Create('MFile.ini' )), что приводит к "захламлению" оной. Более (эко-)логично (за исключением случаев, когда программа делается для CD-ROM) если ini-файл создается в той же директории что и главная программа. Вот пример чтения и записи ini файла из директории программы:


 function ReadIni(ASection, AString : String) : String;
 var
   sIniFile: TIniFile;
   sPath: String[60];
 begin
   GetDir(0,sPath);
   sIniFile := TIniFile.Create(sPath + '\Name.INI');
   Result := sIniFile.ReadString(ASection, AString, S); sIniFile.Free;
 end;
 
 procedure WriteIni(ASection, AString, AValue : String);
 var
   sIniFile: TIniFile;
   sPath: String[60];
 begin
   GetDir(0,sPath);
   sIniFile := TIniFile.Create(sPath + '\Name.INI');
   sIniFile.WriteString(ASection, AString, AValue);
   sIniFile.Free;
 end;
 




Использование InputBox и InputQuery

Решил Вовочка сексуальный ник себе завести. Думал-думал, как поприличнее выразиться... и придумал: put_in

Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi.

Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные.

Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия диалогового окна - кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery.

ShowMessage - другой простой путь отображения сообщения для пользователя.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   s, s1: string;
   b: boolean;
 begin
   s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey'));
   b := s <> '';
   s1 := s;
   if b then
     b := InputQuery('Повторите пароль', 'Пароль', s1);
   if not b or (s1 <> s) then
     ShowMessage('Пароль неверен');
 end;
 




Диалог для ввода значения

Чтобы вызвать диалог, в котором бы пользователь должен был ввести что-нибудь, достаточно воспользоваться функцией InputBox или InputQuery. Эти функции создают диалог с полем ввода, надписью над ним и двумя кнопками: "OK" и "Cancel". Параметры управляют заголовком окна, надписью над полем ввода и начальным значением. Функции отличаются тем, что после вызова InputBox нельзя понять: пользователь нажал "OK", не изменив текст, или "Cancel", а текст был восстановлен самой фунцией. InputQuery возвращает значение типа boolean по которому можно определить, какую кнопку нажал пользователь. Пример:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Caption := InputBox('Заголовок окна',
     'Введите, пожалуйста, заголовок окна:', Form1.Caption);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   s: string;
 begin
   s := Form1.Caption;
   if not InputQuery('Заголовок окна',
     'Введите, пожалуйста, заголовок окна:', s)
   then s := 'No value';
   Form1.Caption := s;
 end;
 




Вставить Combobox в DBGrid


Секрет Windows: Запусти на Пентиуме эмулятор PC XT.

  • Дважды щелкнуть на DBGrid
  • Добавить колонку
  • Указать поле которое будет показываться (свойство FieldName)
  • Заполнить список (свойство PickList)



Вставка текста в TMemo в текущую позицию

Выходит интернетчик из туалета и довольный, говорит: Upload Completed.


 SendMessage(Memo.Handle, EM_REPLACESEL, 0, PCHAR('Delphi World - это КРУТО!'));
 


 Var TempBuf :Array [0..255] of Char;
 SendMessage(Memo.Handle, EM_REPLACESEL, 0, StrPCopy(TempBuf,'Delphi World - это КРУТО!'));
 


 Memo1.SelText := 'Delphi World - ýòî ÊÐÓÒÎ!';
 




Вставка новой записи через буфер

Автор: Eryk Bottomley

Один программер любил компьютеры. Пока его за этим не застукали...


 Table2.Insert;
 Move(Table1.ActiveBuffer^,Table2.ActiveBuffer^,Table1.RecordSize);
 {При необходимости назначаем новый первичный ключ}
 Table2.FieldByName('Primary Key').AsWhatever := whatever;
 Table2.Post;
 

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


 DbiInsertRecord(Table2.Handle,dbiNOLOCK,Table1.ActiveBuffer);
 

...конечно, это "обходит" VCL, т.к., чтобы увидеть потом новую запись, необходимо сделать TTable.Refresh.




Как сделать, чтобы TMemo и TEdit работали в режиме вставки и замены

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".


 type
   TForm1 = class(TForm)
     Memo1: TMemo;
     procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
     procedure Memo1KeyPress(Sender: TObject; var Key: Char);
   private
     {Private declarations}
     InsertOn : bool;
   public
     {Public declarations}
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
 begin
   if (Key = VK_INSERT) and (Shift = []) then
     InsertOn := not InsertOn;
 end;
 
 procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
 begin
   if ((Memo1.SelLength = 0) and (not InsertOn)) then
     Memo1.SelLength := 1;
 end;
 




Инстолятор 2

Звонок в дверь к хакеру, он открывает дверь - а там стоит Смерть, с косой и в балахоне...
- Ты кто?!
- Я твой uninstaller...

Этапы инсталляции

Запомните одно важное правило: инсталлировать программу можно с человеческих носителей (винчестеры, компакт-диски, ZIP-диски) и с дискет :) Если вы собираетесь написать инсталляцию с дискет, которая явно не поместиться на одну дискету, то у вас есть шанс хорошо провести время :)

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

Эта в высшей степени корректная техника перестаёт работать при инсталляции с дискет. Ваша программа, например, копирует четвёртую дискету и тут выясняется, что у неё (у программы) пропал кусок кода. Какие проблемы? — Windows пытается прочитать файл a:\setup.exe и естественно его не находит (на четвёртой-то дискете? откуда?).

Только не паникуйте! Эта проблема давно решена, иначе вы не могли бы установить на свой компьютер ни одной программы! Всё очень просто — программа инсталляции копирует себя и все необходимые файлы во временный каталог на жёсткий диск и перезапускает себя с жёсткого диска. Это и есть первый этап инсталляции. В зарубежных программах он обычно называется "Prepare to install". Ещё раз обратите внимание на то, что совсем не обязательно выполнять этот этап, если вы инсталлируетесь не с дискет, или если ваша инсталляция умещается на одну дискету.

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

Реализация этого этапа до идиотизма тривиальна, поэтому мы и не будем на нём останавливаться подробно.

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

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

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

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

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

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

Копирование программы во временный каталог


 program Setup;
 
 uses
   Windows,
   SysUtils;
 
 const
   ReRunParameter = '/install_from_temp_directory';
 
 var
   TempPath: array [0..MAX_PATH] of Char;
   SrcPath: String;
 
 begin
   if ParamStr(1) = ReRunParameter then
     SrcPath := ParamStr(2)
   else
     if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
     begin
       // Если программа была запущена без ключа и с дискеты, то
       // копируем е¸ во временный каталог и перезапускам
       // Текущее приложение завершаем.
       GetTempPath(MAX_PATH, TempPath);
       // Добавлям к пути временного каталога символ '\', если его там нет
       if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
         StrCat(TempPath, '\');
       // Копируем файл через вызов функции CopyFile из WinAPI
       CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) +
        ExtractFileName(ParamStr(0))), False);
       // Запускаем файл с двумя параметрами
       WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
         ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
       Exit;
     end
     else
       SrcPath := ExtractFilePath(ParamStr(0));
   // Здесь начинается программа инсталляции
   // Переменная SrcPath показывает нам, откуда надо копировать файлы
 end.
 

Есть две грабли, на которые можно наступить в приведённом примере. Первые лежат в вызове функции GetTempPath. Если у вас нет переменных окружения TMP и TEMP, то временным каталогом станет текущий каталог программы, то есть, фактически, ваша дискета.

Вы можете проверять, не находится ли временный каталог на сменном диске (с помощью вызова GetDriveType), и, если находиться, считать временным каталогом C:\TEMP (если его нет — создайте самостоятельно).

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

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

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

Запугивание пользователя законами об авторских правах

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

Как это делается? Если вы не знаете, как сделать диалоговое окно, то, по моему, вам ещё рано писать инсталляции. Если знаете, то выведите окно и поместите в нём нужный текст.

Как получить важные системные данные

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

Имя пользователя и организация

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

HKEY_LOCAL_MACHINE\Software\Microsoft NT\Windows\CurrentVersion\
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ RegisteredOwner = 'Имя'
RegisteredOrganization = 'Организация'

В доступной мне версии Windows 95, эти значения хранятся в ветке HKEY_LOCAL_MACHINE, а в Windows NT — HKEY_CURRENT_USER (в подветках Windows или Windows NT). Поскольку в этом вопросе нет ясности :) я предлагаю проверять обе ветки. Версию операционной системы можно узнать с помощью функции GetVersionEx.

Куда копировать программу:

Можно сформулировать наш вопрос и по другому: где находиться каталог Program Files? Некоторые инсталляции считают, что это C:\Program Files. В действительности, конечно, он может находиться на другом диске, поэтому мы попробуем поискать его по другому... в реестре.

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ ProgramFilesDir = 'D:\Program Files'

Можно воспользоваться функцией SHGetSpecialFolderLocation (это даже более корректно с точки зрения Microsoft). Пример использования этой функции вы обнаружите несколькими файлами позже. Для изменения каталога вы можете вызывать функции SelectDirectory или SHBrowseForFolder. Можно также создать собственное окно диалога "Выбор каталога" с помощью компонента DirectoryListBox. Подробнее о выборе каталога мы поговорим позднее, когда будем рассматривать тонкости процесса инсталляции.

Сколько осталось свободного места на диске

Программа инсталляции перед копированием файлов обязана проверить, сколько на целевом диске осталось свободного дискового пространства. Это делается при помощью функции GetDiskFreeSpace (из модуля Windows) или функции DiskFree (из модуля SysUtils). Вторая функция — это надстройка Delphi над Win API (в смысле, она вызывает GetDiskFreeSpace), но у неё значительно меньше параметров.

Группы программ

Обычно программа инсталляции создаёт для новой программы новую группу. Как правило, когда вы вводите название группы, рядом присутствует список, в котром перечислены все существующие группы. Получить такой список можно двумя способами. Один из них — работа с DDE-сервером, который называется Program Manager. Этот способ мы подробно рассмотрим чуть позже. Второй способ не очень сложен и основан на том факте, что всё меню "Программы" находиться в одном из каталогов вашего диска. Все подменю являются на самом деле подкаталогами, а пукнты — обычными ссылками (файлами с расширением .lnk). Путь к папке, содержащей меню "Программы", вы можете найти в реестре: HKEY_CURRENT_USER\Software\Microsoft\Windows\ CurrentVersion\Explorer\Shell Folders\ Programs = 'D:\WINNT\Profiles\mark\Главное меню\Программы' Не очень сложно прочитать содержимое этого каталога с помощью функций FindFirst/FindNext. Ниже мы и об этом поговорим подробнее, поскольку чтение содержимого каталогов потребуется нам при написании универсальной процедуры копирования файлов.




Как установить BDE

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


 program InstallPrfSt;
 
 {
 Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0
 на "чистой машине" и создать алиас.
 Пример использования в качестве простейшего инсталлятора для программы
 C:\MyDir\MyProg.exe
 1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы:
 CHARSET.BLL
 OTHER.BLL
 IDAPI32.CFG
 BLW32.DLL
 IDAPI32.DLL
 IDBAT32.DLL
 IDPDX32.DLL
 IDR20009.DLL
 IDSQL32.DLL
 BDEADMIN.EXE - по вкусу, т.к. необходимым не является.
 2.Измените значение константы AliasName на имя необходимого вам алиаса.
 3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir.
 ВHИМАHИЕ!!! Если на машине уже установлено BDE, то перед экспериментами
 сохраните (на всякий случай) след. ключи из реестра:
 [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и
 [HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32].
 }
 
 {$APPTYPE CONSOLE}
 uses
   Windows, BDE, Registry;
 
 const
   AliasName: string = 'PrefStat';
 
 var
   R: DBIResult;
   Path: string;
 
 procedure WriteString(S1:string);
 begin
   S1 := S1 + #0;
   AnsiToOem(@S1[1], @S1[1]);
   writeln(S1);
 end;
 
 function GetExePath(S1:string):string;
 var
   I, K :Integer;
   S: string;
 begin
   K := 1;
   S := '';
   for I := Length(S1) downto 1 do
   begin
     if S1[I] = '\' then
     begin
       K := I;
       Break;
     end;
   end;
 
   for I := 1 to K - 1 do
     S := S + S1[I];
 
   Result:=S;
 end;
 
 procedure InstallBde;
 const
   Bor: string = 'SOFTWARE\Borland';
 var
   a: TRegistry;
   BPath: string;
 begin
   BPath:=PATH + '\BDE';
   a := TRegistry.Create;
   with a do
   begin
     RootKey := HKEY_LOCAL_MACHINE;
     OpenKey(Bor + '\Database Engine', True);
     WriteString('CONFIGFILE01', BPath+'\IDAPI32.CFG');
     WriteString('DLLPATH', BPath);
     WriteString('RESOURCE', '0009');
     WriteString('SaveConfig', 'WIN32');
     WriteString('UseCount', '2');
     CloseKey;
     OpenKey(Bor+'\BLW32',True);
     WriteString('BLAPIPATH', BPath);
     WriteString('LOCALE_LIB3', BPath+'\OTHER.BLL');
     WriteString('LOCALE_LIB4', BPath+'\CHARSET.BLL');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\SYSTEM\INIT',True);
     WriteString('AUTO ODBC', 'FALSE');
     WriteString('DATA REPOSITORY', '');
     WriteString('DEFAULT DRIVER', 'PARADOX');
     WriteString('LANGDRIVER', 'ancyrr');
     WriteString('LOCAL SHARE', 'FALSE');
     WriteString('LOW MEMORY USAGE LIMIT', '32');
     WriteString('MAXBUFSIZE', '2048');
     WriteString('MAXFILEHANDLES', '48');
     WriteString('MEMSIZE', '16');
     WriteString('MINBUFSIZE', '128');
     WriteString('SHAREDMEMLOCATION', '');
     WriteString('SHAREDMEMSIZE', '2048');
     WriteString('SQLQRYMODE', '');
     WriteString('SYSFLAGS', '0');
     WriteString('VERSION', '1.0');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\DATE',True);
     WriteString('FOURDIGITYEAR', 'TRUE');
     WriteString('LEADINGZEROD', 'FALSE');
     WriteString('LEADINGZEROM', 'FALSE');
     WriteString('MODE', '1');
     WriteString('SEPARATOR', '.');
     WriteString('YEARBIASED', 'TRUE');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\NUMBER',True);
     WriteString('DECIMALDIGITS', '2');
     WriteString('DECIMALSEPARATOR', ',');
     WriteString('LEADINGZERON', 'TRUE');
     WriteString('THOUSANDSEPARATOR', ' ');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\TIME',True);
     WriteString('AMSTRING', 'AM');
     WriteString('MILSECONDS', 'FALSE');
     WriteString('PMSTRING', 'PM');
     WriteString('SECONDS', 'TRUE');
     WriteString('TWELVEHOUR', 'TRUE');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\REPOSITORIES',True);
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\INIT',True);
     WriteString('LANGDRIVER', 'ancyrr');
     WriteString('TYPE', 'FILE');
     WriteString('VERSION', '1.0');
     CloseKey;
     OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\TABLE
     CREATE',True);
     WriteString('BLOCK SIZE', '4096');
     WriteString('FILL FACTOR', '95');
     WriteString('LEVEL', '7');
     WriteString('STRICTINTEGRTY', 'TRUE');
     CloseKey;
   end;
   a.Free;
 end;
 
 begin
   Path:=GetExePath(ParamStr(0));
   R:=dbiInit(nil);
   if R<>DBIERR_NONE then
   begin
     WriteString('Инициализация BDE ...');
     InstallBDE;
   end;
   R:=dbiInit(nil);
   if R=DBIERR_NONE then
   begin
     WriteString('Инициализация BDE прошла успешно');
     DbiDeleteAlias(nil, PChar(AliasName));
     R:=DbiAddAlias(nil, PChar(AliasName), szPARADOX,
     PChar('PATH:'+Path+'\DB'), True);
     if R=DBIERR_NONE then
       WriteString('Псевдоним "'+AliasName+'" создан')
     else
       WriteString('Ошибка создания псевдонима "'+AliasName+'"');
     R:=DbiCfgSave(nil, nil, Bool(-1));
     if R=DBIERR_NONE then
       WriteString('Файл конфигурации сохранён')
     else
       WriteString('Ошибка сохранения файла конфигурации');
     DbiExit;
   end
   else
     WriteString('Ошибка инициализации BDE');
 end.
 




Как установить BDE 2

На дисках Дельфи в каталоге BDE есть файл bdeinst.cab
 Делаешь в командной строке C:\>extract.exe \bdeinst.cab
 Из кабинетника выпаковывается bdeinst.dll
 Эту DLL переносишь куда тебе надо и там делаешь:
 regsvr32.exe [path]\bdeinst.dll



Как инсталлировать во время работы программы свои шрифты

Жена пpогpаммеpа говоpит мужу:
- Доpогой, я хочу pебенка!
- Ложись, ща пpоинсталлиpуем!

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом:


 {$IFDEF WIN32}
 AddFontResource(PChar(my_font_PathName{AnsiString}));
 {$ELSE}
 var
   ss: array [ 0..255 ] of Char;
 
 AddFontResource(StrPCopy(ss, my_font_PathName));
 {$ENDIF}
 SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
 

Убрать его по окончании работы:


 {$IFDEF WIN32}
 RemoveFontResource(PChar(my_font_PathName));
 {$ELSE}
 RemoveFontResource(StrPCopy(ss, my_font_PathName));
 {$ENDIF}
 SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
 

Где my_font_PathName - полный путь к файлу со шрифтом.




Как установить клиента InterBase

Вежливое обращение к Компьютеру: "Ваше Висючество!"

1. Для Yaffil или FireBird последних билдов - ничего не надо, кроме gds32.dll в директориях поиска библиотек.

2. Для IB5, IB6 или старого FB первых билдов - надо дополнительно прописать в файле services строчку "gds_db 3050/tcp" {файл должен завершаться пустую строкой}.

3. Для IB5, дополнительно к п.2., добавить в ключ реестра:

HKLM\SOFTWARE\InterBase Corp\InterBase\CurrentVersion\RootDirectory

строковое значение - имя папки, в которой лежит файл ib_license.dat

4. В случае медленного подключения клиентов в сети TCP/IP попробуйте прописать адреса IB серверов в файле HOSTS.




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

Идет программист по улице. Встречает девушек.
- Девушки, хотите пива?
- Нет.
- Вино?
- Нет!
- Водку?
- Нет!!
Прграммист думает про себя: "Странно, стандартные драйверы не подошли".

Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.

Примечание:

DriverName = Имя драйвера;
DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).


 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: array [0..64] of char;
 begin
   WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45');
   WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:');
   StrCopy(S, 'PrinterPorts');
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
   StrCopy(S, 'Devices');
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
 end;
 




Вместо печати графики использовать резидентный шрифт принтера

Автор: Олег Кулабухов

Какая разница между Биллом Гейтсом и Богом? Бог не думает, что он - Гейтс.

Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.


 uses Printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   tm: TTextMetric;
   i: integer;
 begin
   if PrintDialog1.Execute then
   begin
     Printer.BeginDoc;
     Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
     GetTextMetrics(Printer.Canvas.Handle, tm);
     for i := 1 to 10 do
       Printer.Canvas.TextOut(100,i * tm.tmHeight + tm.tmExternalLeading,'Test');
     Printer.EndDoc;
   end;
 end;
 




Integer как SmallInt

Автор: Steve Schafer

Я перешел на Delphi 2.0 и у меня появилась проблема с типизированными файлами. У меня есть множество типизированных файлов с различными записями. Теперь, когда целое занимает 4 байта, определения всех моих записей должны быть изменены с расчетом на то, что вместо целого типа придется использовать тип SmallInts. Тем не менее, даже после такого изменения размер моих записей остается прежним...

Вам необходимо использовать модификатор "packed":


 type
   TMyRecType = packed record
     ...
   end;
 




Интеграция Flash в Delphi-приложение

Flash позволяет создавать анимацию для растровой графики и включать её в web-страницы. Многие хорошо знают этот продукт фирмы Macromedia. Если у вас когда-нибудь возникало желание воспроизводить flash'овские movie-клипы [swf-файлы] на своей форме, то теперь вашему желанию суждено сбыться! Для этого нужно сделать следующее:

  1. Скачайте файл SWFLASH.OCX
  2. Импортируйте этот элемент управления ActiveX в среду программирования Delphi. Для этого из меню Component возьмите команду Import ActiveX Control. В появившемся окне щелкните на кнопке Add и укажите на скаченный файл [SWFLASH.OCX]. В том случае, если у вас уже установлен Flash - вам не надо скачивать этот файл - вы его сможете найти по следующему пути: C:\Windows\System\Macromed\Flash



Взаимодействие с чужими окнами

Представьте себе, глупый пользователь сидит как ни в чём небывало с умным видом уже в какой раз пытается составить документ в Microsoft Word'e, но вдруг окно начинает бешено скакать по экрану, в его заголовке выводятся непристойные сообщения, оно то сворачивается, то разворачивается, меняя постоянно свои размеры, а под конец совсем исчезает, унося в небытиё весь текст, который с таким трудом набил ламерюга... а если так себя в любой момент может повести любая программа... впечатления от этого останутся на долго!!!

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

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


 if FindWindow(nil, 'Безымянный - Блокнот') <> 0 then
   ShowMessage('Окно найдено')
 else
   ShowMessage('Окно НЕнайдено');
 

Как мы видим из кода, если наша программа найдёт окно блокнота, мы увидим сообщение, гласящее об этом.

Далее попробуем передвинуть это окно


 var
   h: HWND;
 begin
   h := findwindow(nil, 'Безымянный - Блокнот');
   if h <> 0 then
     SetWindowPos(h, HWND_BOTTOM, 1, 1, 20, 20, swp_nosize);
 end;
 

Опять находим блокнот. Его дескриптор помещаем в переменную класса HWND[С английского Handle Window - дескриптор окна]. Далее используем функцию SetWindowPos для задания позиции. В качестве параметров нужно указать:

  • Дескриптор окна, которое хотим переместить
  • Идентификатор окна, которое предшествует перемещаемому окну в Z-последовательности. Z-последовательность это порядок, в котором формировались окна. Данный параметр указывает с какого именно окна необходимо начинать писк. В качестве значений может принимать либо дескриптор какого-либо окна в системе, либо одно из нижеследующих значений:
    • HWND_BOTTOM Начало Z-последовательности
    • HWND_NOTOPMOST Первое окно которое располагается не "поверх все окон"
    • HWND_TOP Вершина Z-последовательности
    • HWND_TOPMOST Первое окно которое располагается "поверх все окон"
  • Позиция окна по горизонтали
  • Позиция окна по вертикали
  • Ширина окна
  • Высота окна
  • Спецификаторы изменения позиции и размеров окна[флаги]. Для задания значения можно комбинировать следующие константы
    • SWP_DRAWFRAME Прорисовка фрейма вокруг окна.
    • SWP_FRAMECHANGED Посылает сообщение WM_NCCALCSIZE окну, даже если размер его не был изменён. Если этот флаг не указан, сообщение WM_NCCALCSIZE будет посылаться, только после изменения размеров окна.
    • SWP_HIDEWINDOW Скрывает окно.
    • SWP_NOACTIVATE Не активизирует окно. Если же этот флаг не будет поставлен, окно активизируется и будет перемещено поверх всех окон. А вот встанет ли окно даже выше тех окон, которым задано HWND_TOPMOST или нет зависит от параметра hWndInsertAfter.
    • SWP_NOCOPYBITS Если этот спецификатор не будет установлен, тогда содержимое клиентской области окна будет скопировано и вставлено во вновь отобразившееся окно после его перемещения.
    • SWP_NOMOVE Сообщает, что нужно игнорировать параметры задания позиции окну.
    • SWP_NOOWNERZORDER Сообщает, что не следует изменять позицию окна владельца в Z-последовательности.
    • SWP_NOREDRAW Не перерисовывает окно.
    • SWP_NOREPOSITION Такой же как и SWP_NOOWNERZORDER.
    • SWP_NOSENDCHANGING Мешает окну получить сообщение WM_WINDOWPOSCHANGING.
    • SWP_NOSIZE Сообщает, что нужно игнорировать параметры задания размеров окну.
    • SWP_NOZORDER Сохраняет текущее положение в Z-последовательности (игнорирует сообщение hWndInsertAfter parameter).
    • SWP_SHOWWINDOW Отображает окно.

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


 SetWindowText(FindWindow(nil, 'Безымянный - Блокнот'),
 'Дарова, ламерюга, типа ты попал... ');
 

Функции setwindowtext нужно указать только два параметра: это дескриптор нужного окна и новое значение для заголовка. Вот вообщем-то и всё!

Есть ещё одна интересная функция ShowWindow, которая позволяет скрывать или отображать окна. Использовать её нужно так::


 ShowWindow(FindWindow(nil, 'Безымянный - Блокнот'), sw_hide);
 

В скобках указываем сначала над каким именно окном хотим издеваться, а затем что именно мы хотим с ним сделать. В качестве возможных действий можем указать:

  • SW_HIDE Скрывает окно и активизирует другое.
  • SW_MAXIMIZE Разворачивает окно.
  • SW_MINIMIZE Сворачивает окно.
  • SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный размер и позицию.
  • SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.
  • SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при создании процесса приложением запускающим нужную программу.
  • SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.
  • SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.
  • SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е. окно, которое до этого было активно остаётся активно по прежнему.
  • SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.
  • SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами. Активное окно остаётся активным по прежнему.
  • SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные размеры и позицию

Но вся сложность действий заключается в том, что в заголовке Блокнота отслеживается имя текущего файла и использовать значение "Безымянный - Блокнот" мы можем не всегда : (. Тем более это не только в случае с блокнотом... Но есть выход: ведь функции FindWindow для поиска окна мы указываем не только заголовок нужного окна, но ещё его класс. Какой же это выход скажете вы, заголовок окна мы видим, значит знаем, что указывать - а класс окна... в действительности тоже может найти приложив немного усилий!

В пакет Delphi входим специальная утилита для отслеживание всех активных процессов, она называется WinSight32. Вот ею мы и воспользуемся. Запустите её, покопайтесь в списке процессов, ищите строку где значится текущий заголовок нужного окна, например Блокнота, и в левой части этой строки в фигурных скобках вы найдёте имя класса окна. Для блокнота это будет "Notepad". Теперь зная имя класса окна мы можем переписать поиск окна таким способом:


 ShowWindow(FindWindow('Notepad', nil), sw_hide);
 

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

Есть ещё один замечательный способ передачи команд окнам.- функция PostMessage. Ей в качестве параметров нужно указать:

  • Дескриптор окна, которому посылается сообщение или следующие значения:
    • HWND_BROADCAST Сообщение будет послано всем окнам верхнего уровня системы, включая неактивные и невидимые окна, overlapped-окна, и PopUp-окна, но сообщение не будет посылаться дочерним[Child] окнам.
    • NULL Ведёт себя как функция PostThreadMessage с переданным ей dwThreadId параметром.
  • Посылаемое сообщение
  • Первый параметр сообщения
  • Второй параметр сообщения

Например, если послать сообщение wm_quit блокноту - окно будет закрыто без вывода всяких сообщений о необходимости сохранения!


 PostMessage(FindWindow('Notepad', nil), wm_quit, 0, 0);
 




Интерактивные SQL-запросы

Как мне передать значение переменной в SQL-запросе? К примеру, в обработчике onClick клавиши вывести все записи с величиной поля большей, чем задал пользователь. Можно ли в Delphi создать что-либо подобное механизму запросов, реализованному в Paradox for Windows?

Решение этой задачи в Delphi подобно созданию и выполнению строки запроса SQL в Paradox.

Pdoxwin код:


 method pushButton(var eventInfo Event)
 var
 s  string
 q  query
 d  database
 endvar
 
 d.open( "MYALIAS" )
 s = "select * from mytable where somefield=\"" + entryField.value + "\""
 q.readFromString( s )
 q.executeSQL( d )
 
 endmethod
 

Delphi код:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   MyQuery.Active := false;
   MyQuery.SQL.clear;
   MyQuery.SQL.add('select * from mytable where somefield="' +
     EntryField.Text + '"');
   MyQuery.Active := true;
 end;
 




Автоинкрементальные поля и Interbase

Оказывается, что Interbase триггер "before insert" срабатывает только после того, как запись "запостится" из Delphi приложения. В связи с чем становится невозможным увеличение автоинкрементальных ключевых полей. Есть решение?

Большинство программистов решило эту проблему созданием хранимой процедуры (stored procedure), позволяющей от InterBase получить следующий номер и поместить его в вашу запись посредством метода onBeforePost или onNewRecord.




Автоинкрементальные поля и Interbase 2

Автор: Steve Koterski (Borland)

Я пытаюсь сгенерировать последовательный ключ для первичной ключевой колонки, но LIBS мне отвечает "nested select is not support in this context." (вложенный выбор не поддерживается в данном контексте.)

Как насчет:


   CREATE TRIGGER AUTOINCREMENT FOR MYTABLE
   BEFORE INSERT AS
   DECLARE VARIABLE new_key INTEGER;
   BEGIN
     UPDATE AUTOKEYS
       SET KEY_VALUE = KEY_VALUE + 1
       WHERE (KEY_ID = "A");
     SELECT KEY_VALUE
       FROM AUTOKEYS
       WHERE KEY_ID = "A"
       INTO :new_key;
     new.my_key_column = new_key;
   END ^
 




Автоинкрементальные поля и Interbase 3

Автор: Mike Downey

Я пытаюсь добавить запись в таблицу InterBase, содержащую триггеры и blob-поля, тем не менее, всякий раз при выполнении метода "post" после установки ("append") значений, я получаю ошибку: 'Record/Key deleted.' (запись/ключ удален).

Вот реальный пример того, как я обошел эту проблему:

Определение хранимой процедуры:

  Create Procedure NewEmployeeKey Returns ( EmployeeKey Integer ) as
   begin
     EmployeeKey = Gen_Id( gnEmployeeKey, 1 ) ;
   end
Определение триггера:
  Create Trigger SetEmployeeKey for tbEmployee Active Before Insert Position 0 as
   begin
     if ( New.EmployeeKey is Null ) then begin
       Execute Procedure NewEmployeeKey Returning_Values New.EmployeeKey ;
     end
   end

Код Delphi для использования в обработчике события OnNewRecord, или AfterInsert, или BeforePost:


 { qyProviderData - это tQuery }
 { spProviderKey - это tStoredProc }
 
 if qyProviderData.State in [dsInsert] then
 begin
   spProviderKey.ExecProc ;
   qyProviderData.FieldByName( 'ProviderKey' ).AsInteger :=
   spProviderKey.ParamByName( 'ProviderKey' ).AsInteger ;
 end ; { if }
 

Это все, что вам необходимо. Хранимая процедура возвращает следующее сгенерированное значение. Триггер это гарантирует, даже если бы данные не были доступны из вашей Delphi-программы, первичный ключ все еще назначает значение. В Delphi-коде, я полагаю, вы могли бы проверять наличие пустого поля первичного ключа вместо .State in [dsInsert], хотя это то же работает.




Как гарантированно сделать backup

Автор: Nomadic

Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?


 Att.bat:
 at 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT"
 BR.bat:
 del e:\IB_DATA\b.txt
 del e:\IB_DATA\r.txt
 del e:\ib_data\AR_IB.PRV
 del e:\IB_DATA\AR_IB.GBK
 d:\ib_42\bin\gfix -shut -force 1 e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo"
 net stop "InterBase Server"
 copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV
 net start "InterBase Server"
 d:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK -user "SYSDBA" -password "oooo" -B -L -Y "e:\IB_DATA\b.txt"
 d:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo" -P 4096 -V -R -Y "e:\IB_DATA\r.txt"
 Sergey Klochkovski
 




Изображения и InterBase Blob-поля

dBASE и Paradox таблицы имеют в своем арсенале BLOB-поля, позволяющие хранить бинарные данные, в том числе bitmap-формат, отображаемый с помощью компонента TDBImage. В Database Desktop данный тип полей указан как Binary и Graphic (для dBASE и Paradox таблиц, соответственно). Тем не менее, процесс сохранения изображений в InterBase BLOB-полях и их использование в компонентах TDBImage не такой уж простой.

Таблицы InterBase не имеют простого типа BLOB-поля. Есть три варианта, или подтипа: тип 0, тип 1 и подтип, определенный пользователем. Типы 0 и 1 - "встроенные" типы. Тип 0 - BLOB-поля (тип по умолчанию) для хранения общих бинарных данных. Тип 1 - BLOB-поля для хранения текстовых BLOB-данных. Ни один из предопределенных типов не допускает автоматического извлечения данных изображения из BLOB-поля для его последующего отображения в компоненте TDBImage. BLOB-поля типа 0 могут использоваться для хранения данных bitmap-формата, но данные должны извлекаться и передаваться в объект типа TBitmap программным путем. Вот пример ручного извлечения данных изображения, хранящихся в BLOB-поле типа 0 (Table1BLOBField), и его показ в компоненте TImage (не предназначенным для работы с БД) :


 procedure TForm1.ExtractBtnClick(Sender: TObject);
 begin
   Image1.Picture.Bitmap.Assign(Table1BLOBField);
 end;
 

Естественно, поскольку это должно делаться вручную, данный процесс менее желателен в приложении, нежели автоматическое отображение данных изображения в комбинации BDE и компонента TDBImage. Здесь происходит определение подтипа определенного пользователем BLOB-поля. При работе с данными подтип BLOB-поля учитывается, т.к. сохраненные первыми данные устанавливают тип данных для этого поля для всей таблицы целиком. Таким образом, если данные bitmap-формата оказывается первым загружаемым типом, то данный формат будет единственно возможным для данного поля. До сих пор по умолчанию тип бинарного BLOB-поля (предопределенный тип 0) позволял BDE читать и отображать данные в компоненте TDBImage без особых проблем.

Утилиты Database Desktop допускают создание бинарных BLOB-полей только типа 0 и не имеют возможности самим определять подтипы BLOB-полей. Из-за такого ограничения таблицы, подразумевающие хранение и вывод изображений, должны создаваться с помощью SQL-запросов. Обычно это делается посредством утилиты WISQL, но вполне достаточно выполнение SQL-запроса с помощью компонента TQuery. Ниже приведен SQL-запрос, создающий таблицу с определенным пользователем подтипом BLOB-поля:


 CREATE TABLE WITHBMP
 (
   FILENAME CHAR(12),
   BITMAP   BLOB SUB_TYPE -1
 )
 

После создания таблицы с совместимыми BLOB-полями, для хранения данных изображения в BLOB-поле и его вывода в компоненте TDBImage используются те же самые методы, что и при работе с таблицами dBASE и Paradox.

Имеется множество способов загрузки изображений в BLOB-поле. Три самых простых метода включают в себя:

  1. копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем
  2. использование метода LoadFromFile компонента TBLOBField
  3. использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.
Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.

Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
 C: TClipboard;
 begin
 C := TClipboard.Create;
 try
 if Clipboard.HasFormat(CF_BITMAP) then
 DBImage1.PasteFromClipboard
 else
 ShowMessage('Буфер обмена не содержит изображения!');
 finally
 C.Free;
 end;
 end;
 

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

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):


 procedure TForm1.Button2Clicck(Sender: TObject);
 begin
   Table1Bitmap.LoadFromFile(
     'c:\delphi\images\splash\16color\construc.bmp');
 end;
 

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.


 procedure TForm1.Button3Click(Sender: TObject);
 var
   B: TBitmap;
 begin
   B := TBitmap.Create;
   try
     B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
     DBImage1.Picture.Assign(B);
   finally
     B.Free;
   end;
 end;
 




Как узнать текущие дату и время в Interbase

Автор: Nomadic

 Дата + время - DATE.
 Только дата - TODAY.
 Только время - DATE-TODAY.
 



При попытке регистрации UDF возникает ошибка - udf not defined

Автор: Nomadic

Программа "Наша цель - коммунизм!" выполнила недопустимую операцию и будет закрыта. В случае повторной ошибки обращайтесь к разработчику.

  1. Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);

  2. При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):
     declare external function f_SubStr
     cstring(254), integer, integer
     returns
     cstring(254)
     entry_point "Substr" module_name "UDF1"
    Где UDF1 - UDF1.DLL.



После снесения Interbase Server ошибка IBCheck

Автор: Nomadic

Hаши баги мы для совместимости сохраним в следующих версиях.

Решение найдено. Прочитай сам и передай товарищу:

Надо запустить regedit, и открыть ключ

HKEY_LOCAL_MACHINE\Environment

Там есть строка PATH. Так вот иногда она почему-то становится не строкой, а еще чем-то. Ее надо убить, и пересоздать как строку, прописав туда прежнее содержимое (в виде строки).




В InterBase при создании базы ввести параметр для поддержки русского языка


 UPDATE RDB$FIELDS
 SET RDB$CHARACTER_SET_ID = 52
 WHERE RDB$FIELD_NAME = 'RDB$SOURCE''
 




Как перехватывать горячие клавиши в StringGrid

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


 type
   TForm1 = class(TForm)
     Button1: TButton;
     StringGrid1: TStringGrid;
     procedure FormCreate(Sender: TObject);
     procedure Button1Click(Sender: TObject);
     procedure StringGrid1KeyDown(Sender: TObject; var Key: Word;
       Shift: TShiftState);
   private
     { Private declarations }
     procedure CMDialogChar(var Message: TCMDialogChar);
       message CM_DIALOGCHAR;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Button1.Caption := 'E&xit';
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Application.Terminate;
 end;
 
 procedure TForm1.StringGrid1KeyDown(Sender: TObject;
   var Key: Word; Shift: TShiftState);
 begin
   ShowMessage('Grid keypress = ' + Char(Key));
   Key := 0;
 end;
 
 procedure TForm1.CMDialogChar(var Message: TCMDialogChar);
 begin
   if ssAlt in KeyDataToShiftState(Message.KeyData) then
     inherited;
 end;
 




Как перехватить клавишу табуляции Tab в TEdit

Это можно давольно легко сделать переопределив на форме процедуру CMDialogKey. Чтобы посмотреть как это работает, поместите на форму Edit и введите следующий код:


 procedure CMDialogKey(var Msg: TWMKey);
   message CM_DIALOGKEY;
 
 ...
 
 procedure TForma.CMDialogKey(var Msg: TWMKEY);
 begin
   if (ActiveControl is TEdit) and
     (Msg.Charcode = VK_TAB) then
   begin
     ShowMessage('Нажата клавиша TAB?');
   end;
   inherited;
 end;
 




Интерфейсы и published свойства

Итак, мы уже знаем, как найти VTBL. Но в каком порядке хранятся в ней методы ? Ответ можно получить, посмотрев на ассемблерный листинг и сравнив его с исходным кодом VCL. И выяснится, что новые методы дописыватся в конец VTBL, по мере произведения новых классов. Я проследил генеалогию классов до TWinControl и вот что у меня получилось (цифра означает смещение в VTBL):

  • TObject
    Виртуальные методы этого класса расположены в VTBL по отрицательным индексам. Смотрите моё описание RTTI в предыдущей статье
  • TPersistent
    • 0x00 AssignTo
    • 0x01 DefineProperties
    • 0x02 Assign
  • TComponent
    В нём, помимо всего прочего, реализуется также интерфейсы IUnknown & IDispatch, поэтому объекты-производные от него могут быть серверами OLE-Automation
    • 0x03 Loaded
    • 0x04 Notification
    • 0x05 ReadState
    • 0x06 SetName
    • 0x07 UpdateRegistry
    • 0x08 ValidateRename
    • 0x09 WriteState
    • 0x0A QueryInterface
    • 0x0B Create(AOwner: TComponent)
  • TControl
    Его производные классы могут быть помещены на форму во время проектрирования и умеют отображать себя ( так называемые "видимые" компоненты )
    • 0x0C UpdateLastResize
    • 0x0D CanResize
    • 0x0E CanAutoResize
    • 0x0F ConstrainedResize
    • 0x10 GetClientOrigin
    • 0x11 GetClientRect
    • 0x12 GetDeviceContext
    • 0x13 GetDragImages
    • 0x14 GetEnabled
    • 0x15 GetFloating
    • 0x16 GetFloatingDockSiteClass
    • 0x17 SetDragMode
    • 0x18 SetEnabled - полезный метод, особенно для всяких кнопок в диалогах регистрации серийных номеров...
    • 0x19 SetParent
    • 0x1A SetParentBiDiMode
    • 0x1B SetBiDiMode
    • 0x1C WndProc - адрес оконной процедуры. Если она не находит обработчика у себя, вызывается метод TObject::Dispatch. И уже последний метод вызывает dynamic функцию по индексу, равному номеру сообщения Windows.
    • 0x1D InitiateAction
    • 0x1E Invalidate
    • 0x1F Repaint - адрес функции отрисовки компонента
    • 0x20 SetBounds
    • 0x21 Update
  • TWinControl
    Его производные классы имеют собственное окно
    • 0x22 AdjustClientRect
    • 0x23 AlignControls
    • 0x24 CreateHandle
    • 0x25 CreateParams
    • 0x26 CreateWindowHandle
    • 0x27 CreateWnd
    • 0x28 DestroyWindowHandle
    • 0x29 DestroyWnd
    • 0x2A GetControlExtents
    • 0x2B PaintWindow
    • 0x2C ShowControl
    • 0x2D SetFocus

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


 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, Project1_TLB;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses
  Unit2;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
  My_Object: TRP_Server;
  My_Interface: IRP_Server;
 begin
  My_Object := Nil;
  My_Interface := Nil;
  Try
   My_Object := TRP_Server.Create;
   My_Interface := My_Object;
   My_Interface.RP_Prop := PChar('Строка');
   MessageDlg(Format('My Method1: %d, string is %s, refcount is %d',
      [My_Interface.Method1(1), My_Interface.RP_Prop, My_Object.RefCount]),
     mtConfirmation,[mbOk],0);
  finally
    if My_Interface <> Nil then
     My_Interface := Nil;
 { это не правильно - My_Object уже не существует здесь }
    MessageDlg(Format('refcount is %d',[My_Object.RefCount]),
     mtConfirmation,[mbOk],0);
  end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
  RP_IO: IRP_Server;
 begin
  try
   RP_IO := CoRP_Server.Create;
   RP_IO.RP_Prop := 'Yet one string';
   MessageDlg(Format('String is %s, Method1 return %d',
      [RP_IO.RP_Prop, RP_IO.Method1(123)]), mtConfirmation,[mbOk],0);
  except
  On e:Exception do
   MessageDlg(Format('Exception occured: %s, reason %s',
     [e.ClassName, e.Message]), mtError,[mbOk],0);
  end;
 end;

Unit2.pas - объект - сервер OLE-Automation


 interface
 
 uses
   ComObj, ActiveX, Project1_TLB, Dialogs, SysUtils;
 
 type
   TRP_Server = class(TAutoObject, IRP_Server)
   private
     MyString: String;
   protected
     function Get_RP_Prop: PChar; safecall;
     function Method1(a: Integer): Integer; safecall;
     procedure Set_RP_Prop(Value: PChar); safecall;
     { Protected declarations }
   public
     destructor Destroy; override;
   end;
 
 implementation
 
 uses ComServ;
 
 Destructor TRP_Server.Destroy;
 begin
   MessageDlg('Destroy',mtConfirmation,[mbOk],0);
   Inherited Destroy;
 end;
 
 function TRP_Server.Get_RP_Prop: PChar;
 begin
  if MyString <> '' then
    Result := PChar(MyString)
  else
    Result := PChar('');
 end;
 
 function TRP_Server.Method1(a: Integer): Integer;
 begin
  MessageDlg(Format('My Method1: %d', [a]),mtConfirmation,[mbOk],0);
  if MyString <> '' then
    Result := Length(MyString)
  else
    Result := 0;
 end;
 
 procedure TRP_Server.Set_RP_Prop(Value: PChar);
 begin
  if Value <> nil then
   MyString := Value
  else
   MyString := '';
 end;
 
 initialization
   TAutoObjectFactory.Create(ComServer, TRP_Server, Class_RP_Server,
     ciMultiInstance, tmApartment);
   MessageDlg('Initializtion part',mtConfirmation,[mbOk],0);
 end.

Projcet1_TLB.pas - файл, автоматически сгенерированный Delphi для классов, являющихся серверами OLE-Automation


 unit Project1_TLB;
 ...
 interface
 
 uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL;
 
 // *********************************************************************//
 // GUIDS declared in the TypeLibrary. Following prefixes are used:      //
 //   Type Libraries     : LIBID_xxxx                                    //
 //   CoClasses          : CLASS_xxxx                                    //
 //   DISPInterfaces     : DIID_xxxx                                     //
 //   Non-DISP interfaces: IID_xxxx                                      //
 // *********************************************************************//
 const
   LIBID_Project1: TGUID = '{198C3180-6073-11D3-908D-00104BB6F968}';
   IID_IRP_Server: TGUID = '{198C3181-6073-11D3-908D-00104BB6F968}';
   CLASS_RP_Server: TGUID = '{198C3183-6073-11D3-908D-00104BB6F968}';
 type
 
 // *********************************************************************//
 // Forward declaration of interfaces defined in Type Library            //
 // *********************************************************************//
   IRP_Server = interface;
   IRP_ServerDisp = dispinterface;
 
 // *********************************************************************//
 // Declaration of CoClasses defined in Type Library                     //
 // (NOTE: Here we map each CoClass to its Default Interface)            //
 // *********************************************************************//
   RP_Server = IRP_Server;
 
 // *********************************************************************//
 // Interface: IRP_Server
 // Flags:     (4416) Dual OleAutomation Dispatchable
 // GUID:      {198C3181-6073-11D3-908D-00104BB6F968}
 // *********************************************************************//
   IRP_Server = interface(IDispatch)
     ['{198C3181-6073-11D3-908D-00104BB6F968}']
     function Method1(a: Integer): Integer; safecall;
     function Get_RP_Prop: PChar; safecall;
     procedure Set_RP_Prop(Value: PChar); safecall;
     property RP_Prop: PChar read Get_RP_Prop write Set_RP_Prop;
   end;
 
 // *********************************************************************//
 // DispIntf:  IRP_ServerDisp
 // Flags:     (4416) Dual OleAutomation Dispatchable
 // GUID:      {198C3181-6073-11D3-908D-00104BB6F968}
 // *********************************************************************//
   IRP_ServerDisp = dispinterface
     ['{198C3181-6073-11D3-908D-00104BB6F968}']
     function Method1(a: Integer): Integer; dispid 1;
     property RP_Prop: {??PChar} OleVariant dispid 2;
   end;
 
   CoRP_Server = class
     class function Create: IRP_Server;
     class function CreateRemote(const MachineName: string): IRP_Server;
   end;
 
 implementation
 
 uses ComObj;
 
 class function CoRP_Server.Create: IRP_Server;
 begin
   Result := CreateComObject(CLASS_RP_Server) as IRP_Server;
 end;
 
 class function CoRP_Server.CreateRemote(const MachineName: string): IRP_Server;
 begin
   Result := CreateRemoteComObject(MachineName, CLASS_RP_Server) as IRP_Server;
 end;

Меня всегда интересовало, как же это так Delphi позволят иметь код, запускаемый при инициализации и деинициализации модуля ? Просмотрев исходный код в файле Rtl/Sys/System.pas ( я рекомендую иметь исходные тексты, поставляемые вместе с Delphi при исследовании написанных на ней программ ) и сравнив его с ассемблерным листингом, выясняется, что это легко и непринуждённо. Итак, существуют несколько довольно простых структур:


 PackageUnitEntry = record
     Init, FInit : procedure;
   end;
 
   { Compiler generated table to be processed sequentially to init & finit all package units }
   { Init: 0..Max-1; Final: Last Initialized..0                                              }
   UnitEntryTable = array [0..9999999] of PackageUnitEntry;
   PUnitEntryTable = ^UnitEntryTable;
 
   PackageInfoTable = record
     UnitCount : Integer;      { number of entries in UnitInfo array; always > 0 }
     UnitInfo : PUnitEntryTable;
   end;
 
   PackageInfo = ^PackageInfoTable;

При startupе указатель на PackageInfoTable передаётся единственным аргументом функции InitExe:


 start        proc near
              push    ebp
              mov     ebp, esp
              add     esp, 0FFFFFFF4h
              mov     eax, offset dword_0_445424
              call    @@InitExe       ; ::`intcls'::InitExe
 

По адресу 0x445424 хранится DWORD 0x29 и указатель на таблицу структур PackageUnitEntry, где, в частности, на предпоследнем месте содержатся и адреса моих процедур инициализации и деинициализации.

Delphi помещает список реализуемых классом интерфейсов в отдельную структуру, указатель на которую помещает в RTTI по смещению 0x4. Сама эта структура описана во всё том же Rtl/Sys/System.pas:


   PGUID = ^TGUID;
   TGUID = record
     D1: LongWord;
     D2: Word;
     D3: Word;
     D4: array[0..7] of Byte;
   end;
 
   PInterfaceEntry = ^TInterfaceEntry;
   TInterfaceEntry = record
     IID: TGUID;
     VTable: Pointer;
     IOffset: Integer;
     ImplGetter: Integer;
   end;
 
   PInterfaceTable = ^TInterfaceTable;
   TInterfaceTable = record
     EntryCount: Integer;
     Entries: array[0..9999] of TInterfaceEntry;
   end;

Указатель на TInterfaceTable и помещается в RTTI по смещению 0x4 ( если класс реализует какие-либо интерфейсы ). TGUID - это обычная структура UID, используемая в OLE, VTable - указатель на VTBL интерфейса, IOffset - смещение в данном классе на экземпляр, содержащий данные данного интерфейса. Когда вызывается метод интерфейса, он вызывается обычно от указателя на интерфейс, а не на класс, реализующий этот интерфейс. Мы же пишем методы нашего класса, которые ожидают видеть в качестве нулевого аргумента указатель на экземпляр нашего класса. Поэтому Delphi автоматически генерирует для VTable код, настраивающий свой нулевой аргумент соответствующим образом. Например, для моего класса TRP_Server значение поля IOffset составляет 0x34. Функции же, содержащиеся в VTable, выглядят так:


 loc_0_444B39: ; функция, вызываемая по интерфейсу
                 add     dword ptr [esp+4], 0FFFFFFCCh
                 jmp     MyMethod1	; вызов функции в классе
 

Напомню, что все методы интерфейсов должны объявляться как safecall - параметры передаются как в C, справо налево, но очистку стека производит вызываемая процедура. Поэтому в [esp+4] содержится нулевой параметр функции - указатель на экземпляр интерфейса - класса IRP_Server. Затем вызывается метод класса TRP_Server, которому должен нулевым параметром передаваться указатель на экземпляр TRP_Server - поэтому происходит настройка этого параметра, 0x0FFFFFFCC = -0x34.

Самый же значимый резльтат всех этий ковыряний в коде - мне удалось обнаружить в RTTI полное описание всех published свойств ! Из системы помощи Delphi: ( файл del4op.hlp, перевод мой ):

Published члены имеют такую же видимость, как public члены. Разница заключается в том, что для published членов генерируется информация о типе времени исполнения (RTTI). RTTI позволяет приложению динамически обращаться к полям и свойствам объектов и отыскивать их методы. Delphi использует RTTI для доступа к значениям свойств при сохранении и загрузке файлов форм (.DFM), для показа свойств в Object Inspector и для присваивания некоторых методов (называемых обработчиками событий) определённым свойствам (называемых событиями)

Published свойства ограничены по типу данных. Они могут иметь типы Ordinal, string, класса, интерфейса и указателя на метод класса. Также могут быть использованы наборы (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (другими словами, набор должен помещаться в байте, слове или двойном слове ). Также можно иметь published свойство любого вещественного типа (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Класс не может содержать published свойств, если он не скомпилирован с ключом {$M+} или является производным от класса, скомпилированного с этим ключом. Подавляющее большинство классов с published свойствами являются производными от класса TPersistent, который уже скомпилирован с ключом {$M+}, так что Вам редко потребуется использовать эту директиву.

Что сиё может означать для reverse engeneerов ? Значение вышесказанного трудно переоценить - мы можем извлечь из RTTI названия, типы и местоположение в классе всех published свойств любого класса ! Если вспомнить, что такие свойства, как Enable, Text, Caption, Color, Font и многие другие для таких компонентов, как TEdit,TButton,TForm и проч., обычно изменяющиеся, предположим, в диалоге регистрации в зависимости от правильности-неправильности серийного номера, имеют как раз тип published... Поскольку все формы Delphi и компоненты в них имеют published свойства, моя фантазия рисует мне куда более сочную и красочную картину... Одна из главных структур, применяющихся для идентификации published свойств - TPropInfo


   TPropInfo = packed record
     PropType: PPTypeInfo;
     GetProc: Pointer;
     SetProc: Pointer;
     StoredProc: Pointer;
     Index: Integer;
     Default: Longint;
     NameIndex: SmallInt;
     Name: ShortString;
   end;

После структуры наследования ( по смещению 10h в RTTI ) расположен WORD - количество расположенных следом за ним структур TPropInfo, по одной на каждое published свойство. В этой структуре поля имеют следующие значения:

  • PropType - указатель на структуру, описывающую тип данного свойства. Структуры, содержащиеся в TypeInfo, довольно сложные, так что я не буду объяснять, как именно они работают, Вам достаточно знать, что мой IDC script потрошит её в 99 % случаев. Они описаны в файле vcl/typeinfo.pas.
  • GetProc,SetProc,StoredProc - поля, указывающие на методы Get ( извлечение свойства ), Set ( изменение свойства ) и Stored ( признак сохранения значения свойства ). Для всех них есть недокументрированные правила:
    • Если старший байт этих полей равен 0xFF, то в остальных байтах находится смещение в экземпляре класса, по которому находятся данные, представляющие данное свойство. В таком случае все манипуляции со свойством производятся напрямую.
    • Если старший байт равен 0xFE, то в остальных байтах содержится смещение в VTBL класса, т.е. все манипуляции со свойством производятся через виртуальную функцию.
    • Если значение поля равно 0x80000000 - метод не определён ( скажем, метод Set для read-only published свойств )
    • Значение 1 для поля StoredProc означает обязательное сохранение значения свойства.
    • Все остальные значения полей рассматриваются как ссылка на метод класса.
  • Index - значение не выяснено. Есть подозрение, что это поле связано со свойствами типа массив и подчиняется тем же правилам, что и предыдущие три поля. Во время тестирования мне не встретилось ни одного поля Index со значением, отличным от 0x80000000
  • Default - значение свойства по умолчанию
  • NameIndex - порядковый номер published свойства в данном классе, отсчёт ведётся почему-то с 2.
  • Name - Имя свойства, pascal-style строка

Как видите, можно узнать о published-свойствах практически всё, включая адрес, на который нужно ставить точку останова.

Я изменил свой IDC script для анализа RTTI классов Delphi 4, чтобы он поддерживал все обнаруженные структуры.

Желаю удачи...




Интерфейс OLE AutoServer

Автор: Anders Hejlsberg

Это не улыбка, а дружественный интерфейс.

Я пытаюсь создать in-process oleserver с возможностью обратного вызова (callback). Я хочу передавать мой ole-объект MS C++ dll так, чтобы DLL могла бы вызываться из сервера. Проблема в том, что dll "вылетает", если мой сервер - Delphi 2.0, но работает в VB 4.0

Проблема в том, что вы передаете со стороны Delphi Variant, но на стороне C++ "ожидают" IUnknown. Измените прототип функции Delphi следующим образом:


 function SmtOleLink(OleCallBack: IUnknown; ...) ...;
 

Для получения доступа к типу IUnknown необходимо добавить "Ole2" к списку используемых модулей. Теперь измените вызов со стороны Delphi:


 SmtOleLink(VarToInterface(MyObject), 16, 0);
 

Функция "VarToInterface" (определенная в модуле OleAuto) извлекает указатель IDispatch из Variant (или возбуждает исключение, если Variant не содержит ссылки на объект OLE Automation).

Это должно сработать.




Поиск пересечений графика с осью OX

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


 function F(x: double): double;
 begin
   result := sin(x);
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   left = -10;
   right = 10;
 var
   x1, x2: double;
   y1, y2: double;
   k, b: double;
   x, y: double;
   d1, d2: double;
 begin
   x1 := left;
   y1 := f(x1);
   repeat
     x2 := x1 + 0.1;
     y2 := f(x2);
     if y1 * y2 < 0 then
     begin
       repeat
         y1 := f(x1);
         y2 := f(x2);
         k := (y1 - y2) / (x1 - x2);
         b := y1 - k * x1;
         x := -b / k;
         y := k * x + b;
         d1 := sqr(x1 - x) + sqr(y1 - y);
         d2 := sqr(x2 - x) + sqr(y2 - y);
         if d1 > d2 then
         begin
           d1 := d2;
           x1 := x;
         end
         else
           x2 := x;
       until
         d1 < 1E-20;
       ListBox1.Items.Add(FloatToStr(x1));
     end;
     x1 := x2;
     y1 := y2;
   until
     x2 > right;
 end;
 




Преобразование десятичного числа в шестнадцатиричное

Билу Гейтсу в Испании вручили чин Мaркиз, теперь он деБил Гейтс.


 HexString := Format('%0x',[DecValue]);
 

или


 HexString := IntToHex( [DecValue] , [MinDigits] );
 




Преобразование десятичного числа в шестнадцатиричное 2


 function dec2hex(value: dword): string[8];
 const
   hexdigit = '0123456789ABCDEF';
 begin
   while value <> 0 do
   begin
     dec2hex := hexdigit[succ(value and $F)];
     value := value shr 4;
   end;
   if dec2hex = '' then dec2hex := '0';
 end;
 




Использование указателей на целое

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

Сначала вы должны создать тип:


 Type
 Pinteger : ^Integer;
 
 Var
 MyPtr : Pinteger;
 

Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.

Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.

Например,


 NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr))
 

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

Для полноты, это должно быть:


 NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));
 

SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.

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


 Type
   pIntArr = ^IntArr;
   IntArr  = Array[1..1000] of Integer;
 Var
   MyPtr : pIntArr;
 Begin
   GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!)
   { MyPtr[2]:=1; }
   // <<<< Заполняем массив >>>>
   MyPtr[2]^:=1;
   FreeMem(MyPtr,10);
 End;
 

Технология похожа на ту, которуя Delphi использует при работе с pchar. Синтаксис очень похож:


 type
   intarray = array[0..20000] of integer;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   xptr:  ^IntArray;
 begin
   GetMem(xptr, 10);
   xptr^[idx] := 1;  { где idx от 0 до 4, поскольку мы
                       имеем 10 байте = 5 целых }
   FreeMem(xptr, 10);
 end;
 

Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!)




Возведение числа в степень

Алгебра у программистов. Преподаватель пишет на доске: sin X = 1.
- Ну, кто может найти X?
Выбегает программист и так радостно:
- Вот, вот X, - показывает на X.

Это может звучать тривиально, но как мне возвести число в степень? Например, 2^12 = 4095.

На самом деле вопрос далеко не тривиальный. Проблема в том, что сам алгоритм функции далеко не прост. Функцией Power(X, N) (т.е. X^N) должны четко отслеживаться несколько возможных ситуаций:

  1. X любое число, N = 0
  2. X = 1, N любое число
  3. X = 0 и N > 0
  4. X = 0 и N < 0
  5. X > 0
  6. X < 0 и N нечетное целое
  7. X < 0 и N целое
  8. X < 0 и N нецелое

Посмотрите на следующую, абсолютно правильно работающую функцию (тем не менее она может быть и не самой эффективной!):


 interface
 
 type
   EPowerException = class(Exception)
   end;
 
 implementation
 
 function Power(X, N: real): extended;
 var
   t: longint;
   r: real;
   isInteger: boolean;
 begin
   if N = 0 then
   begin
     result := 1.0;
     exit;
   end;
 
   if X = 1.0 then
   begin
     result := 1.0;
     exit;
   end;
 
   if X = 0.0 then
   begin
     if N > 0.0 then
     begin
       result := 0.0;
       exit;
     end
     else
       raise EPowerException.Create('Результат - бесконечность');
   end;
 
   if (X > 0) then
   try
     result := exp(N * ln(X));
     exit;
   except
     raise
       EPowerException.Create('Результат - переполнение или потеря значимости');
   end;
 
   { X - отрицательный, но мы все еще можем вычислить результат, если n целое. }
   { пытаемся получить целую часть n с использованием типа longint, вычисление }
   { четности n не займет много времени }
 
   try
     t := trunc(n);
     if (n - t) = 0 then
       isInteger := true
     else
       isInteger := False;
   except
     { Лишний бит может вызвать переполнение или потерю значимости }
     r := int(n);
     if (n - r) = 0 then
     begin
       isInteger := true;
       if frac(r / 2) = 0.5 then
         t := 1
       else
         t := 2;
     end
     else
       isInteger := False;
   end;
 
   if isInteger then
   begin
     {n целое}
     if odd(t) then
       {n нечетное}
     try
       result := -exp(N * ln(-X));
       exit;
     except
       raise
         EPowerException.Create('Результат - переполнение или потеря значимости');
     end
     else
       {n четное}
     try
       result := exp(N * ln(-X));
       exit;
     except
       raise
         EPowerException.Create('Результат - переполнение или потеря значимости');
     end;
   end
   else
     raise EPowerException.Create('Результат невычисляем');
 end;
 




Возведение числа в степень 2

X^Y = exp(ln(X) * Y) c некоторыми условиями (например, X не может быть нулем).




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

Я пытаюсь создать приложение, помещающее во время запуска иконку в системную область панели задач c надлежащим контекстным меню. Тем не менее приложение все еще остается видимым в панели задач. Использование Application.ShowMainForm:=False оказывается недостаточным.

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


 procedure TMainForm.FormCreate(Sender: TObject);
 begin
   Application.OnMinimize:=AppMinimize;
   Application.OnRestore:=AppMinimize;
   Application.Minimize;
   AppMinimize(@Self);
 end;
 
 procedure TMainForm.AppMinimize(Sender: TObject);
 begin
   ShowWindow(Application.Handle, SW_HIDE);
 end;
 




Показ in-place подсказки в TListBox и других компонентах


 {
   In-place ToolTips are used to display text strings for objects that have been clipped,
   in TreeView for example. The following code has been tested only on standard ListBox.
   Of cause you can use tips on other VCLs after appropriate modification.
   (Only copy following code to your form1's unit file)
 }
 
 //------------------------------------------------------------------------------ 
 //  Show in-place tooltips on ListBox 
 //  Author??Joe Huang                 Email??Happyjoe@21cn.com 
 // 
 //------------------------------------------------------------------------------ 
 
 
 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, CommCtrl;
 
 type
   //Override TListBox's WinProc to get CM_MOUSELEAVE message 
   TNewListBox = class(TListBox)
   protected
     { Protected declarations }
     procedure WndProc(var Message: TMessage); override;
   end;
 
 type
   TForm1 = class(TForm)
     Button2: TButton;
     procedure FormCreate(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
     GHWND: HWND;
     TipVisable: Boolean;
     OldIndex, CurrentIndex: Integer;
     ti: TOOLINFO;
     ListBox1: TListBox;
 
     procedure InitListBox;   //Create ListBox1 dynamically 
     procedure CreateTipsWindow;  //Create Tooltip Window 
     procedure HideTipsWindow;    //Hide Tooltip Window 
 
     //WM_NOTIFY message's handler, fill Tooltip Window content 
     procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;
 
     procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
     procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.dfm}
 
 { TNewListBox }
 
 procedure TNewListBox.WndProc(var Message: TMessage);
 begin
   case Message.Msg of
     CM_MOUSELEAVE: Form1.HideTipsWindow;
   end;
   inherited WndProc(Message);
 end;
 
 { TForm1 }
 
 procedure TForm1.InitListBox;
 begin
   ListBox1 := TNewListBox.Create(Self);
   ListBox1.Parent := Self;
   ListBox1.Left := 50;
   ListBox1.Top := 50;
   ListBox1.Width := 200;
   ListBox1.Height := 200;
   //append serveral items for testing 
   ListBox1.Items.Append('happyjoe');
   ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');
   ListBox1.Items.Append('Delphi 5 Developer''s Guide');
   ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ Advanced Development');
 
   ListBox1.OnMouseMove := ListBox_MouseMove;
   ListBox1.OnMouseDown := ListBox_MouseDown;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Self.Font.Name := 'Tahoma';
   InitListBox;
   CreateTipsWindow;
 end;
 
 procedure TForm1.CreateTipsWindow;
 var
   iccex: tagINITCOMMONCONTROLSEX;
 begin
   // Load the ToolTip class from the DLL. 
   iccex.dwSize := SizeOf(tagINITCOMMONCONTROLSEX);
   iccex.dwICC := ICC_BAR_CLASSES;
   InitCommonControlsEx(iccex);
 
   // Create the ToolTip control. 
   GHWND := CreateWindow(TOOLTIPS_CLASS, '',
                         WS_POPUP,
                         Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                         Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                         0, 0, hInstance,
                         nil);
 
   // Prepare TOOLINFO structure for use as tracking ToolTip. 
   ti.cbSize := SizeOf(ti);
   ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;
   ti.hwnd := Self.Handle;
   ti.uId := ListBox1.Handle;
   ti.hinst := hInstance;
   ti.lpszText := LPSTR_TEXTCALLBACK;
   ti.Rect.Left := 0;
   ti.Rect.Top := 0;
   ti.Rect.Bottom := 0;
   ti.Rect.Right := 0;
 
   SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(False)));
   SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));
 end;
 
 procedure TForm1.WMNotify(var Msg: TMessage);
 var
   phd: PHDNotify;
   NMTTDISPINFO: PNMTTDispInfo;
 begin
   phd := PHDNotify(Msg.lParam);
   if phd.Hdr.hwndFrom = GHWND then
   begin
     if phd.Hdr.Code = TTN_NEEDTEXT then
     begin
       NMTTDISPINFO := PNMTTDispInfo(phd);
       NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);
     end;
   end;
 end;
 
 procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
 begin
   if TipVisable then     //when mouse down, hide Tooltip Window 
   begin
     SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
     TipVisable := False;
   end;
 end;
 
 procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 var
   Index: Integer;
   APoint: TPoint;
   ARect: TRect;
   ScreenRect: TRect;
 begin
   Index := ListBox1.ItemAtPos(Point(X, Y), true);
   if Index = -1 then
   begin
     SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
     OldIndex := -1;
     TipVisable := False;
     Exit;
   end;
   CurrentIndex := Index;
   if Index = OldIndex then Exit;
   if TipVisable then
   begin
     SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
     OldIndex := -1;
     TipVisable := False;
   end else
   begin
     ARect := ListBox1.ItemRect(Index);
 
     if (ARect.Right - ARect.Left - 2) >= ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then
     begin
       OldIndex := -1;
       Exit;
     end;
     APoint := ListBox1.ClientToScreen(ARect.TopLeft);
     windows.GetClientRect(GetDesktopWindow, ScreenRect);
 
     if ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) + APoint.X > ScreenRect.Right then
       APoint.X := ScreenRect.Right - ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) - 5;
     SendMessage(GHWND,
                 TTM_TRACKPOSITION,
                 0,
                 MAKELPARAM(APoint.x - 1, APoint.y - 2));
 
     SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(True)), Integer(@ti));
     OldIndex := Index;
     TipVisable := True;
   end;
 end;
 
 procedure TForm1.HideTipsWindow;
 begin
   if TipVisable then
   begin
     SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
     OldIndex := -1;
     TipVisable := False;
   end;
 end;
 
 // Test it: 
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
  InitListBox;
  CreateTipsWindow;
 end;
 
 end.
 end.
 




Добавление IPERSISTPROPERTYBAG к активным элементам управления

Из хроники. Вчера при попытке запуска нового вируса получил повреждения несовместимые с жизнью компьютер известного международного хакера П. Д. Раста.

Данный совет рассказывает о том, как можно добавить интерфейс IPersistPropertyBag к элементу управления ActiveX. Существует возможность установки свойств элемента управления ActiveX с помощью HTML тэгов PARAM. Добавление интерфейса IPersistPropertyBag в элемент управления ActiveX также позволяет изменять его свойства с помощью инструментов типа ActiveX Control Pad.

Добавление интерфейса IPersistPropertyBag к элементу управления ActiveX очень простая процедура. Все, что необходимо сделать, это добавить интерфейс к определению класса объекта и реализовать три метода интерфейса. Приведенный здесь пример покажет вам эту технологию шаг за шагом, где наш элемент управления ActiveX будет базироваться на TButton. Для упрощения примера мы покажем реализацию функциональности для свойства "Caption" (заголовок). Для реализации полной функциональности можно экстраполировать данный пример на все доступные свойства элемента управления.

Начнем с использования ActiveX Control Wizard и создадим элемент управления ActiveX на основе TButton.

Активизируйте пункт меню File|New и выберите в диалоге New Item (новый элемент) закладку ActiveX. Затем в списке выберите элемент "ActiveX Control". В появившемся диалоговом окне выберите TButton для VCL Class Name. Все остальные настройки можете не трогать и оставить как есть. После нажатия на кнопку OK Delphi сгенерирует базовый код для вашего элемента управления.

Следующим шагом будет добавление интерфейса IPersistPropertyBag к определению класса. Измените первую строку определения, декларирующую тип...


 type
   TButtonX = class(TActiveXControl, IButtonX)
 

на...


 type
   TButtonX = class(TActiveXControl, IButtonX, IPersistPropertyBag)
 

Теперь интерфейс IPersistPropertyBag добавлен к объявлению типа. Затем объявите необходимые методы, добавляя следующие строки в секцию protected:


 function IPersistPropertyBag.InitNew = PersistPropBagInitNew;
 function IPersistPropertyBag.Load = PersistPropBagLoad;
 function IPersistPropertyBag.Save = PersistPropBagSave;
 function PersistPropBagInitNew: HResult; stdcall;
 function PersistPropBagLoad(const pPropBag: IPropertyBag;
   const pErrorLog: IErrorLog): HResult; stdcall;
 function PersistPropBagSave(const pPropBag: IPropertyBag;
   fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult;
   stdcall;
 

Затем, конечно, реализуйте эти функции...


 // -- реализация PersistPropBagInitNew
 function TButtonX.PersistPropBagInitNew: HResult;
 begin
   Result := S_OK;
 end;
 
 // -- реализация PersistPropBagLoad
 function TButtonX.PersistPropBagLoad(const pPropBag:
   IPropertyBag; const pErrorLog: IErrorLog): HResult; stdcall;
 var
   v: OleVariant;
 begin
   if pPropBag.Read('Caption', v, pErrorLog) = S_OK then
     FDelphiControl.Caption := v;
   Result := S_OK;
 end;
 
 // -- реализация PersistPropBagSave
 function TButtonX.PersistPropBagSave(const pPropBag:
   IPropertyBag; fClearDirty: BOOL; fSaveAllProperties: BOOL)
   : HResult; stdcall;
 var
   v: OleVariant;
 begin
   v := FDelphiControl.Caption;
   pPropBag.Write('Caption', v);
   Result := S_OK;
 end;
 

Добавлением этого кода завершается создание элемента управления. Продолжаем дальше: соберите (build) элемент управления ActiveX и разместите его в сети. Сделайте это с помощью мастера Web Delpoy Wizard. Просто сделайте необходимые настройки на странице Project|Web Delpoyment Options и разместите ActiveX через Project| Web Deploy.

Мастер Web Deployment Wizard создаст HTML-страницу, содержащую тэг OBJECT, которая должна выглядеть приблизительно так:

<OBJECT
           classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306"
           codebase="ActiveX/ButtonXControl.ocx"
           width=100
           height=50
           align=center
           hspace=0
           vspace=0
 >
 </OBJECT>
Эта страница должна заработать без проблем. Тем не менее, теперь у вас имеется возможность задания заголовка для кнопок через HTML простым добавлением тэга PARAM. Вам измененный тэг OBJECT должен выглядеть таким образом:
<OBJECT
           classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306"
           codebase="ActiveX/ButtonXControl.ocx"
           width=100
           height=50
           align=center
           hspace=0
           vspace=0
 >
 <Param Name="Caption" Value="Привет">
 </OBJECT>

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




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

MS в обстановке секретности готовит ответ фирме mirabilis и ее знаменитому продукту ICQ. Рабочее название новой MS-разработки - IFuQ.

Функция, представленная в этом примере может быть и не очень элегантна, зато работает. Функция получает в качестве параметра строку, содержащую IP адрес, и возвращает строку с IP адресом в виде DWord значения. Результат легко можно проверить командой "Ping".

Обратите внимание, что необходимо добавить "Math" в "Uses" для функции "IntPower";


 function IP2HEX(OrgIP:string):string;
 var
   // Сохраняем оригинальное значение IP адреса
   OrgVal: string;
   // части оригинального IP
   O1,O2,O3,O4: string;
   // шестнадцатиричные части
   H1,H2,H3,H4: string;
   // Здесь будут собраны все шестнадцатиричные части
   HexIP: string;
   XN: array[1..8] of Extended;
   Flt1: Extended;
   Xc: Integer;
 begin
 
   // Сохраняем в обратном порядке для простого случая
   Xn[8]:=IntPower(16,0);Xn[7]:=IntPower(16,1); Xn[6]:=IntPower(16,2);Xn[5]:=IntPower(16,3);
   Xn[4]:=IntPower(16,4);Xn[3]:=IntPower(16,5); Xn[2]:=IntPower(16,6);Xn[1]:=IntPower(16,7);
 
   // Сохраняем оригинальный IP адрес
   OrgVal:=OrgIP;
   O1:=Copy(OrgVal,1,Pos('.',OrgVal)-1);Delete(OrgVal,1,Pos('.',OrgVal));
   O2:=Copy(OrgVal,1,Pos('.',OrgVal)-1);Delete(OrgVal,1,Pos('.',OrgVal));
   O3:=Copy(OrgVal,1,Pos('.',OrgVal)-1);Delete(OrgVal,1,Pos('.',OrgVal));
   O4:=OrgVal;
 
   H1:=IntToHex(StrToInt(O1),2);H2:=IntToHex(StrToInt(O2),2);
   H3:=IntToHex(StrToInt(O3),2);H4:=IntToHex(StrToInt(O4),2);
 
   // Получаем шестнадцатиричное значение IP адреса
   HexIP:=H1+H2+H3+H4;
 
   // Преобразуем это большое шестнадцатиричное значение в переменную Float
   Flt1:=0;
 
   for Xc:=1 to 8 do
   begin
     case HexIP[Xc] of
       '0'..'9': Flt1:=Flt1+(StrToInt(HexIP[XC])*Xn[Xc]);
       'A': Flt1:=Flt1+(10*Xn[Xc]);
       'B': Flt1:=Flt1+(11*Xn[Xc]);
       'C': Flt1:=Flt1+(12*Xn[Xc]);
       'D': Flt1:=Flt1+(13*Xn[Xc]);
       'E': Flt1:=Flt1+(14*Xn[Xc]);
       'F': Flt1:=Flt1+(15*Xn[Xc]);
     end;
   end;
   Result:=FloatToStr(Flt1);
 end;
 




Простейшая авторизация в ISAPI-CGI приложениях

Сисадмин: - Hу и пусть говорят, что использовать в качестве пароля имя своего кота - дурной тон! RrgTt_fx32!b, кыс-кыс-кыс...

Самый простой способ защитить директорию на web сервере - это применить авторизацию. Этот пример показывает как это сделать используя только ISAPI приложение.

Эти две строчки заставляют браузер спросить имя пользователя и пароль:


 Response.StatusCode := 401; // Запрос логина и пароля
 Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Заголовок
 

Браузер посылает имя пользователя и пароль и мы получаем их:


 Request.Authorization;
 

Но информация закодирована в Base64. Существует довольно много исходников, которые показывают как кодировать/декодировать в Base64. Следующая строчка возвращает декодированные данные в mAuthorization.


 FBase64.DecodeData(Copy(Request.Authorization, 6, Length(Request.Authorization)), mAuthorization);
 




Проверка ISBN

Разница между женщиной и компьютером:
* Женщина всегда реагирует на мышь.
* Её не надо перезагружать.
* Не надо набирать пароль, чтобы войти в неё!!!!

ISBN (или International Standard Book Numbers, международные стандартные номера книг) - мистические кодовые числа, однозначно идентифицирующие книги. Цель этой статьи заключается в том, чтобы убрать покров таинственности, окружающий структуру ISBN, и в качестве примера разработать приложение, проверяющее правильность создания кода-кандидата на ISBN.

ISBN имеет длину тринадцать символов, которые ограничиваются в использовании символами-цифрами от "0" до "9", дефисом, и буквой "X". Этот тринадцатисимвольный код состоит из четырех частей (между которыми располагается дефис): идентификатор группы, идентификатор издателя, идентификатор книги для издателя, и контрольная цифра. Первая часть (идентификатор группы) используется для обозначения страны, географического региона, языка и пр.. Вторая часть (идентификатор издателя) однозначно идентифицирует издателя. Третья часть (идентификатор книги) однозначно идентифицирует данную книгу среди коллекции книг, выпущенных данным издателем. Четвертая, заключительная часть (контрольная цифра), используется в коде алгоритме другими цифрами для получения поддающегося проверке ISBN. Количество цифр, содержащееся в первых трех частях, может быть различным, но контрольная цифра всегда содержит один символ (расположенный между "0" и "9" включительно, или "X" для величины 10), а само ISBN в целом имеет длину тринадцать символов (десять чисел плюс три дефиса, разделяющих три части ISBN).

ISBN 3-88053-002-5 можно так разложить на части:

  Группа:            3
   Издатель:          88053
   Книга:             002
   Контрольная цифра: 5
ISBN можно проверить на правильность кода, используя простой математический алгоритм. Суть его в следующем: нужно взять каждую из девяти цифр первых трех частей ISBN (пропуская нечисловые дефисы), умножить каждую отдельную цифру на число цифр, стоящих слева от позиции числа ISBN (оно всегда будет меньше одинадцати), сложить все результаты умножения, прибавить контрольную цифру, после чего разделить получившееся число на одиннадцать. Если после деления на одинадцать никакого остатка не образуется (т.е., число по модулю 11 делится без остатка), кандидат на ISBN является верным числом ISBN. К примеру, используем предыдущий образец ISBN 3-88053-002-5:
  ISBN:              3  8  8  0  5  3  0  0  2  5
   Множитель:        10  9  8  7  6  5  4  3  2  1
   Продукт:          30+72+64+00+30+15+00+00+04+05 = 220
Поскольку 220 на одинадцать делится без остатка, расмотренный нами кандидат на IDBN является верным кодом ISBN.

Данный алгоритм проверки легко портируется в код Pascal/Delphi. Для извлечения контрольной цифры и кода из ISBN номера используются строковые функции и процедуры, после чего они передаются в функцию проверки. Контрольная цифра преобразуется в тип целого, на основе ее формируется стартовое значение составной переменной, состоящей из добавляемых цифр, умноженных на их позицию в коде ISBN (отдельные цифры, составляющие первые три части ISBN). Для последовательной обработки каждой цифры используется цикл For, в котором мы игнорируем дефисы и умножаем текущую цифру на ее позицию в коде ISBN. В заключение, значение этой составной переменной проверяется на делимость без остатка на одиннадцать. Если остатка после деления нет, код ISBN верен, если же остаток существует, то код кандидат на ISBN имеет неправильный код.

Вот пример этой методики, изложенной на языке функций Delphi:


 function IsISBN(ISBN: string): Boolean;
 var
   Number, CheckDigit: string;
   CheckValue, CheckSum, Err: Integer;
   i, Cnt: Word;
 begin
   {Получаем контрольную цифру}
   CheckDigit := Copy(ISBN, Length(ISBN), 1);
   {Получаем остальную часть, ISBN минус контрольная цифра и дефис}
   Number := Copy(ISBN, 1, Length(ISBN) - 2);
   {Длина разницы ISBN должны быть 11 и контрольная цифра между 0 и 9, или X}
   if (Length(Number) = 11) and (Pos(CheckDigit, '0123456789X') > 0) then
   begin
     {Получаем числовое значение контрольной цифры}
     if (CheckDigit = 'X') then
       CheckSum := 10
     else
       Val(CheckDigit, CheckSum, Err);
     {Извлекаем в цикле все цифры из кода ISBN, применяя алгоритм декодирования}
     Cnt := 1;
     for i := 1 to 12 do
     begin
       {Действуем, если только текущий символ находится между "0" и "9", исключая дефисы}
       if (Pos(Number[i], '0123456789') > 0) then
       begin
         Val(Number[i], CheckValue, Err);
         {Алгоритм для каждого символа кода ISBN, Cnt - n-й обрабатываемый символ}
         CheckSum := CheckSum + CheckValue * (11 - Cnt);
         Inc(Cnt);
       end;
     end;
     {Проверяем делимость без остатка полученного значения на 11}
     if (CheckSum mod 11 = 0) then
       IsISBN := True
     else
       IsISBN := False;
   end
   else
     IsISBN := False;
 end;
 

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




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



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



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


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