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

Работа с ресурсами без TResourceSteram.

FindResource + LoadResource + LockResource.

Определяем размеры картинки хранящейся в ресурсах:

Code: Function PictureSize: TSize; Var. ResHandle: HWND; ResData: HWND; BMI: PBitmapInfo; Begin. Result.cx := 0; Result.cy := 0; ResHandle := FindResource(HInstance, MAKEINTRESOURCE(200), RT_BITMAP); If ResHandle <> 0 then. Begin. ResData := LoadResource(HInstance, ResHandle); If ResData <> 0 then. Try. BMI := LockResource(ResData); If Assigned(BMI) then. Try. Result.cx := BMI.bmiHeader.biWidth; Result.cy := BMI.bmiHeader.biHeight; Finally. UnlockResource(ResData); End; Finally. FreeResource(ResData); End; End; End;

©Drkb::02172.

Получаем список всех ресурсов

Code: Function GetResourceList: Boolean; Var. Errors: Cardinal; Function CallBack(hModule: HMODULE; lpType: PChar; LpzName: LPTSTR; lParam: Longint): BOOL; stdcall; Var. Size: Cardinal; Begin. Result := True; If Assigned(lpzName) then. Begin. Size := Length(ResourceName); Inc(Size); SetLength(ResourceName, Size); ResourceName[Size - 1] := ShortString(lpzName); If (ResourceName[Size - 1] <> 'RES_INI') and. (ResourceName[Size - 1] <> 'RES_MDB') then. Inc(Errors); End; End; Begin. Result := True; ResourceName := nil; Errors := 0; EnumResourceNames(HInstance, 'INSTALL', @CallBack, 0); If (Length(ResourceName) <> 2) or (Errors > 0) then. Begin. MessageBox(Handle, PChar(ERR_CORRUPT), PChar(ERR_GLOBAL), MB_OK + MB_ICONERROR); Result := False; PostQuitMessage(0); End; End;

©Drkb::02173.

Извлекаем ресурс в файл

Code: Function ExtractResource: Boolean; Const. ResName = 'RES_MDB'; Function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; Const. BlockSize = 1024; Type. TArray = array of Byte; Var. Buff: array [0..BlockSize - 1] of Byte; Counter, CurCount, A, I: LongWord; Begin. Counter := 0; Result := Count; I := 10; Repeat. If Count - Counter > BlockSize then. CurCount := BlockSize. Else. CurCount := Count - Counter; Move(TArray(@Buffer)[Counter], Buff[0], CurCount); If WriteFile(THandle(Handle), Buff, CurCount, LongWord(Result), nil) then. Inc(Counter, CurCount). Else. Begin. Result := -1; Exit; End; A := Round((Counter / Count) * 100); If A > I then. Begin. I := A; SendMessage(Progress, PBM_SETPOS, A, 0); End; Until Counter = Count; End; Var. ResHandle: HWND; ResData: HWND; LockRes: Pointer; FHandle: Integer; Size: Integer; Begin. Result := False; Try. ResHandle := FindResource(HInstance, PChar(ResName), 'INSTALL'); If ResHandle = 0 then Exit; ResData := LoadResource(HInstance, ResHandle); If ResData = 0 then Exit; Try. LockRes := LockResource(ResData); If not Assigned(LockRes) then Exit; Try. FHandle := FileCreate(BasePath + '\MainDB.~mdb'); If fHandle = -1 then Exit; Try. Size := SizeofResource(HInstance, ResHandle); If FileWrite(fHandle, LockRes^, Size) = -1 then Exit; Result := True; StatusDone := True; Finally. CloseHandle(THandle(fHandle)); End; Finally. UnlockResource(ResData); End; Finally. FreeResource(ResData); End; Finally. PostMessage(Handle, WM_NOTIFY_THREAD_RESULT, Integer(Result), 0); End; End;

©Drkb::02174.

Отрисовываем картинку из ресурса на форме:

Code: Procedure ShowPicture; Function Rect(Left, Top, Right, Bottom: Integer): TRect; Begin. Result.Left := Left; Result.Top := Top; Result.Right := Right; Result.Bottom := Bottom; End; Var. Bitmap: HBITMAP; BitmapSize: TSize; DC, BitmapDC, OldDC: HDC; BLeft, bTop: Cardinal; _Rect: TRect; S: String; Pen: HPEN; Begin. Bitmap := LoadBitmap(HInstance, MAKEINTRESOURCE(200)); If Bitmap <> 0 then. Try. BitmapSize := PictureSize; DC := GetDC(Handle); Try. BitmapDC := CreateCompatibleDC(DC); Try. OldDC := SelectObject(BitmapDC, Bitmap); Try. BLeft := (Width - BitmapSize.cx); BTop := 0; StretchBlt(DC, 0, 0, bLeft, BitmapSize.cy, BitmapDC, 0, 0, 1, BitmapSize.cy, SRCCOPY); BitBlt(DC, bLeft, bTop, BitmapSize.cx, BitmapSize.cy, BitmapDC, 0, 0, SRCCOPY); SetBkMode(DC, OPAQUE); If hFontBold <> 0 then. SelectObject(DC, hFontBold); S := INFO1; _Rect := Rect(10, 6, 230, 31); DrawText(DC, PChar(S), Length(S), _Rect, DT_WORDBREAK); If hFontNormal <> 0 then. SelectObject(DC, hFontNormal); S := INFO2; _Rect := Rect(10, 40, 280, 70); DrawText(DC, PChar(S), Length(S), _Rect, DT_WORDBREAK + DT_NOCLIP); S := INFO3; _Rect := Rect(10, 55, 280, 100); DrawText(DC, PChar(S), Length(S), _Rect, DT_WORDBREAK + DT_NOCLIP); Pen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW)); Try. SelectObject(DC, Pen); MoveToEx(DC, 6, 127, nil); LineTo(DC, 349, 127); Finally. DeleteObject(Pen); End; Pen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT)); Try. SelectObject(DC, Pen); MoveToEx(DC, 348, 128, nil); LineTo(DC, 5, 128); Finally. DeleteObject(Pen); End; Finally. SelectObject(OldDC, Bitmap); End; Finally. DeleteDC(BitmapDC); End; Finally. ReleaseDC(Handle, DC); End; Finally. DeleteObject(Bitmap); End; End;

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

Автор: Rouse_

©Drkb::02175.

Работа с Bluetooth в Delphi.

Часть 1.

Вступление

Этой статьей хочу начать серию по работе с Bluetooth в Delphi под Microsoft Windows XP. Так как тема весьма сложная, прошу внимательно читать. Повторяться не буду.

Все программы написаны на Delphi 6 и тестировались со стандартным стеком Bluetooth от Microsoft под Windows XP + SP2.

Все необходимые библиотеки прилагаются. Так что дополнительно ничего качать не нужно. При разработке использовал только API функции с JEDI.

Описание функций будут даны в стиле Object Pascal. Сионистов просьба обращаться к MSDN и Microsoft Platform SDK.

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

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

BluetoothFindFirstRadio - начинает перечисление локальных радиомодулей Bluetooth.

Объявление функции:

Code: Function BluetoothFindFirstRadio( Const pbtfrp : PBlueToothFindRadioParams; Var phRadio : THandle): HBLUETOOTH_RADIO_FIND; stdcall;

Параметры:

Pbtfrp. указатель на структуру BLUETOOTH_FIND_RADIO_PARAMS. Член dwSize этой структуры должен содержать размер структуры (устанавливается посредством SizeOf(BLUETOOTH_FIND_RADIO_PARAMS)). PhRadio. описатель (Handle) найденного устройства.

Возвращаемые значения:

· В случае успешного выполнения функция вернет корректный описатель в phRadio и корректный описатель в качестве результата

· В случае ошибки будет возвращен 0. Для получения кода ошибки используйте функцию GetLastError

BluetoothFindNextRadio - находит следующий установленный радиомодуль Bluetooth.

Объявление функции:

Code: Function BluetoothFindNextRadio( HFind : HBLUETOOTH_RADIO_FIND; Var phRadio : THandle): BOOL; stdcall;

Параметры:

HFind. Описатель, который вернула функция BluetoothFindFirstRadio. PhRadio. Сюда будет помещен описатель следующего найденного радиомодуля

Возвращаемые значения:

· Вернет TRUE, если устройство найдено. В phRadio корректный описатель на найденный радиомодуль.

· Вернет FALSE в случае отсутствия устройства. phRadio содержит некорректный описатель. Используйте GetLastError для получения кода ошибки.

BluetoothFindRadioClose - закрывает описатель перечисления радиомодулей Bluetooth.

Объявление функции:

Code: Function BluetoothFindRadioClose(hFind : HBLUETOOTH_RADIO_FIND): BOOL; stdcall;

Параметры:

HFind. Описатель, который вернула функция BluetoothFindFirstRadio.

Возвращаемые значения:

· Вернет TRUE если описатель успешно закрыт.

· Вернет FALSE в случае ошибки. Для получения кода ошибки используйте GetLastError.

Теперь у нас достаточно знаний, чтобы получить список установленных радиомодулей Bluetooth.

Напишем вот такую процедуру:

Code: Procedure EnumRadio; Var. HRadio: THandle; BFRP: BLUETOOTH_FIND_RADIO_PARAMS; HFind: HBLUETOOTH_RADIO_FIND; Begin. // Инициализация структуры BLUETOOTH_FIND_RADIO_PARAMS. BFRP.dwSize := SizeOf(BFRP); // Начинаем поиск. HFind := BluetoothFindFirstRadio(@BFRP, hRadio); If (hFind <> 0) then. Begin. Repeat. // Что-то сделать с полученным описателем. // Закрыть описатель устройства. CloseHandle(hRadio); // Находим следующее устройство. Until (not BluetoothFindNextRadio(hFind, hRadio)); // Закрываем поиск. BluetoothFindRadioClose(hFind); End; End;

Это, конечно, все здорово, но в принципе бесполезно. Давайте что-нибудь сделаем еще. Например, получим информацию о радиомодуле Bluetooth.

Получение информации о радиомодуле Bluetooth.

Для получения информации о радиомодуле Bluetooth используется функция

BluetoothGetRadioInfo - возвращает информацию о радиомодуле, который представлен описателем.

Объявление функции:

Code: Function BluetoothGetRadioInfo(hRadio : THandle; Var pRadioInfo : BLUETOOTH_RADIO_INFO): DWORD; stdcall;

Параметры:

HRadio. Описатель локального радиомодуля, который получен функцией BluetoothFindRadioFirst или BluetoothFindRadioNext. PRadioInfo. Структура, в которую записывается информация об указанном радиомодуле. Член dwSize должен быть равен размеру структуры

Возвращаемые значения:

· Вернет ERROR_SUCCESS если информация получена, в противном случае код ошибки.

Структура BLUETOOTH_RADIO_INFO выгляди вот так:

Code: _BLUETOOTH_RADIO_INFO = record. DwSize : dword; Address : BLUETOOTH_ADDRESS; SzName : array [0..BLUETOOTH_MAX_NAME_SIZE - 1] of widechar; UlClassofDevice : ulong; LmpSubversion : word; Manufacturer : word; End;

DwSize. Размер структуры в байтах Address. Адрес локального радиомодуля SzName. Имя радиомодуля UlClassofDevice. Класс устройства LmpSubversion. Устанавливается производителем Manufacturer. Код производителя (константы BTH_MFG_Xxx). Для получения новых кодов обратитесь к сайту спецификаций Bluetooth.

Это уже что-то. Воспользуемся этой информацией и напишем вот такую процедуру.

Code: Procedure GetRadioInfo(hRadio: THandle); Var RadioInfo: BLUETOOTH_RADIO_INFO; Begin. // Инициализация структуры BLUETOOTH_RADIO_INFO. FillChar(RadioInfo, 0, SizeOf(RadioInfo)); RadioInfo.dwSize := SizeOf(RadioInfo); // Получаем информацию. If (BluetoothGetRadioInfo(hRadio, RadioInfo) = ERROR_SUCCESS) then. Begin. // Используем полученную информацию. End; End;

Заключение

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

Работа с Bluetooth в Delphi.

Часть 2.

Вступление

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

Теперь пришло время получить список устройств Bluetooth, которые подключены к нашим локальным радиомодулям.

Получение списка устройств Bluetooth.

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

BluetoothFindFirstDevice - начинает перечисление устройств Bluetooth.

Объявление функции:

Code: Function BluetoothFindFirstDevice( Const pbtsp : BLUETOOTH_DEVICE_SEARCH_PARAMS; Var pbtdi : BLUETOOTH_DEVICE_INFO): HBLUETOOTH_DEVICE_FIND; stdcall;

Параметры:

Pbtsp. Указатель на структуру BLUETOOTH_DEVICE_SEARCH_PARAMS. Член dwSize этой структуры должен содержать размер структуры (устанавливается посредством SizeOf(BLUETOOTH_DEVICE_SEARCH_PARAMS)). Член hRadio должен содержать описатель локального радиомодуля, полученный вызовом функции BluetoothFindFirstRadio. Pbtdi. Структура BLUETOOTH_DEVICE_INFO в которую будет возвращена информации об устройстве Bluetooth.

Возвращаемые значения:

· В случае успешного выполнения функция вернет корректный описатель в качестве результата.

· В случае ошибки будет возвращен 0. Для получения кода ошибки используйте функцию GetLastError

BluetoothFindNextDevice - находит следующее устройство Bluetooth.

Объявление функции:

Code: Function BluetoothFindNextDevice(hFind : HBLUETOOTH_DEVICE_FIND; Var pbtdi : BLUETOOTH_DEVICE_INFO): BOOL; stdcall;

Параметры:

HFind. Описатель, который вернула функция BluetoothFindFirstDevice. Pbtdi. Структура BLUETOOTH_DEVICE_INFO, в которую будет помещена информацию об устройстве

Возвращаемые значения:

· Вернет TRUE, если устройство найдено.

· Вернет FALSE в случае отсутствия устройства. Используйте GetLastError для получения кода ошибки.

BluetoothFindDeviceClose - закрывает описатель перечисления устройств Bluetooth.

Объявление функции:

Code: Function BluetoothFindDeviceClose(hFind : HBLUETOOTH_DEVICE_FIND): BOOL; stdcall;

Параметры:

HFind. Описатель, который вернула функция BluetoothFindFirstDevice.

Возвращаемые значения:

· Вернет TRUE если описатель успешно закрыт.

· Вернет FALSE в случае ошибки. Для получения кода ошибки используйте GetLastError.

BluetoothGetDeviceInfo - возвращает информацию об указанном устройстве Bluetooth.

Объявление функции:

Code: Function BluetoothGetDeviceInfo(hRadio : THandle; Var pbtdi : BLUETOOTH_DEVICE_INFO): DWORD; stdcall;

Параметры:

HRadio. Описатель локального радиомодуля Bluetooth. Pbtdi. Структура BLUETOOTH_DEVICE_INFO, в которую возвразается информация об устройстве. dwSize должен быть равен размеру структуры. addreess должен содержать адрес устройства, о котором хотим получить информацию.

Возвращаемые значения:

· Вернет ERROR_SUCCESS если выполнено успешно и информация занесена в структуру pbtdi. Остальные значения – код ошибки.

Обладая этими знаниями, можно написать процедуру получения информации об устройствах Bluetooth:

Code: Procedure GetDevices(_hRadio: THandle); Var. DeviceInfo: PBLUETOOTH_DEVICE_INFO; DeviceSearchParams: BLUETOOTH_DEVICE_SEARCH_PARAMS; DeviceFind: HBLUETOOTH_DEVICE_FIND; Begin. // Инициализация структуры BLUETOOTH_DEVICE_SEARCH_PARAMS. With DeviceSearchParams do. Begin. DwSize := SizeOf(BLUETOOTH_DEVICE_SEARCH_PARAMS); FReturnRemembered := true; // Вернуть запомненные. HRadio := _hRadio; End; // Инициализация структуры BLUETOOTH_DEVICE_INFO. FillChar(DeviceInfo, SizeOf(BLUETOOTH_DEVICE_INFO), 0); DeviceInfo.dwSize := SizeOf(PBLUETOOTH_DEVICE_INFO); // Начинаем поиск. DeviceFind := BluetoothFindFirstDevice(DeviceSearchParams, DeviceInfo); If (DeviceFind <> 0) then begin. Repeat. // Что-то сделать с полученными данными. // Инициализация структуры BLUETOOTH_DEVICE_INFO. FillChar(DeviceInfo, SizeOf(BLUETOOTH_DEVICE_INFO), 0); DeviceInfo.dwSize := SizeOf(PBLUETOOTH_DEVICE_INFO); // Находим следующее устройство. Until (not BluetoothFindNextDevice(DeviceFind, DeviceInfo)); // Закрываем поиск. BluetoothFindDeviceClose(DeviceFind); End; End;

Заключение

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

Работа с Bluetooth в Delphi.

Часть 3.

Вступление

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

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

Прежде, чем мы приступим, давайте определимся в терминах. Microsoft в своей документации вводит два термина: Radio и Device. Radio – это локальный радиомодуль Bluetooth (USB-брелок, интегрированное решение, в общем то, что установлено на вашем компьютере). Device – это то устройство Bluetooth с которым вы хотите обмениваться информацией. Будь то телефон, КПК, гарнитура или еще что-то. Важно понимать, что если мы пишем программу для PDA, то когда она работает на PDA - его модуль Bluetooth будет Radio, а компьютер - Device. Если же она работает на компьютере, то компьютерный модуль – Radio, а PDA – Device.

Что мы знаем

К сожалению, документация Microsoft по Bluetooth API и работе с Bluetooth настолько скудна (у меня получилось 50 страниц в Word с оформлением), а примеров они вообще не предоставляют, что из нее очень трудно понять, как же все-таки работает эта технология.

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

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

И так, приступим.

Создание проекта

Давайте создадим в Delphi новый проект и сохраним его под именем BTWork, а модуль – под именем Main.

Главную и пока единственную форму, назовем fmMain. Заголовок BTWork.

Теперь нам понадобятся файл JwaBluetoothAPI.pas, JwaBtHDef.pas и JwaBthSdpDef.pas. Их можно найти в примерах из предыдущих частей или в библиотеке BTClasses.

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

Uses JwaWindows.

и замените JwaWindows на Windows.

Далее удалить из них строки

Code: {$WEAKPACKAGEUNIT}. {$HPPEMIT ''}. {$HPPEMIT '#include "bluetoothapis.h"'}. {$HPPEMIT ''}. {$I jediapilib.inc}.

И в файле JwaBluetoothAPI удалите все, что находится между {$IFDEF DYNAMIC_LINK} и {$ELSE} вместе с этими DEF. И в конце этого файле удалите {$ENDIF}.

Далее, в JwaBluetoothAPI.pas после

Implementation uses JwaWinDLLNames;

Напишите

Const btapi = 'irprops.cpl';

Да простят нас ребята, которые эту библиотеку писали!

Все эти действия я делал для того, что бы уменьшить архив примера. Да и не нужно тянуть за собой много лишнего. Хотя сама библиотека весьма полезна. Один модуль JwaWindows чего стоит. Там очень много интересного есть. Ну да ладно – что-то я отвлекся.

После того, как мы кастрировали эти модули, давайте добавим их в наш проект. Готово?

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

Приступаем.

Оформление главной формы

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

Свойство Значение Align. AlTop. Caption. Name. Panel.

Далее поместим компонент TTreeView и установите свойства как в таблице:

Свойство Значение Align. AlLeft. Cursor. CrHandPoint. HideSelection. False. HotTrack. True. Name. TreeView. ReadOnly. True.

Правее TTreeView поместим TSplitter и установим следующие его свойства:

Свойство Значение Name. Splitter. Width. 5.

И, наконец, помещаем компонент TListView еще правее TSplitter. Устанавливаем его свойства как в таблице:

Свойство Значение Align. AlClient. ColumnClick. False. Cursor. CrHandPoint. GridLines. True. HideSelection. False. HotTrack. True. Name. ListView. ReadOnly. True. RowSelect. True. ShowWorkAreas. True. ViewStyle. VsReport.

На TPanel поместим кнопку TButton.

Свойство Значение Caption. Refresh. Name. BtRefresh.

Теперь мы готовы писать программу.

Пишем код

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

Для этого в обработчике OnCreate формы fmMain напишем такой код:

Code: Procedure TfmMain.FormCreate(Sender: TObject); Begin. BtRefresh.Click; End;

А в обработчике OnClick кнопки btRefresh напишем следующее:

Code: Procedure TfmMain.btRefreshClick(Sender: TObject); Var. RootNode: TTreeNode; HFind: HBLUETOOTH_RADIO_FIND; HDevFind: HBLUETOOTH_DEVICE_FIND; FindParams: BLUETOOTH_FIND_RADIO_PARAMS; SearchParams: BLUETOOTH_DEVICE_SEARCH_PARAMS; SearchParamsSize: dword; DevInfo: ^PBLUETOOTH_DEVICE_INFO; DevInfoSize: dword; HRadio: THandle; RadioInfo: PBLUETOOTH_RADIO_INFO; RadioInfoSize: dword; RadioNode: TTreeNode; Loop: integer; DevNode: TTreeNode; Begin. With TreeView.Items do. Begin. BeginUpdate; // Очищаем дерево. For Loop := 0 to Count - 1 do. Begin. If TreeView.Items[Loop].ImageIndex > 0 then. CloseHandle(TreeView.Items[Loop].ImageIndex); If Assigned(TreeView.Items[Loop].Data) then. Dispose(TreeView.Items[Loop].Data); End; Clear; // Корневая ветвь в дереве. RootNode := Add(nil, 'Bluetooth Radios'); With RootNode do. Begin. Data := nil; ImageIndex := -1; End; // Начинаем поиск локальных модулей Bluetooth. FindParams.dwSize := SizeOf(BLUETOOTH_FIND_RADIO_PARAMS); HFind := BluetoothFindFirstRadio(@FindParams, hRadio); If hFind <> 0 then begin. Repeat. // Получить информацию о радиомодуле. New(RadioInfo); RadioInfoSize := SizeOf(BLUETOOTH_RADIO_INFO); FillChar(RadioInfo^, RadioInfoSize, 0); RadioInfo^.dwSize := RadioInfoSize; // Ошибки не обрабатываем!!! BluetoothGetRadioInfo(hRadio, RadioInfo^); // Добавляем радио в дерево. RadioNode := AddChild(RootNode, String(RadioInfo^.szName) + ' [' + BTAdrToStr(RadioInfo^.address) + ']'); With RadioNode do. Begin. // Так как мы сохраняем Handle, то не закрываем его! ImageIndex := hRadio; Data := RadioInfo; End; // Начинаем поиск устройств для найденного радиомодуля. SearchParamsSize := SizeOf(BLUETOOTH_DEVICE_SEARCH_PARAMS); FillChar(SearchParams, SearchParamsSize, 0); SearchParams.dwSize := SearchParamsSize; SearchParams.fReturnRemembered := True; SearchParams.hRadio := hRadio; New(DevInfo); DevInfoSize := SizeOf(BLUETOOTH_DEVICE_INFO); FillChar(DevInfo^, DevInfoSize, 0); DevInfo^.dwSize := DevInfoSize; // Ищем первое. HDevFind := BluetoothFindFirstDevice(SearchParams, DevInfo^); If hDevFind <> 0 then begin. Repeat. // Добавляем в дерево. DevNode := AddChild(RadioNode, String(DevInfo^.szName) + ' [' + BTAdrToStr(DevInfo^.Address) + ']'); With DevNode do. Begin. Data := DevInfo; ImageIndex := -2; End; // Ищем следующее устройство. New(DevInfo); DevInfoSize := SizeOf(BLUETOOTH_DEVICE_INFO); FillChar(DevInfo^, DevInfoSize, 0); DevInfo^.dwSize := DevInfoSize; Until not BluetoothFindNextDevice(hDevFind, DevInfo^); // Поиск устройств закончен. BluetoothFindDeviceClose(hDevFind); End; // Находим следующее радио. Until not BluetoothFindNextRadio(hFind, hRadio); // Поиск радиомодулей закончен. BluetoothFindRadioClose(hFind); End; EndUpdate; End; With TreeView do. Begin. Selected := RootNode; Items[0].Expand(True); End; End;

В uses нашего модуля, который относится к главной форме, допишем:

Code: Implementation // Уже написано!!! Uses // Дописать! JwaBluetoothAPIs, Windows, SysUtils, Dialogs;

Ниже добавим функцию:

Code: // Преобразует адрес из внутреннего формата (dword) в строку, // принятую для представления адресов устройств Bluetooth. Function BTAdrToStr(const Adr: BLUETOOTH_ADDRESS): string; Var. Loop: byte; Begin. Result := IntToHex(Adr.rgBytes[0], 2); For Loop := 1 to 5 do. Result := IntToHex(Adr.rgBytes[Loop], 2) + ‘:’ + Result; End;

Здесь хочу привести описание используемых структур, так как ранее я их не описывал:

BLUETOOTH_DEVICE_SEARCH_PARAMS.

Объявление:

Code: BLUETOOTH_DEVICE_SEARCH_PARAMS = record. DwSize : DWORD; FReturnAuthenticated : BOOL; FReturnRemembered : BOOL; FReturnUnknown : BOOL; FReturnConnected : BOOL; FIssueInquiry : BOOL; CTimeoutMultiplier : UCHAR; HRadio : THandle; End;

Члены:

DwSize. Входной параметр. Должен быть равен размеру структуры (dwSize := SizeOf(BLUETOOTH_DEVICE_SEARCH_PARAMS)). FReturnAuthenticated. Входной параметр. Функция будет возвращать устройства, прошедшие авторизацию. FReturnRemembered. Входной параметр. Функция будет возвращать устройства, уже запомненные раннее. FReturnUnknown. Входной параметр. Функция будет возвращать новые либо неизвестные устройства. FReturnConnected. Входной параметр. Функция будет возвращать подключенные устройства. FIssueInquiry. Входной параметр. Заставляет функцию проверять устройства. CTimeoutMultiplier. Входной параметр. Тайм-аут для проверки устройства. HRadio. Handle радиомодуля, для которого проводится поиск устройств. Если 0, то проверяются все радиомодули.

BLUETOOTH_DEVICE_INFO.

Объявление:

Code: BLUETOOTH_DEVICE_INFO = record. DwSize : DWORD; Address : BLUETOOTH_ADDRESS; UlClassofDevice : ULONG; FConnected : BOOL; FRemembered : BOOL; FAuthenticated : BOOL; StLastSeen : SYSTEMTIME; StLastUsed : SYSTEMTIME; SzName : array [0..BLUETOOTH_MAX_NAME_SIZE - 1] of WideChar; End;

Члены:

DwSize. Входной параметр. Должен быть равен размеру структуры (dwSize := SizeOf(BLUETOOTH_DEVICE_INFO)). Address. Адрес устройства Bluetooth. UlClassofDevice. Класс устройства. Подробнее по классам смотрите в JwaBluetoothAPIs. Константы с префиксом COD_xxx. FConnected. Если TRUE, то устройство подключено/используется FRemembered. Если TRUE, то устройство ранее уже было найдено (запомнено). FAuthenticated. Если TRUE, то устройство прошло авторизацию (авторизированно). StLastSeen. Дата и время последнего обнаружения устройства StLastUsed. Дата и время последнего использования устройства SzName. Название устройства (имя).

BLUETOOTH_RADIO_INFO.

Объявление:

Code: BLUETOOTH_RADIO_INFO = record. DwSize : DWORD; Address : BLUETOOTH_ADDRESS; SzName : array [0..BLUETOOTH_MAX_NAME_SIZE - 1] of WideChar; UlClassofDevice : ULONG; LmpSubversion : Word; Manufacturer : Word; End;

Члены:

DwSize. Должен быть равен размеру структуры (dwSize := SizeOf(BLUETOOTH_RADIO_INFO)). Address. Адрес радиомодуля Bluetooth. SzName. Имя радиомодуля UlClassofDevice. Класс устройства (см. выше). LmpSubversion. Зависит от производителя Manufacturer. Код производителя. Определяется константами BTH_MFG_Xxx. Более полную информацию о производителях можно получить на сайте поддержки Bluetooth.

Далее напишем вот такой обработчик события OnChange для TreeView:

Code: Procedure TfmMain.TreeViewChange(Sender: TObject; Node: TTreeNode); Var. ASelected: TTreeNode; Procedure ShowRadios; Var. Info: PBLUETOOTH_RADIO_INFO; CurNode: TTreeNode; Begin. // Строим столбцы. With ListView.Columns do. Begin. BeginUpdate; With Add do Caption := 'Address'; With Add do Caption := 'Name'; With Add do Caption := 'Class Of Device'; With Add do Caption := 'Manufacturer'; With Add do Caption := 'Subversion'; With Add do Caption := 'Connectable'; With Add do Caption := 'Discoverable'; EndUpdate; End; // Заполняем список. With ListView.Items do. Begin. BeginUpdate; CurNode := ASelected.GetFirstChild; While Assigned(CurNode) do begin. Info := PBLUETOOTH_RADIO_INFO(CurNode.Data); // Перечитать информацию о радиомодуле. BluetoothGetRadioInfo(CurNode.ImageIndex, Info^); With Add do. Begin. Data := Pointer(CurNode.ImageIndex); Caption := BTAdrToStr(Info.address); With SubItems do. Begin. Add(string(Info.szName)); Add(IntToStr(Info.ulClassofDevice)); Add(IntToStr(Info.manufacturer)); Add(IntToStr(Info.lmpSubversion)); // NEW FUNCTIONS!!! Add(BoolToStr(BluetoothIsConnectable(CurNode.ImageIndex), True)); Add(BoolToStr(BluetoothIsDiscoverable(CurNode.ImageIndex), True)); End; End; CurNode := ASelected.GetNextChild(CurNode); End; EndUpdate; End; End; Procedure ShowDevices; Var. Info: ^PBLUETOOTH_DEVICE_INFO; CurNode: TTreeNode; Begin. // Строим столбцы. With ListView.Columns do. Begin. BeginUpdate; With Add do Caption := 'Address'; With Add do Caption := 'Name'; With Add do Caption := 'Class Of Device'; With Add do Caption := 'Connected'; With Add do Caption := 'Remembered'; With Add do Caption := 'Authenticated'; With Add do Caption := 'Last Seen'; With Add do Caption := 'Last Used'; EndUpdate; End; // Заполняем список. With ListView.Items do. Begin. BeginUpdate; CurNode := ASelected.GetFirstChild; While Assigned(CurNode) do. Begin. Info := CurNode.Data; // Перечитываем информацию об устройстве. // Так как передаем указатель, то она автоматом. // Обновится и в том месте, где мы ее сохраняли. BluetoothGetDeviceInfo(ASelected.ImageIndex, Info^); With Add do. Begin. Data := Info; Caption := BTAdrToStr(Info^.Address); With SubItems do. Begin. Add(string(Info^.szName)); Add(IntToStr(Info^.ulClassofDevice)); Add(BoolToStr(Info^.fConnected, True)); Add(BoolToStr(Info^.fRemembered, True)); Add(BoolToStr(Info^.fAuthenticated, True)); Try // stLastSeen может быть 0 и тогда здесь ошибка будет. Add(DateTimeToStr(SystemTimeToDateTime(Info^.stLastSeen))); Except. Add(‘’); End; Try // stLastUsed может быть 0 и тогда здесь ошибка будет. Add(DateTimeToStr(SystemTimeToDateTime(Info^.stLastUsed))); Except. Add(‘’); End; End; End; CurNode := ASelected.GetNextChild(CurNode); End; EndUpdate; End; End; Procedure ShowServices; Var. Info: __PBLUETOOTH_DEVICE_INFO; ServiceCount: dword; Services: array of TGUID; HRadio: THandle; Loop: integer; Begin. // Строим столбцы. With ListView.Columns do. Begin. BeginUpdate; With Add do Caption := 'GUID'; EndUpdate; End; // Заполняем список. With ListView.Items do. Begin. BeginUpdate; // Получаем размер массива сервисов. ServiceCount := 0; Services := nil; HRadio := ASelected.Parent.ImageIndex; Info := ASelected.Data; // NEW FUNCTION. BluetoothEnumerateInstalledServices(hRadio, Info, ServiceCount, nil); // Выделяем память. SetLength(Services, ServiceCount); // Получаем список сервисов. BluetoothEnumerateInstalledServices(hRadio, Info, ServiceCount, PGUID(Services)); // Рисуем их. For Loop := 0 to ServiceCount - 1 do. With Add do. Caption := GUIDToString(Services[Loop]); // Очищаем память. Services := nil; EndUpdate; End; End; Begin. ASelected := TreeView.Selected; // Очищаем ListView. With ListView do. Begin. With Columns do. Begin. BeginUpdate; Clear; EndUpdate; End; With Items do. Begin. BeginUpdate; Clear; EndUpdate; End; End; // Заполняем информацией. If Assigned(ASelected) then. Case ASelected.ImageIndex of. -2: ShowServices; -1: ShowRadios; Else. If ASelected.ImageIndex > 0 then ShowDevices; End; End;

В этом коде появилось три новые функции, которые выделены жирным шрифтом. Вот они

BluetoothIsConnectable - определяет, возможно ли подключение к указанному радиомодулю.

Объявление функции:

Code: Function BluetoothIsConnectable(const hRadio : THandle): BOOL; stdcall;

Параметры:

HRadio. Handle радиомодуля, который мы проверяем. Если 0, то проверяются все радиомодули.

Возвращаемые значения:

· Вернет TRUE, если указанный радиомодуль разрешает входящие подключения. Если hRadio=0, то вернет TRUE, если хотя бы один радиомодуль разрешает входящие подключения.

· Если входящие подключения запрещены, то вернет FALSE.

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

Объявление функции:

Code: Function BluetoothIsDiscoverable(const hRadio : THandle): BOOL; stdcall;

Параметры:

HRadio. Handle радиомодуля, который мы проверяем. Если 0, то проверяются все радиомодули.

Возвращаемые значения:

· Вернет TRUE, если указанный радиомодуль разрешает обнаружение. Если hRadio=0, то вернет TRUE, если хотя бы один радиомодуль разрешает обнаружение.

· Если обнаружение запрещено, то вернет FALSE.

BluetoothEnumerateInstalledServices - получает список GUID сервисов, предоставляемых устройством. Если параметр hRadio=0, то просматривает все радиомодули.

Объявление функции:

Code: Function BluetoothEnumerateInstalledServices( HRadio : THandle; Pbtdi : __PBLUETOOTH_DEVICE_INFO; Var pcServices : dword; PGuidServices : PGUID): dword; stdcall;

Параметры:

HRadio. Handle радиомодуля, который мы проверяем. Если 0, то проверяются все радиомодули. Pbtdi. Указатель на структуру BLUETOOTH_DEVICE_INFO, в которой описано проверяемое устройство. Необходимо заполнить поля dwSize и Address. PcServices. При вызове – количество записей в массиве pGuidServices, возвращает в этом параметре реальное количество сервисов, предоставляемых устройством. PGuidServices. Указатель на массив TGUID, в который будут записаны GUID предоставляемых устройством сервисом. Если nil и pcServices=0, то в pcServices будет записано количество сервисов. Необходимо выделить для pGuidServices память размером не менее pcServices*SizeOf(TGUID).

Возвращаемые значения:

· Вернет ERROR_SUCCESS, если вызов успешен и количество сервисов в pcServices соответствует реальности.

· Вернет ERROR_MORE_DATA, если вызов успешен, но выделенное количество памяти (pcServices при вызове) меньше, чем количество предоставляемых сервисов.

· В случае ошибки – другие коды ошибок Win32.

Примечания:

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

Code: // Получаем размер массива сервисов. ServiceCount := 0; Services := nil; HRadio := ASelected.Parent.ImageIndex; Info := ASelected.Data; // NEW FUNCTION. BluetoothEnumerateInstalledServices(hRadio, Info, ServiceCount, nil); // Выделяем память. SetLength(Services, ServiceCount); // Получаем список сервисов. BluetoothEnumerateInstalledServices(hRadio, Info, ServiceCount, PGUID(Services)).

Сначала мы вызываем функцию с pcServices=0 и pGuidServices=nil для того, чтобы получить количество сервисов, предоставляемых устройством.

Потом выделяем память (SetLength()) и только затем вызываем функцию с реальными параметрами и получаем список сервисов.

Еще важное замечание. В файле JwaBluetoothAPIs.pas параметр pbtdi имеет тип PBLUETOOTH_DEVICE_INFO, который раскрывается в BLUETOOTH_DEVICE_INFO. Заметьте, что это НЕ УКАЗАТЕЛЬ. Это не верно, так как в исходном виде функция требует именно указатель. По-этому, я ввел тип

Type __PBLUETOOTH_DEVICE_INFO = ^PBLUETOOTH_DEVICE_INFO.

Так что ИСПОЛЬЗУЙТЕ файл из примера, а не из исходной библиотеки. Иначе получите нарушение доступа к памяти.

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

В принципе то, что описано выше, мы уже знали, кроме двух указанных функций.

Давайте расширим возможности нашего приложения. Добавим функции запрета/разрешения обнаружения радиомодуля и запрета/разрешения подключения к нему.

BluetoothEnableIncomingConnections и BluetoothEnableDiscoverable.

Поместим на форму компонент TactionList и изменим его свойства как показано в таблице.

Свойство Значение Name. ActionList.

Теперь два раза щелкнем по ActionList и в появившемся окне редактора свойств добавим две TAction со следующими свойствами:

Свойство Значение Caption. Connectable. Name. AcConnectable.

Свойство Значение Caption. Discoverable. Name. AcDiscoverable.

На панель Panel добавим две TButton и установим свойства:

Свойство Значение Action. AcConnectable. Name. BtConnectable.

Свойство Значение Action. AcDiscoverable. Name. BtDiscoverable.

Напишем вот такой обработчик события OnUpdate у acConnectable:

Code: Procedure TfmMain.acConnectableUpdate(Sender: TObject); Var. SelectedItem: TListItem; SelectedNode: TTreeNode; Begin. SelectedNode := TreeView.Selected; SelectedItem := ListView.Selected; With TAction(Sender) do. Begin. Enabled := Assigned(SelectedNode) and Assigned(SelectedItem) and (SelectedNode.ImageIndex = -1); If Enabled then. If StrToBool(SelectedItem.SubItems[4]). Then Caption := 'Not conn.' Else Caption := 'Connectable'; End; End;

И то же самое напишем для обработчика события OnUpdate - acDiscoverable:

Code: Procedure TfmMain.acDiscoverableUpdate(Sender: TObject); Var. SelectedItem: TListItem; SelectedNode: TTreeNode; Begin. SelectedNode := TreeView.Selected; SelectedItem := ListView.Selected; With TAction(Sender) do. Begin. Enabled := Assigned(SelectedNode) and Assigned(SelectedItem) and (SelectedNode.ImageIndex = -1); If Enabled then. If StrToBool(SelectedItem.SubItems[5]). Then Caption := 'Not disc.' Else Caption := 'Discoverable'; End; End;

Теперь обработчик события OnExecute для acConnectable:

Code: Procedure TfmMain.acConnectableExecute(Sender: TObject); Var. SelectedItem: TListItem; Begin. SelectedItem := ListView.Selected; If Assigned(SelectedItem) then. If not BluetoothEnableIncomingConnections(Integer(SelectedItem.Data), TAction(Sender).Caption = 'Not conn.'). Then MessageDlg('Unable to change Radio state', mtError, [mbOK], 0). Else TreeViewChange(TreeView, TreeView.Selected); End;

Такой же обработчик напишем и для OnExecute - acDiscoverable:

Code: Procedure TfmMain.acConnectableExecute(Sender: TObject); Var. SelectedItem: TListItem; Begin. SelectedItem := ListView.Selected; If Assigned(SelectedItem) then. If not BluetoothEnableDiscovery(Integer(SelectedItem.Data), TAction(Sender).Caption = 'Not disc.'). Then MessageDlg('Unable to change Radio state', mtError, [mbOK], 0). Else TreeViewChange(TreeView, TreeView.Selected); End;

Вывод окна свойств устройства

Важно: Если Windows сам использует радиомодуль, то он не даст поменять статус, хотя и функция выполнится без ошибок!

Здесь мы ввели две новые функции (выделены жирным):

BluetoothEnableInfomingConnection - функция разрешает/запрещает подключения к локальному радиомодулю Bluetooth.

Объявление функции:

Code: Function BluetoothEnableIncomingConnections( HRadio : THandle; FEnabled : BOOL): BOOL; stdcall;

Параметры:

HRadio. Handle радиомодуля, статус которого мы хотим изменить. Если 0, то меняем у всех. FEnabled. TRUE – разрешаем подключения; FALSE – запрещаем.

Возвращаемые значения:

· TRUE - если вызов успешен и статус изменен,

· FALSE - в противном случае.

BluetoothEnableDiscovery - функция разрешает/запрещает обнаружение локального радиомодуля Bluetooth.

Объявление функции:

Code: Function BluetoothEnableDiscovery(hRadio : THandle; fEnabled : BOOL): BOOL; stdcall;

Параметры:

HRadio. Handle радиомодуля, статус которого мы хотим изменить. Если 0, то меняем у всех. FEnabled. TRUE – разрешаем обнаружение; FALSE – запрещаем.

Возвращаемые значения:

· TRUE - если вызов успешен и статус изменен,

· FALSE - в противном случае.

Теперь давайте научимся выводить системное окно свойств устройства Bluetooth. Для этого добавим к ActionList еще один TAction вот с такими свойствами:

Свойство Значение Caption. Property. Name. AcProperty.

Добавим на Panel кнопку TButton с такими свойствами:

Свойство Значение Action. AcProperty. Name. BtProperty.

Теперь напишем такой обработчик событий OnUpdate у acProperty:

Code: Procedure TfmMain.acPropertyUpdate(Sender: TObject); Var. SelectedNode: TTreeNode; SelectedItem: TListItem; Begin. SelectedNode := TreeView.Selected; SelectedItem := ListView.Selected; TAction(Sender).Enabled := Assigned(SelectedNode) and. Assigned(SelectedItem) and. (SelectedNode.ImageIndex > 0); End;

И обработчик OnExecute для нее же:

Code: Procedure TfmMain.acPropertyExecute(Sender: TObject); Var. Info: BLUETOOTH_DEVICE_INFO; Begin. Info := BLUETOOTH_DEVICE_INFO(ListView.Selected.Data^); BluetoothDisplayDeviceProperties(Handle, Info); End;

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

Важно: Ни в этой процедуре, ни ранее, ни далее я не провожу проверку ошибок, чтобы не загромождать код лишними подробностями. В реальном приложении НЕОБХОДИМО проверять возвращаемые функциями значения и указатели.

И так, в этом коде есть новая функция, выделенная жирным шрифтом.

BluetoothDisplayDeviceProperty - функция выводит стандартное окно свойств устройства Bluetooth.

Объявление функции:

Function BluetoothEnableDiscovery( hwndParent : HWND; var pbtdi : PBLUETOOTH_DEVICE_INFO): BOOL; stdcall;

Важно: В оригинале (см. примечание выше) функция выглядит вот так:

Function BluetoothEnableDiscovery( hwndParent : HWND; pbtdi : PBLUETOOTH_DEVICE_INFO): BOOL; stdcall;

Это не верно, так как в документации Microsoft указано, что параметр pbtdi должен передаваться как указатель (что подразумевает запись PBLUETOOTH_DEVICE_INFO), но как я писал выше, этот тип ошибочен. Он не является указателем. Я изменил функцию так, как показано выше (так она и должна быть, если не менять определение типа). Параметры:

HwndParent. Handle родительского окна, которому будет принадлежать диалог свойств. Может быть 0, тогда родительским выбирается окно Desktop. Pbtdi. Указатель на структуру BLUETOOTH_DEVICE_INFO в которой содержится адрес требуемого устройства.

Возвращаемые значения:

· TRUE - если вызов успешен

· FALSE - в противном случае (код ошибки можно узнать вызовом функции GetLastError).

Выбор устройства

Рассмотрим, как вызвать окно диалога выбора устройства.

Добавим в наш проект на Panel еще одну кнопку TButton и установите ее свойства как в таблице:

Свойство Значение Caption. Select. Name. BtSelect.

Напишем вот такой обработчик события OnClick у этой кнопки:

Code: Procedure TfmMain.btSelectClick(Sender: TObject); Var. ASelParams: BLUETOOTH_SELECT_DEVICE_PARAMS; ASelParamsSize: dword; Begin. ASelParamsSize := SizeOf(BLUETOOTH_SELECT_DEVICE_PARAMS); FillChar(ASelParams, ASelParamsSize, 0); With ASelParams do. Begin. DwSize := ASelParamsSize; HwndParent := Handle; FShowRemembered := True; FAddNewDeviceWizard := True; End; BluetoothSelectDevices(@ASelParams); BluetoothSelectDevicesFree(@ASelParams); End.

В этой части кода две новые функции.

BluetoothSelectDevices - функция разрешает/запрещает обнаружение локального радиомодуля Bluetooth.

Объявление функции:

Function BluetoothSelectDevices( pbtsdp : PBLUETOOTH_SELECT_DEVICE_PARAMS): BOOL; stdcall;

Параметры:

Pbtsdp. Описание смотрите ниже в описании структуры.

Возвращаемые значения:

Если функция вернула TRUE, то пользователь выбрал устройства. Pbtsdp^.pDevices будет указывать на корректные данные. После вызова необходимо проверить флаги fAuthenticated и fRemembered, что бы удостовериться в корректности данных. Для освобождения памяти используйте функцию BluetoothSelectDevicesFree, только если функция вернет TRUE.

Вернет FALSE если вызов прошел не удачно. Используйте GetLastError для получения дополнительных сведений. Возможные ошибки:

ERROR_CANCELLED. Пользователь отменил выбор устройства. ERROR_INVALID_PARAMETER. Параметр pbsdp равен nil. ERROR_REVISION_MISMATCH. Структура, переданная в pbsdp неизвестного или неверного размера. Другие ошибки Win32.

BLUETOOTH_SELECT_DEVICE_PARAMS.

Объявление:

Code: BLUETOOTH_SELECT_DEVICE_PARAMS = record. DwSize : DWORD; CNumOfClasses : ULONG; PrgClassOfDevices : PBlueToothCodPairs; PszInfo : LPWSTR; HwndParent : HWND; FForceAuthentication : BOOL; FShowAuthenticated : BOOL; FShowRemembered : BOOL; FShowUnknown : BOOL; FAddNewDeviceWizard : BOOL; FSkipServicesPage : BOOL; PfnDeviceCallback : PFN_DEVICE_CALLBACK; PvParam : Pointer; CNumDevices : DWORD; PDevices : __PBLUETOOTH_DEVICE_INFO; End;

Члены:

DwSize. Должен быть равен размеру структуры (dwSize := SizeOf(BLUETOOTH_RADIO_INFO)). CNumOfClasses. Входной параметр. Количество записей в массиве prgClassOfDevice. Если 0, то ищутся все устройства. PrgClassOfDevices. Входной параметр. Массив COD (классов устройств), которые необходимо искать. PszInfo. Входной параметр. Если не nil, то задает текст заголовка окна выбора устройства. HwndParent. Входной параметр. Handle родительского окна для диалога выбора устройства. Если 0, то родителем будет Desktop. FForceAuthentication. Входной параметр. Если TRUE, то требует принудительной авторизации устройств. FShowAuthenticated. Входной параметр. Если TRUE, то авторизованные устройства будут доступны для выбора. FShowRemembered. Входной параметр. Если TRUE, то запомненные устройства будут доступны для выбора. FShowUnknown. Входной параметр. Если TRUE, то неизвестные (неавторизованные и не запомненные) устройства будут доступны для выбора. FAddNewDeviceWizard. Входной параметр. Если TRUE, то запускает мастер добавления нового устройства. FSkipServicesPage. Входной параметр. Если TRUE, то пропускает страницу Сервисы в мастере. PfnDeviceCallback. Входной параметр. Если не nil, то является указателем на функцию обратного вызова, которая вызывается для каждого найденного устройства. Если функция вернет TRUE, то устройства добавляется в список, если нет, то устройство игнорируется. PvParam. Входной параметр. Его значение будет передано функции pfnDeviceCallback в качестве параметра pvParam. CNumDevices. Как входной параметр – количество устройств, которое требуется вернуть. Если 0, то нет ограничений. Как выходной параметр – количество возвращенных устройств (выбранных). PDevices. Выходной параметр. Указатель на массив структур BLUETOOTH_DEVICE_INFO. Для его освобождения используйте функцию BluetoothSelectDevicesFree. Важно: В оригинале этот параметр объявлен как PBLUETOOTH_DEVICE_INFO. По этому поводу здесь много комментариев.

BluetoothSelectDevicesFree - функция должна вызываться, только если вызов BluetoothSelectDevices был успешен. Эта функция освобождает память и ресурсы, задействованные функцией BluetoothSelectDevices в структуре BLUETOOTH_SELECT_DEVICE_PARAMS.

Объявление функции:

Function BluetoothSelectDevices( pbtsdp : PBLUETOOTH_SELECT_DEVICE_PARAMS): BOOL; stdcall;

Параметры:

Pbtsdp. Описание смотрите выше в описании структуры.

Возвращаемые значения:

· TRUE - если вызов успешен,

· FALSE - нечего освобождать.

Управление сервисами

Для управления сервисами Microsoft Bluetooth API предоставляет функцию:

BluetoothSetServiceState - включает или выключает указанный сервис для устройства Bluetooth. Система проецирует сервис Bluetooth на соответствующий драйвер. При отключении сервиса – драйвер удаляется. При его включении – драйвер устанавливается. Если выполняется включение не поддерживаемого сервиса, то драйвер не будет установлен.

Объявление функции:

Code: Function BluetoothSetServiceState( HRadio : Thandle; Var pbtdi : PBLUETOOTH_DEVICE_INFO; Const pGuidService : TGUID; DwServiceFlags : DWORD): DWORD; stdcall;

Параметры:

HRadio. Описатель радиомодуля. Pbtdi. Указатель на структуру BLUETOOTH_DEVICE_INFO. PGuidService. GUID сервиса, который необходимо включить/выключить. DwServiceFlags. Флаги управления сервисом: BLUETOOTH_SERVICE_DISABLE – отключает сервис; BLUETOOTH_SERVICE_ENABLE – включает сервис.

Возвращает ERROR_SUCCESS если вызов прошел успешно. Если вызов не удался вернет один из следующих кодов:

ERROR_INVALID_PARAMETER. Неверные флаги в dwServiceFlags. ERROR_SERVICE_DOES_NOT_EXIST. Указанный сервис не поддерживается Другие ошибки Win32.

Важно: В оригинале (см. примечание выше) функция выглядит вот так:

Function BluetoothSetServiceState( hRadio : Thandle; pbtdi : PBLUETOOTH_DEVICE_INFO; const pGuidService : TGUID; dwServiceFlags : DWORD): DWORD; stdcall;

Как использовать функцию? Давайте добавим к ActionList еще одну TAction с такими свойствами:

Свойство Значение Caption. Disable. Name. AcEnable.

И добавим на Panel еще одну кнопку TButton, установив у нее следующие свойства:

Свойство Значение Action. AcEnable. Name. BtEnable.

В обработчике события OnUpdate для acEnable напишем вот такой код:

Code: Procedure TfmMain.acEnableUpdate(Sender: TObject); Var. SelectedNode: TTreeNode; SelectedItem: TListItem; Begin. SelectedNode := TreeView.Selected; SelectedItem := ListView.Selected; TAction(Sender).Enabled := Assigned(SelectedNode) and. Assigned(SelectedItem) and. (SelectedNode.ImageIndex = -2); End;

А в обработчике OnExecute для acEnable вот такой код:

Code: Procedure TfmMain.acEnableExecute(Sender: TObject); Var. GUID: TGUID; Begin. GUID := StringToGUID(ListView.Selected.Caption); BluetoothSetServiceState(TreeView.Selected.Parent.ImageIndex, BLUETOOTH_DEVICE_INFO(TreeView.Selected.Data^), GUID, BLUETOOTH_SERVICE_DISABLE); End;

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

Как определять отключенные сервисы рассмотрим в серии про передачу данных через Bluetooth.

Удаление устройств

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

BluetoothRemoveDevice - функция удаляет авторизацию между компьютером и устройством Bluetooth. Так же очищает кэш-записи об этом устройстве.

Объявление функции:

Code: Function BluetoothRemoveDevice( Var pAddress : BLUETOOTH_ADDRESS): DWORD; stdcall;

Параметры:

HAddress. Адрес устройства, которое удаляется.

Возвращаемые значения:

ERROR_SUCCESS. устройство удалено ERROR_NOT_FOUND. устройство не найдено

Давайте попробуем. Добавим в ActionList TAction со следующими свойствами:

Свойство Значение Caption. Remove. Name. AcRemove.

И на Panel кнопку TButton со свойствами:

Свойство Значение Action. AcRemove. Name. BtRemove.

В обработчике OnUpdate для acRemove напишем следующий код:

Code: Procedure TfmMain.acRemoveUpdate(Sender: TObject); Begin. TAction(Sender).Enabled := acProperty.Enabled; End;

А для события OnExecute вот такой код:

Code: Procedure TfmMain.acRemoveExecute(Sender: TObject); Var. Info: BLUETOOTH_DEVICE_INFO; Res: dword; Begin. Info := BLUETOOTH_DEVICE_INFO(ListView.Selected.Data^); Res := BluetoothRemoveDevice(Info.Address); If Res <> ERROR_SUCCESS then. MessageDlg('Device not found', mtError, [mbOK], 0); TreeViewChange(TreeView, TreeView.Selected); End;

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

Важно: Устройство удаляется из списка. Однако, если уже иметь адрес устройства, то можно получить о нем информацию.

Есть еще одно функция, которая связана с BluetoothRemoveDevice. Это:

BluetoothUpdateDeviceRecord - функция обновляет данные об устройстве в кэше.

Объявление функции:

Code: Function BluetoothUpdateDeviceRecord( Var pbtdi : BLUETOOTH_DEVICE_INFO): DWORD; stdcall;

Параметры:

Pbtdu. Указатель на структуру BLUETOOTH_DEVICE_INFO. В ней должны быть заполнены поля: dwSize – размер структуры; Address – адрес устройства; szName – новое имя устройства.

Возвращаемые значения:

ERROR_SUCCESS. Функция выполнена успешно ERROR_INVALID_PARAMETER. Указатель pbtdi=nil. (Для варианта в Delphi не реально, так как указатель мы получаем из структуры, передавая ее как var-параметр). ERROR_REVISION_MISMATCH. Размер структуры в dwSize не правильный Другие ошибки Win32.

Попробуем использовать и ее. Схема стандартная: TAction к ActionList, TButton на Panel:

Свойство Значение Caption. Update. Name. AcUpdate.

Свойство Значение Action. AcUpdate. Name. BtUpdate.

Код:

Code: Procedure TfmMain.acUpdateUpdate(Sender: TObject); Begin. TAction(Sender).Enabled := acProperty.Enabled; End; Procedure TfmMain.acUpdateExecute(Sender: TObject); Var. Info: BLUETOOTH_DEVICE_INFO; Res: dword; NewName: string; Begin. If InputQuery('Имя устройства', 'Новое имя', NewName) then begin. LstrcpyW(Info.szName, PWideChar(WideString(NewName))); Res := BluetoothUpdateDeviceRecord(Info); If Res <> ERROR_SUCCESS then RaiseLastOsError; TreeViewChange(TreeView, TreeView.Selected); End; End;

Как видите, все просто.

И так, удалять устройства мы умеем. Давайте теперь научимся добавлять их. Для этого Bluetooth API предоставляет две функции:

BluetoothAuthenticateDevice - отправляет запрос на авторизацию удаленному устройству Bluetooth. Есть два режима авторизации: "Wizrd mode" и "Blind Mode".

"Wizard Mode" запускается, когда параметр pszPasskey = nil. В этом случае открывается окно "Мастера подключения". У пользователя будет запрошен пароль, который будет отправлен в запросе на авторизацию удаленному устройству. Пользователь будет оповещен системой об успешном или не успешном выполнении авторизации и получит возможность попытаться авторизировать устройства еще раз.

"Blind Mode" вызывается, когда pszPasskey <> nil. В этом случае пользователь не увидит никакого мастера. Вам необходимо программно запросить код авторизации (pszPasskey) и уведомить пользователя о результате.

Объявление функции:

Code: Function BluetoothAuthenticateDevice( HwndParent : HWND; HRadio : THandle; Pbtdi : BLUETOOTH_DEVICE_INFO; PszPasskey : PWideChar; UlPasskeyLength : ULONG): DWORD; stdcall;

Параметры:

HwndParent. Handle родительского окна. Если 0, то родительским окном станет окно Desktop. HRadio. Handle локального радиомодуля. Если 0, то авторизация будет проведена на всех радиомодулях. Если хотя бы один пройдет авторизацию, функция выполнится успешно. Pbdti. Информация об устройстве, на котором необходимо авторизироваться. PszPasskey. PIN для авторизации. Если nil, то вызывается мастер авторизации (описано выше). Важно: pszPasskey не NULL-терминированная строка! UlPasskeyLength. Длина строки в байтах. Должна быть меньше либо равна BLUETOOTH_MAX_PASSKEY_SIZE * SizeOf(WCHAR).

Возвращаемые значения:

ERROR_SUCCESS. Функция выполнена успешно ERROR_CANCELLED. Пользователь отменил процесс авторизации ERROR_INVALID_PARAMETER. Структура pbtdi не верна ERROR_NO_MORE_ITEMS. Устройство в pbtdi уже авторизированно Другие ошибки Win32.

Для "Blind Mode" соответствие кодов ошибок Bluetooth кодам ошибок Win32 приведено в таблице:

Bluetooth. Win32. BTH_ERROR_SUCCESS. ERROR_SUCCESS. BTH_ERROR_NO_CONNECTION. ERROR_DEVICE_NOT_CONNECTED. BTH_ERROR_PAGE_TIMEOUT. WAIT_TIMEOUT. BTH_ERROR_HARDWARE_FAILURE. ERROR_GEN_FAILURE. BTH_ERROR_AUTHENTICATION_FAILURE. ERROR_NOT_AUTHENTICATED. BTH_ERROR_MEMORY_FULL. ERROR_NOT_ENOUGH_MEMORY. BTH_ERROR_CONNECTION_TIMEOUT. WAIT_TIMEOUT. BTH_ERROR_LMP_RESPONSE_TIMEOUT. WAIT_TIMEOUT. BTH_ERROR_MAX_NUMBER_OF_CONNECTIONS. ERROR_REQ_NOT_ACCEP. BTH_ERROR_PAIRING_NOT_ALLOWED. ERROR_ACCESS_DENIED. BTH_ERROR_UNSPECIFIED_ERROR. ERROR_NOT_READY. BTH_ERROR_LOCAL_HOST_TERMINATED_CONNECTION. ERROR_VC_DISCONNECTED.

Аналогичная функция:

BluetoothAuthenticateMultipleDevices - позволяет авторизироваться сразу на нескольких устройствах при помощи одной копии "Мастера авторизации".

Объявление функции:

Code: Function BluetoothAuthenticateMultipleDevices( HwndParent : HWND; HRadio : THandle; CDevices : DWORD; Rgpbtdi : __PBLUETOOTH_DEVICE_INFO): DWORD; stdcall;

Параметры:

HwndParent. Handle родительского окна. Если 0, то родительским окном станет окно Desktop. HRadio. Handle локального радиомодуля. Если 0, то авторизация будет проведена на всех радиомодулях. Если хотя бы один пройдет авторизацию, функция выполнится успешно. CDevices. Количество элементов в массиве rgpbtdi. Rgpbtdi. Массив структур BLUETOOTH_DEVICE_INFO, в котором представлены устройства для авторизации.

Возвращаемые значения:

ERROR_SUCCESS. Функция выполнена успешно. Проверьте флаг fAuthenticated у каждого устройства, что бы знать, какие прошли авторизацию. ERROR_CANCELLED. Пользователь отменил процесс авторизации. Проверьте флаг fAuthenticated у каждого устройства, что бы знать, какие прошли авторизацию. ERROR_INVALID_PARAMETER. Один или несколько элементов массива rgpbtdi не верны. ERROR_NO_MORE_ITEMS. Все устройства в массиве уже авторизированны. Другие ошибки Win32.

Важно: В оригинале функция выглядит вот так:

Code: Function BluetoothAuthenticateMultipleDevices( HwndParent : HWND; HRadio : THandle; CDevices : DWORD; Pbtdi : PBLUETOOTH_DEVICE_INFO): DWORD; stdcall;

Это не верно, так как в документации Microsoft указано, что параметр rgpbtdi должен передаваться как указатель (что подразумевает запись PBLUETOOTH_DEVICE_INFO), но как я писал выше, этот тип ошибочен. Он не является указателем. Я изменил функцию так, как показано выше. По поводу типа __PBLUETOOTH_DEVICE_INFO я писал выше.

Описывать с примером, как использовать эти функции не буду, так как они тривиальны (если вы прочитали все вышеизложенное). Остались последние три функции, которые мы не рассмотрели:

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

Объявление функции:

Code: Function BluetoothRegisterForAuthentication( Var pbtdi : PBLUETOOTH_DEVICE_INFO; Var phRegHandle : HBLUETOOTH_AUTHENTICATION_REGISTRATION; PfnCallback : PFN_AUTHENTICATION_CALLBACK; PvParam : Pointer): DWORD; stdcall;

Параметры:

Pbtdi. Указатель на BLUETOOTH_DEVICE_INFO. Используется адрес устройства, для которого регистрируется функция. Обратите внимание на параметр. В оригинале он опять передается не как указатель. PhRegHandle. Указатель, куда будет возвращен Handle регистрации, которой потом используется в BluetoothUnregisterAuthentication. PfnCallback. Функция обратного вызова. PvParam. Опциональный параметр, который без изменения передается в функцию обратного вызова.

Возвращаемые значения:

ERROR_SUCCESS. Функция выполнена успешно. ERROR_OUTOFMEMORY. Недостаточно памяти. Другие ошибки Win32.

BluetoothUnregisterAuthentication - удаляет функцию обратного вызова, зарегистрированную функцией BluetoothRegisterForAuthentication и закрывает Handle.

Объявление функции:

Code: Function BluetoothUnregisterAuthentication( HRegHandle : HBLUETOOTH_AUTHENTICATION_REGISTRATION): BOOL; stdcall;

Параметры:

HRegHandle. Handle регистрации, полученный функцией BluetoothRegisterForAuthentication.

Возвращаемые значения:

Вернет TRUE, если вызов успешен и FALSE в случае неудачи. Используйте GetLastError для получения дополнительной информации.

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

Объявление функции:

Code: Function BluetoothSendAuthenticationResponse( HRadio : THandle; Pbtdi : PBLUETOOTH_DEVICE_INFO; PszPasskey : LPWSTR): DWORD; stdcall;

Параметры:

HRadio. Handle радиомодуля, для которого проводим авторизацию. Если 0, то пытаемся на всех. Pbtdi. Указатель на BLUETOOTH_DEVICE_INFO с данными об устройстве, от которого поступил запрос на авторизацию. Может быть тот же указатель, который передан в функцию обратного вызова. PszPasskey. Указатель на UNICODE строку, в которой содержится ключ авторизации (PIN).

Возвращаемые значения:

ERROR_SUCCESS. Функция выполнена успешно. ERROR_CANCELLED. Устройство отвергло авторизационный код (PIN). Так же, возможно, имеются проблемы со связью E_FAIL. Устройство вернуло ошибку авторизации. Другие ошибки Win32.

И, наконец, функция обратного вызова:

PFN_AUTHENTICATION_CALLBACK.

Описание этой функции дано выше. Здесь приведу лишь определеннее.

Объявление функции:

Code: PFN_AUTHENTICATION_CALLBACK = Function(pvParam : Pointer; PDevice : PBLUETOOTH_DEVICE_INFO): BOOL; stdcall;

Параметры:

PvParam. Указатель на параметр, который мы передали в BluetoothRegisterForAuthentication. PDevice. Указатель на BLUETOOTH_DEVICE_INFO с данными об устройстве, от которого поступил запрос на авторизацию.

Заключение

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

Но актуальным остается вопрос, который мне многие задают. Как же все-таки передавать данные между устройствами Bluetooth?

Ответ на этот вопрос читайте в следующей серии статей "Передача данных через Bluetooth".

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

Полностью рабочий пример, рассмотренный в этой статье, вы можете скачать здесь (300K).

Я буду рад любым замечаниям и пожеланиям по данной теме.

P.S. Внимательно относитесь к сторонним библиотекам. Как видите, в JWALIB оказалось много ошибок, которые порой загоняют в тупик. Я минут 20 смотрел на Access Violation, пока не понял, в чем дело.

Работа с Bluetooth в Delphi.

Часть 4. Передача данных через Bluetooth.

Введение

Наконец, после долгого перерыва я добрался и до заключительной, как я надеюсь, части статьи про Bluetooth.

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

Как вы помните из предыдущих моих статей, мы используем исключительно Windows API для работы с Bluetooth. Сразу хочу оговориться, что описанные здесь способы не будут работать с драйверами BlueSoliel и VIDCOMM. В конце статьи я расскажу, как установить драйвера от Microsoft, если вы это еще не сделали.

И так, приступаем.

Что вы должны знать

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

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

Вы также должны более или менее разбираться в технологии Winsock.

Bluetooth и Winsock.

Как не странно это звучит, но Microsoft решила реализовать всю функциональность по передаче данных посредством Windows Socket Model. Тем, кто писал что-либо для IrDA это должно показаться знакомым.

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

Я не буду описывать здесь все правила применения функций WinSock к работе с Bluetooth. Остановлюсь лишь на практической стороне вопроса. А именно - передача данных.

В статье мы сделаем простенький Bluetooth-клиент, который будет подсоединяться к удаленному устройству как к модему и позволит вам выполнять AT-команды. Весьма полезная вещь. Учтите, что данный клиент будет требовать авторизации устройств и не будет требовать наличия в системе каких-либо виртуальных COM-портов.

Сервисы и профили

Сервисы и профили... Это два краеугольных понятия Bluetooth. В некотором смысле – они идентичны.

Сервис – приложение-сервер, которое регистрирует определенным образом параметры в стеке протоколов Bluetooth. Наименование (GUID) всех сервисов строго определены Bluetooth.org.

Профиль – соглашения и стандарты работы сервиса. Понятнее объяснить не смогу.

Начало

И так, прежде чем можно будет использовать библиотеку WinSock, ее необходимо инициализировать. Делается это вызовом функции WSAStartup. Вот как она выглядит:

Code: Function WSAStartup(wVersionRequired: Word; var lpWSAData: WSAData): Integer; stdcall;

Не буду описывать все параметры, так как они есть в любой справочной системе (MSDN, Delphi). Скажу только, что для использования WinSock с Bluetooth необходимо указаь в качестве параметра wVersionRequired номер версии $0202.

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

Code: Var. Data: WSADATA; Begin. If WSAStartUp($0202, Data) <> 0 then. Raise Exception.Create('Winsock Initialization Failed.');

По окончанию работы с WinSock библиотеку необходимо освободить. Для этого существует функция WSACleanup.

Code: Function WSACleanup: Integer; stdcall;

Вызывается она просто, без всяких параметров. Возвращаемое значение, в принципе, можно не проверять:

WSACleanup;

Создание клиента

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

Code: Function socket(af, type_, protocol: Integer): TSocket; stdcall;

Вот как это делается:

Code: Var. ASocket: TSocket; Begin. ASocket := socket(AF_BTH, SOCK_STREAM, BTHPROTO_RFCOMM); If ASocket = INVALID_SOCKET then. RaiseLastOsError;

Функция вернет корректный описатель сокета, либо INVALID_SOCKET в случае ошибки. Запомните, что Bluetooth поддерживает только потоковые сокеты (SOCK_STREAM).

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

Code: Var. Addr: SOCKADDR_BTH; AddrSize: DWORD; Begin. AddrSize := SizeOf(SOCKADDR_BTH); FillChar(Addr, AddrSize, 0); With Addr do. Begin. AddressFamily := AF_BTH; BtAddr := ADeviceAddress; ServiceClassId := SerialPortServiceClass_UUID; Port := DWORD(BT_PORT_ANY); End;

Здесь в переменной ADeviceAddress должен быть адрес устройства (Int64), присоединяемся к любому порту (BT_PORT_ANY) сервиса SerialPortServiceClass.

Далее вызываем функцию connect, которая имеет вид:

Code: Function connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; stdcall;

Делается это вот так:

Code: If connect(ASocket, @Addr, AddrSize) <> 0 then RaiseLastOsError;

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

После того, как соединение установлено, можно передавать и принимать данные через сокет функциями send и recv.

Code: Function send(s: TSocket; var buf; len, flags: Integer): Integer; stdcall; Function recv(s: TSocket; var buf; len, flags: Integer): Integer; stdcall;

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

Ну и закрытие сокета осуществляется вызовом функции closesocket:

Code: Function closesocket(s: TSocket): Integer; stdcall;

Опять же, возвращаемое значение можно проигнорировать (если вы знаете, что делаете).

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

Создание сервера

Как и создание клиента, создание сервера ничем не отличается от создания сервера для любой службы WinSock.

И так, начнем. Сокет создается также как и в приведенном выше примере для клиента. Точно также заполняем структуру Addt: SOCKADDR_BTH. Только в качестве адреса устройства указываем 0. Далее, необходимо привязать сокет к адресу. Делается это функцией bind:

Code: Function bind(s: TSocket; name: PSockAddr; namelen: Integer): Integer; stdcall;

Которая вызывается следующим образом:

Code: If Bind(ASocket, @Addr, AddrSize) <> 0 then. RaiseLastOsError;

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

Code: Function listen(s: TSocket; backlog: Integer): Integer; stdcall; Function accept(s: TSocket; addr: PSockAddr; addrlen: PINT): TSocket; stdcall;

Делается это вот так:

Code: Var. AClientSocket: TSocket; Begin. If listen(ASocket, 10) <> 0 then. RaiseLastOSError; AClientSocket = accept(ASocket, nil, nil);

После подключения клиента можно работать с AClientSocket – передавать и принимать данные.

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

Что осталось за кадром

Как и обещал, я коротко описал процедуры, необходимые для построения простого клиента и сервера, которые будут работать с Bluetooth через WinSock. Однако, здесь я не рассматривал вопросы регистрации сервисов и протоколы верхнего уровня.

Приведенной здесь информации достаточно для того, что бы вы могли создать приложение "клиент", которое соединится с ваши телефоном по Bluetooth и сможет выполнять AT-команды.

Более полную информацию и рабочие примеры можно найти здесь: http://www.btframework.com. Там же приведено решение по установке драйверов от Microsoft.

Всегда буду рад ответить на ваши вопросы: mike@btframework.com.

©Drkb::01624.

Работа с КАЗАХСКИМИ ШРИФТАМИ.

Работа с КАЗАХСКИМИ ШРИФТАМИ

Работа с КАЗАХСКИМИ ШРИФТАМИ. Здравствуйте Уважаемые Господа Програмисты. Моя небольшая статья будет, скорее всего, интересна програмистам из региона - КАЗАХСТАН. Так как програмисты проживающиее и работающие в этом регионе чаще всего встречаются с проблемой вывода нестандартных КАЗАХСКИХ ШРИФТОВ. Вместо введения... Как всегда, передо мною, выросла проблема и, как всегда, я решил приложить максимум усилий чтобы разобраться самому. (Вы меня простите но я не любитель напрягать форумы своими проблемами). Программисты Казахстана знают какая это довольно таки серьезная проблема "Нестандартные казахские символы". Так как я сейчас активно занимаюсь "писаниной" пишу прогу которая должна "понимать" КАЗАХСКИЙ ЯЗЫК от и до(Если так можно сказать). Писал, писал, и вдруг случилось... Окызывается не один элемент управления не хочить не "писать" , не "читать" по КАЗАХСКИ. Решил перелопатить инфу которая была и локальную и "ИНЕТСКУЮ". Как выяснилось инфы типа "КАК СДЕЛАТЬ СУПЕР _TButton_" огромное количество. А по шрифтам... "увольте". Приступим. Первое что надо сделать чтобы работать с казахскими шрифтами это... Разместить их в системной таблице шрифтов. Есть два способа закидываете файл со шрифтом в каталог \Windows\Fonts\/ Или же, ложите файл рядом с программой и вызываете AddFontResource('you_font.xxx'); Я пошел по первому пути(Так проще, хотя второй я тоже практиковал). Ну предположим что мы разобрались с методом регистрации шрифта в системе. Я использовал шрифт "Times/Kazakh" и вам советую. (Во всяком случае все примеры основанны именно на этом шрифте). Но при определенном навыке, или же когда освоитесь с этим шрифтом. Вы сможете перейти на любой другой шрифт. /*ВАЖНО*/ Второе, в чем часто путаются программеры, это - чтобы работать со шрифтами по принципу "ОТ ОКНА К ОКНУ" надо чтобы на всех окнах, в которых подразумевается использование казахского шрифта, было установленно одинаковое имя шрифта (Times/Kazakh). Тогда вы спокойно сможете пользоваться буфером обмена и оператором присваивания (EditX.Text:=EditY.text;). Это же относится и ко всем TCanvas на которых подразумевается вывод КАЗ_ШРИФТА. Основная проблема заключается в том что даже после усановки казахской раскладки и казахского шрифта Окна (даже окна редактирования TEdit. Tmemo) все равно не хотят выводить текст, даже с клавиатуры. И тут приходиться "хитрить" дело в том что нестандартные КАЗАХСКИЕ СИМВОЛЫ(CHAR) лежат в диапазоне 176-191(Большие и маленькие). Поэтому я сделал так - Во время ввода, если выбранна КАЗАХСКАЯ раскладка клавиатуры, перехватывать VIRT_KEY в событии OnKeyDown. И транслировать их в Казахские ЧАР'ы. Уже готовый текст вы можете сохранить в файл и потом открыть. Без всяких излишеств. Либо скопировать в буфер обмена. Но учтите при вставке в другое окно или приложение(NOTEPAD), обязательно убедитесь в том что там установлен такой же шрифт как и у вас в программе.

Code: //Дополнительные Переменные и функции. Const KZ_KBRD = $043f043f;//Дескриптор Казахской раскладки. //В системе. //Функция Определяющая какой регистр использовать. //Данные обрабатываются в соответствии. //С состояниями клавиш от клавиатуры. Function IsLow:Boolean; Var SHF,CPS_L : Boolean; Begin. REsult:=false; SHF:= HiWord(GetAsyncKeyState(VK_SHIFT))>0; //Зажат ли ШИФТ. CPS_L:= 0 <> (GetKeyState(VK_CAPITAL) and $01); //Состояние CAPS_LOCK. If (SHF and CPS_L) then Result:=true; //пропись если ЗАЖАТЫ ОБЕ КЛАВИШИ. If (not SHF and not CPS_L) then Result :=true; //Или наоборт. End; //Функция конвертирующая КЛАВИШУ в СИМВОЛ. Function KeyToKZChar(Key:Integer;lowKey:boolean):Char; Begin. Result:=#0; {Мальнькие } {Большие}. Case key of {Символы} {Символы}. 50: if LowKey then result:=chr(184) else Result:= chr(176); 51: if lowkey then result:=chr(105) else Result:= chr(73); 52: if lowkey then result:=chr(187) else Result:= Chr(179); 53: if lowkey then Result:=chr(185) else Result:= Chr(177); 54: if lowkey then result:=chr(190) else Result:= Chr(182); 55: if lowkey then result:=chr(189) else Result:= Chr(181); 48: if lowkey then result:=chr(186) else Result:= Chr(178); 189:if lowkey then result:=chr(188) else Result:= Chr(180); 187:if lowkey then result:=chr(191) else Result:= Chr(183); End; End; {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}. {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}. Var LastKey :integer; //Для хранения Последней клавиши. LowKey :Boolean = true; //Верхний или нижний регистр. //Проверяем как прога пишет на Казахском языке. //Вылавливаем клавишу для дальнейшей обработки. Procedure TForm1.Edit3KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. LastKey := Key; LowKey:=IsLow; //Сразу (на месте) определяем и сохраняем регистр. End; Procedure TForm1.Edit3KeyPress(Sender: TObject; var Key: Char); Var tmpKey :char; Begin. If GetKeyboardLayout(0)=KZ_KBRD then //Если казахская раскладка то.. Begin. TmpKey:=KeyToKZChar(LastKey,LowKey);// Получаем нужный символ. If not(tmpKey = #0) then //Если не стандартный символ то... Begin. Key:=tmpKey; // Указываем окну наш символ. Exit; End; End; End; //Дальше тоже самое только для компонента TMEMO. Procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Begin. LastKey:=key; LowKey:=IsLow; End; Procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char); Var tmpKey : char; Begin. If GetKeyboardLayout(0)=KZ_KBRD then. Begin. TmpKey:=KeyToKZChar(LastKey,LowKey); If not(tmpKey = #0) then. Begin. Key:=tmpKey; Exit; End; End; End; //Можем сохранить наше творение в файл. Procedure TForm1.Button4Click(Sender: TObject); Begin. Memo1.Lines.SaveToFile('A.txt'); End; //Или же наоборот загрузить из файла. Procedure TForm1.Button5Click(Sender: TObject); Begin. Memo1.Lines.LoadFromFile('A.txt'); End; //Проба вывода на канвас разными методами. Procedure TForm1.Button3Click(Sender: TObject); Begin. Pb.Canvas.Font.Name:='Times/Kazakh'; Pb.Canvas.Font.Color:=clRed; Pb.Canvas.Font.Size:=14; Pb.Canvas.TextOut(10,10,Edit1.Text); TextOut(PB.Canvas.Handle,30,30,Pchar(Edit1.Text),10); End; //Текст На компоненты. Edit3.Text:=Memo1.Text; Button2.Caption:=Edit3.Text;

На этом моя задача исчерпала сама себя. Конечно в приведенном примере еще много белых пятен. К примеру возникают сложности при вставке текста скопированном в другом приложении (Блокнот). Но это уже другие проблемы, другие вопросы, другие задачи. Даже на основе этого "скилета". Можно приступать к "написанию" программ на "Казахском языке" либо же разрабатывать на его основе свои "скилеты". Буду очень признателен если кто нибудь оттранслирует статью под С++(С сылкой на автора) Если будут какие нибудь вопросы то... Я всегда буду рад на них ответить. aster_x@inbox.ru.

Из за того что фичь есть но юзать его простым смертным не дано.... С ГЛУБОКИМ УВАЖЕНИЕМ ASTER_X.

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

Автор: ASTER_X.

©Drkb::01931.

Работа с портами микропроцессора

Модуль для работы с портами микропроцессора

Работает под Win9x.

НЕ работает под WinNT.

Работа с отчетами Rave Report в режиме RunTime.

Автор: Турушев Виталий

Введение

С выходом Delphi 7 мы стали свидетелями выхода нового генератора отчетов Rave Report Borland Edition от разработчиков фирмы Nevrona. Среда разработки Rave имеет довольно много новшеств, и в тоже время ряд ошибок и недочетов. Среди положительных качеств можно отметить: сохранение проекта отчета в файл и чтение его из файла, что позволяет удобно загрузить или сохранить необходимый проект отчета, и в дальнейшем работать с ним. Также есть набор компонентов для конвертирования отчета Rave в другие форматы (PDF, HTML, RTF, TEXT). Rave Report значительно облегчает разработку отчетов где используются базы данных, ведь выбор компонентов доступа к источникам данных весьма неплох. Среди недочетов отмечу: недоработку среды разработки отчетов Rave, где присутствует ряд серьезных ошибок. Также Nevrona предоставила довольно таки очень скудную справку для разработчика и не порадовала достаточным количеством примеров работы с отчетами Rave.

Причиной написания данной статьи стало отсутствие примеров и описания работы с отчетами Rave в режиме RunTime, что не позволяет пользователю более гибко работать с отчетом (например: изменение данных/оформления в отчете при наступлении определенного события в программе, а возможности Event Editor в Rave Report увы ограничены), что отталкивает пользователей от использования генератора отчетов Rave. Возможно, по этой причине или по причине недоработки генератора отчета часть пользователей возвращается к генератору отчетов Quick Report или к генераторам отчетов других разработчиков.

Исследование классов в проекте отчета Rave Report.

Для работы с отчетами в RunTime потребуется, знание имен подключаемых модулей в раздел uses, создаваемого проекта. Ниже представлена таблица описания основных модулей, которые могут понадобятся для работы с отчетом Rave в RunTime. Примечание: Для разработчиков CLX приложений название модулей почти идентично, только в имени модуля предшествует символ «Q». Например: QRvCsBars. Все модули находятся в каталоге «\Rave5\Lib» куда установлена среда программирования Delphi 7.

Имя модуля Описание модуля

RvClass Этот модуль содержит реализацию базовых классов

RvProj В этом модуле набор классов реализующие собственно сам проект

отчета и отвечающих за работу с ним

RvCsDraw Классы в этом модуле реализуют графические примитивы

RvCsBars В этом модуле реализованы штриховые коды

RvCsStd В этом модуле реализуются основные элементы оформления отчета

RvCsRpt, Набор классов в данном модуле служит для вывода данных из

RvCsData баз данных или других источников данных

Примечание: В качестве файла отчета взят уже готовый демонстрационный пример отчета RaveDemo.rav, поставляемый с генератором отчета Rave Report, который находится в каталоге «\Rave5\Demos». Поэтому следует указать полный путь к файлу отчета или скопировать данный файл в каталог с текущим проектом.

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

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

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

И так, двигаемся далее. Для работы с отчетом в RunTime, конечно, необходимо знать из набора каких объектов состоит данный отчет и, от каких классов произошли эти объекты, ведь в справочной системе Rave Report о них нет ни слова. Для этого необходимо написать процедуру, которая поможет узнать, из каких объектов состоит отчет, а также поможет выяснить имена классов и объектов. Код данной процедуры представлен ниже:

Code: Procedure GetListObjects(ListClass: TStrings; ClassX: TComponent; TabStr: String; AddObjects: Boolean = False); Var. I: Integer; Begin. If (ClassX = nil) or (ListClass = nil) then. EXIT; For I := 0 to ClassX.ComponentCount - 1 do. Begin. If AddObjects then. ListClass.AddObject(TabStr + ClassX.Components[I].Name + ' - ' + ClassX.Components[I].ClassName, ClassX.Components[I]). Else. ListClass.Add(TabStr + ClassX.Components[I].Name + ' - ' + ClassX.Components[I].ClassName); If ClassX.Components[I].ComponentCount > 0 then. GetListObjects(ListClass, ClassX.Components[I], TabStr + '..', AddObjects); End; End;

Работа с JPEG изображением в Delphi.

Автор: Михаил Христосенко

WEB сайт: http://mihandelphi.narod.ru.

Работа с Microsoft Speech API в Delphi.

Альберт Мамедов

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

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

Об этом позаботились специалисты Microsoft выпустив на рынок бесплатный ActiveX компонент TextToSpeech входящий в стандартную комплектацию WinMe и Win 2x.

Если у Вас этого компонента нет Вам необходимо скачать и установить Microsoft Speech API 4.0 825 Кб и Lernout &Hauspie Text-To-Speech 2.9 Мб (русский мужской и женский голос.).

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

Рассмотрим пример применения Microsoft Speech API.

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

Для размещения ActiveX компонентов будем использовать универсальный класс-контейнер TAxControl, подробно описанный в книге «Delphi для профессионалов» авторы Александровский А.Д., Шубин В.В.

Code: Unit axControl; { Класс-контейнер для ActiveX (компонента управления). }. Interface. Uses. Windows, Messages, Classes, Controls, ActiveX, OleCtrls,StdCtrls; // ///******************************************************************** Type. TAxControl = class(TOleControl)// Private. CControlData : TControlData2; // Информация об ActiveX. Protected. Procedure InitControlData; override; Public. Property CData : TControlData2 read CControlData; Constructor Create (AOwn : TComponent;AGUID : TGUID); End; Implementation. ////////////////////////////////////////////////////////////////////////////// Constructor TAxControl. Create (AOwn : TComponent ;AGUID : TGUID); Begin. FillChar(CControlData,sizeof(CControlData),0); // Обнуляете поле с информацией об Active. CControlData.ClassID :=AGUID; // Указываете QUID компонента,который будет создаваться. Inherited Create (AOwn); // Вызываете конструктор предка. ControlStyle := ControlStyle + [csClickEvents]; // Стиль отображения. End ; /////////////////////////////////////////////////////////////////////////////////// Procedure TAxControl. InitControlData; Begin. ControlData := @CControlData; // Указываете адрес, где находится информация об ActiveX. End; ////////////////////////////////////////////////////////////////////////////////////// End.

Работа с системным логом событий.

Программный класс работы с системным логом событий. Реализованы методы чтения, записи, работа с бэкапом, слежение за изменением лога. На его основе и для демонстрации возможностей класса, написано демо приложение - аналог стандартного просмоторщика событий.

Скачать демонстрационный пример

Александр (Rouse_) Багель.

Http://rouse.drkb.ru.

©Drkb::02243.

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

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

Работа с транзакциями

Code: DbMain.StartTransaction; Try. SpAddOrder.ParamByName('ORDER_NO').AsInteger := OrderNo; SpAddOrder.ExecProc; For i := 0 to PartList.Count - 1 do. Begin. SpReduceParts.ParamByName('PART_NO').AsInteger := PartRec(PartList.Objects[i]).PartNo; SpReduceParts.ParamByName('NUM_SOLD').AsInteger := PartRec(PartList.Objects[i]).NumSold; End; DbMain.Commit; Except. DbMain.RollBack; Raise; End;

Работа с Structured Storage.

Класс для работы с структурированным хранилищем данных (Structured Storage). Обновленная версия, исправлена неприятная ошибка приводящая к утечке памяти.

Работа с WinInet, Демо получения HTML кода страницы.

Работа с WinInet, Демо получения HTML кода страницы

Code: //////////////////////////////////////////////////////////////////////////////// // // Демо получения HTML кода страницы. // Автор: Александр (Rouse_) Багель. // © Fangorn Wizards Lab 1998 - 2003. // 19 января 2003. Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, Wininet, StdCtrls; Const. HTTP_PORT = 80; CRLF = #13#10; Header = 'Content-Type: application/x-www-form-urlencoded' + CRLF; Type. TForm1 = class(TForm). Button1: TButton; Memo1: TMemo; Button2: TButton; Memo2: TMemo; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function DelHttp(URL: String): String; Begin. If Pos('http://', URL) > 0 then Delete(Url, 1, 7); Result := Copy(Url, 1, Pos('/', Url) - 1); If Result = '' then Result := URL + #0; End; Function GetUrl(const URL: String): String; Var. FSession, FConnect, FRequest: HINTERNET; FHost, FScript, SRequest: String; Ansi: PAnsiChar; Buff: array [0..1023] of Char; BytesRead: Cardinal; Res, Len: DWORD; Begin. Result := ''; // Небольшой парсинг. // вытаскиваем имя хоста и параметры обращения к скрипту. FHost := DelHttp(Url); FScript := Url; Delete(FScript, 1, Pos(FHost, FScript) + Length(FHost)); //FScript := FHost + '/' +FScript; // Инициализируем WinInet. FSession := InternetOpen('DMFR', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); If not Assigned(FSession) then Exit; Try. // Попытка соединения с сервером. FConnect := InternetConnect(FSession, PChar(FHost), HTTP_PORT, nil, 'HTTP/1.0', INTERNET_SERVICE_HTTP, 0, 0); If not Assigned(FConnect) then Exit; Try. // Подготавливаем запрос страницы. Ansi := 'text/*'; FRequest := HttpOpenRequest(FConnect, 'GET', PChar(FScript), 'HTTP/1.1', Nil, @Ansi, INTERNET_FLAG_RELOAD, 0); If not Assigned(FConnect) then Exit; Try. // Добавляем заголовки. If not (HttpAddRequestHeaders(FRequest, Header, Length(Header), HTTP_ADDREQ_FLAG_REPLACE or. HTTP_ADDREQ_FLAG_ADD or. HTTP_ADDREQ_FLAG_COALESCE_WITH_COMMA)) then Exit; // Проверяем запрос: Len := 0; Res := 0; SRequest := ' '; HttpQueryInfo(FRequest, HTTP_QUERY_RAW_HEADERS_CRLF or. HTTP_QUERY_FLAG_REQUEST_HEADERS, @SRequest[1], Len, Res); If Len > 0 then. Begin. SetLength(SRequest, Len); HttpQueryInfo(FRequest, HTTP_QUERY_RAW_HEADERS_CRLF or. HTTP_QUERY_FLAG_REQUEST_HEADERS, @SRequest[1], Len, Res); End; Form1.Memo2.Lines.Text := SRequest; // Отправляем запрос. If not (HttpSendRequest(FRequest, nil, 0, nil, 0)) then Exit; // Получаем ответ. FillChar(Buff, SizeOf(Buff), 0); Repeat. Result := Result + Buff; FillChar(Buff, SizeOf(Buff), 0); InternetReadFile(FRequest, @Buff, SizeOf(Buff), BytesRead); Until BytesRead = 0; Finally. InternetCloseHandle(FRequest); End; Finally. InternetCloseHandle(FConnect); End; Finally. InternetCloseHandle(FSession); End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Memo1.Text := GetUrl('http://forum.sources.ru/index.php?showforum=14'); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Memo1.Text := GetUrl('http://forum.sources.ru/'); End; End.

Проект также доступен по адресу: http://rouse.front.ru/loadhtml.zip Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03585.

Разработка ASP-приложений при помощи Delphi.

Разработка ASP-приложений при помощи Delphi 5.

Сервер ASP работает под управлением Windows NT (98, 2000) с Internet Information Server (IIS) или Microsoft Personal Web Server (PWS). Такая зависимость несколько сужает круг использования ASP. По существу, ASP-технология -- это внутренняя разработка Microsoft, которая не была согласована с такими законодателями де-факто технологий интернет, как Sun и Netscape. Возможно, что не стоит особо рассчитывать на то, что эта технология “приживется” на других платформах, поскольку в ASP заложены такие эксклюзивные разработки Microsoft, как COM-технология и запись данных в системный реестр. Однако уже сегодня многие крупные ресурсы интернет построены на основе ASP.

Принцип работы ASP.

Клиентское приложение, работающее с ASP-сервером,-- это обычный документ HTML, который можно прочитать в любом браузере. И размещаются эти документы на обычном вебсервере. Вебсервер, получив требование о предоставлении такого документа, считывает его из локального хранилища и передает клиенту, но при этом часть информации вносится в этот документ ASP-сервером динамически. Принято, чтобы документы, обращающиеся к ASP-серверу, имели расширение ASP. Примеры таких документов есть в каталогах Microsoft Internet Informational Server -- WINNT\SYSTEM32\INETSRV\IISADMIN и INETPUB\IISAMPLES\EXAIR. Типичное обращение к ASP-серверу из документа HTML выглядит так:

Это сценарий, написанный на Visual Basic (VB). Поскольку сценарии из ASP-документов выполняются на сервере, то клиенту передается уже готовая вебстраница. Таким образом, несмотря на наличие VB-сценария, страница ASP может быть доступна клиентам, работающим на других платформах, таких как UNIX.

По существу ASP-сервер представляет собой сервер OLE-автоматизации, где предопределено несколько интерфейсов, в частности, IRequest (содержит методы, вызов которых позволяет установить параметры, заполненные на клиенте) и IResponse (вызов методов которого приводит к формированию документа HTML и передаче последнего клиенту). В этом ASP-сервер напоминает приложения CGI и ISAPI/NSAPI DLL (далее -- вебсерверные приложения). Принципы выполнения методов на ASP-сервере и в вебсерверных приложениях также аналогичны: анализируется (при необходимости) запрос клиента и динамически формируется отклик. Отличие заключается в том, что вебсерверные приложения формируют документ HTML целиком, а отклик ASP-сервера вставляется в код исходной вебстраницы. Например, если документ ASP представлен в виде

и результатом выполнения метода MyContent является строка “Первое обращение к ASP-серверу”, то на экране клиентского браузера появится документ, содержащий текст “Первое обращение к ASP-серверу”, отформатированный в соответствии с тэгами этого документа.

Таким образом, в документ HTML вставляется отклик ASP-сервера. В одном документе могут содержаться обращения к разным ASP-серверам. Результат будет также объединен в один документ. Получить аналогичный результат при использовании веб-приложений невозможно. Однако и здесь есть свое ограничение: все ASP-серверы, к которым обращается документ, должны быть зарегистрированы на одном сервере IIS. Обратиться по разным адресам для формирования одного документа HTML нельзя.

Простой пример работы ASP.

ASP-сервер может быть реализован как в виде исполняемого приложения, так и в виде динамической подключаемой библиотеки (DLL). Это разрешается при создании сервера OLE-автоматизации. ASP-сервер в виде EXE-файла запускается один раз в ответ на запрос клиента. При использовании внутренних (in-process) ASP-серверов один экземпляр DLL, загруженный в оперативную память, способен обслуживать одновременно нескольких клиентов. Для каждого из них может создаваться отдельный экземпляр COM-объекта. Кроме того, один экземпляр COM-объекта также может обслуживать нескольких клиентов. Это зависит от выбранной модели потоков обработки данных (Threading Model) в диалоговом окне, открываемом по команде File р New р ActiveX р Active Server Object.

Рассмотрим следующий пример. Создадим при помощи среды разработки Delphi 5 внутренний (in-process) ASP-сервер и рассмотрим принципы его работы. Пусть сервер выполняет один запрос. Создадим с помощью команды File р New р ActiveX р ActiveX Library новый проект и сохраним его под именем MyASP. Теперь воспользуемся командой File р New р ActiveX р Active Server Object. В появившемся диалоговом окне определим имя класса, например, TestASP (рис. 1). Поскольку мы создаем внутренний (in-process) сервер, то в данном случае параметр Instancing не играет роли, зато имеет значение параметр Threading Model. Выбор режима Single приводит к неэффективной работе сервера, т. к. при одновременном обращении к нему нескольких клиентов сервер будет выполнять запросы последовательно. Если выполнение запроса одного из клиентов потребует много времени, то остальные клиенты будут вынуждены ожидать его окончания, даже если их запросы можно выполнить гораздо быстрее. Это создает впечатление “зависания” браузера и часто приводит к попыткам пользователей, так или иначе, прервать выполнение задачи. В режиме Apartment запросы клиентов разделяются по потокам, причем для каждого клиента создается отдельный экземпляр COM-объекта (в данном примере класса TTestASP). В этом случае при написании методов класса не требуется защиты переменных класса по потокам. Клиент может свободно модифицировать их, что упрощает разработку кода. Недостаток такой модели состоит в ресурсоемкости проекта. Кроме того, при каждом обращении к ASP-серверу переменные класса инициализируются заново, что увеличивает время отклика. Этих недостатков лишена модель Free, в которой один экземпляр COM-объекта обслуживает нескольких клиентов. Однако, если клиенты могут изменять данные, то потребуется защита общих переменных по потокам. Это усложнит код приложения и станет потенциальным источником трудноуловимых ошибок. Как правило, модель Free используют в серверах, которые только предоставляют данные, но не позволяют клиенту их модифицировать. В нашем случае выберем модель Apartment.

В этом же диалоговом окне мы имеем возможность выбрать назначение ASP-сервера. Если планируется инсталлировать сервер на компьютере, которым управляет IIS версии 3 или 4, то следует выбрать Page Level Events Methods. С IIS 5 этот режим также работает, но в этом случае эффективнее будет работать опция Object Context. Ее же следует выбирать, если работой ASP управляет Microsoft Transaction Server (MTS). В режиме Generate a template test script for this object будет создан документ HTML, который в дальнейшем можно будет использовать для тестирования ASP-сервера.

После нажатия кнопки OK будет создан файл с описанием интерфейсов Unit1.pas. Переименуем его в TestASPUnit.pas. Кроме того, будет создана библиотека типов, откроется ее редактор и файл с описанием -- в данном примере MyASP_TLB.pas. Если был выбран режим Page-level event methods, то библиотека типов будет содержать два предопределенных метода -- OnStartPage и OnEndPage. Также будет создан файл TestASP.asp, который содержит документ HTML с заготовками VB-сценариев для тестирования сервера.

Теперь создадим метод, который будет заполнять документ HTML. Для этого в редакторе библиотеки типов выберем интерфейс ITestASP и вберем команду New Method. Назовем вновь созданный метод MyContent. Этот метод не должен иметь параметров. Затем обновим данные в модуле, описывающем библиотеку, нажатием кнопки.

В модуле реализации (TestASPUnit.pas) появится заготовка, где следует описать эту реализацию. Пусть метод выглядит следующим образом:

Code: Procedure TTestASP.MyContent; Begin. If Assigned(Response) then Response.Write. ('First call to ASP server'); End;

Разработка Internet-приложений с использованием Borland Delphi и Kylix.

Никита Попов

Введение

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

Безусловно, применение Internet-технологий для построения информационной инфраструктуры является относительно новым полем деятельности, однако к настоящему моменту в мире образовалось достаточно большое число компаний, поставляющих на рынок средства разработки и поддержки бизнес-приложений, использующих Internet-технологии. Многие из этих компаний создаются непосредственно под Internet-рынок, однако не меньше игроков — выходцы из области «классических» средств разработки. Одним из известнейших поставщиков средств разработки приложений долгое время была и остается компания Borland, известная своими RAD-инструментами для платформы Windows, такими как Borland Delphi, Borland C++Builder, а также кросс-платформенным средством разработки JBuilder, использующим технологии Java.

Исторически являющаяся одной из компаний-первопроходцев в различных направлениях разработки программного обеспечения, Borland вполне закономерно обратила свое внимание на набирающее рост направление Internet-технологий, представив различные средства для создания, внедрения и поддержки Internet-приложений.

В данной статье речь пойдет о поддержке разработки Internet-приложений в двух наиболее известных инструментах компании Borland: Delphi и Kylix.

Delphi — это интегрированная среда для быстрого создания приложений баз данных, настольных и Internet-приложений, построенная на основе разработанной Borland визуальной библиотеки компонентов (Visual Components Library, VCL), включающая в себя средства разработки интерфейса приложений с двусторонней связью с исходным кодом (Two-Way Tools), широкий спектр средств отладки приложений и различных вспомогательных средств.

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

Kylix, Delphi для Linux — это аналог Delphi, предназначенный для разработки приложений для операционной системы Linux, которая в последнее время все более широко распространяется в мире1. Подобно своему Windows-аналогу — Delphi, Kylix имеет для своей платформы чрезвычайно важное значение хотя бы потому, что до настоящего времени для Linux не существовало средств разработки, сравнимых с Delphi по мощности и простоте использования, что, в свою очередь, привело к сужению круга разработчиков программного обеспечения для этой платформы и в значительной степени затормозило ее распространение в качестве настольной операционной системы, временно ограничив Linux лишь достаточно узкой областью серверной платформы и Internet-хостинга.

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

Подобно Delphi, Kylix базируется на аналогичной VCL технологии, получившей название CLX (произносится как «кликс») — Component Library for Cross Platform Development, а также на наборе средств разработки, аналогичных Delphi. При этом Kylix даже более ориентирован на разработку Internet-приложений, нежели Delphi, который в настоящее время является более универсальным продуктом. Текущая версия Kylix, точнее Kylix Server Developer, помимо средств разработки приложений баз данных, настольных приложений и «классических» Internet-приложений, то есть клиентов, использующих различные Internet-службы и протоколы, и серверов, применяющих технологии CGI (Common Gateway Interface), а также реализующих ответные, серверные части Internet-служб, включает в себя ряд средств для разработки расширений Web-сервера Apache, представляющего собой сегодня один из наиболее распространенных Web-серверов в мире.

Поскольку Kylix был официально анонсирован компанией Borland раньше новой версии Delphi, целесообразно начать наш обзор именно с этого продукта.

Итак, какие именно инструменты для разработки Internet-приложений имеет в своем арсенале Delphi для Linux?

Средства разработки Internet-приложений из состава Borland Kylix.

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

Kylix поддерживает два типа серверных Internet-приложений: приложения на основе технологии CGI и расширения сервера Apache — Apache DSO (Dynamic Shared Objects, динамические объекты совместного использования).

Shared Objects — это некий аналог Windows-модулей DLL для Linux, обеспечивающих совместное использование программных элементов несколькими приложениями. Практически вся функциональность Linux, включая большую часть ядра ОС, построена с применением Shared Objects (SO). Kylix также использует эту технологию, в частности для переноса технологии пакетов (packages) на Linux, и, конечно, позволяет разрабатывать собственные SO-модули.

В свою очередь, DSO-модули — это специальным образом организованные библиотеки Shared Objects, обладающие расширенными возможностями взаимодействия с сервером Apache за счет доступа к его API (Application Programming Interface, прикладного программного интерфейса) и использующиеся как стандартное средство расширения возможностей этого сервера.

Сервер Apache является проектом Open Source, координируемым Apache Group. Как и большинство проектов Open Source, Apache распространяется бесплатно вместе с исходным кодом в соответствии со специальной лицензией и, опять-таки подобно большинству OS-проектов, активно развивается, получая все больший набор возможностей. Несомненно, эти особенности, а также высокая надежность, простота в использовании и доступность для очень широкого спектра операционных систем (большинство клонов UNIX, Win32 и т.д.) явились причинами широкого распространения сервера Apache в качестве платформы для Internet-хостинга и корпоративных Web-приложений.

Поскольку Apache входит в поставку большинства клонов Linux, логично было включить его поддержку в Kylix Server Developer, что и было осуществлено компанией Borland в дополнение к поддержке технологии CGI.

Другие технологии, такие как WinCGI и ISAPI/NSAPI, по понятным причинам не вошли в состав Kylix, поскольку предназначены для использования для серверных расширений на платформе Windows.

В состав Kylix входит иерархия компонентов для создания Internet-приложений, построенная на иерархии WebBroker, аналогичной применяемой в Delphi 5: WebModule, WebDispatcher, WebActionItem и т.д. Все они являются невизуальными компонентами, отвечающими за создание иерархии обработки запросов протокола HTTP и генерации соответствующих ответных действий на эти запросы путем образования слоя Internet-компонентов среднего уровня, обеспечивающих взаимодействие клиентских и серверных Internet-приложений на уровне протокола HTTP. Основой приложения, построенного на архитектуре WebBroker, является контейнер типа WebModule, в котором размещаются другие Web-компоненты, генерируемые автоматически (WebDispatcher) или создаваемые в процессе разработки приложения (WebActionItem, PageProducer и т.д.). Компонент WebDispatcher создается контейнером WebModule автоматически и является центром обработки HTTP-запросов. Следует еще раз подчеркнуть, что данная иерархия полностью аналогична Delphi-реализации, и потому работа Internet-приложения, созданного при помощи Kylix, будет полностью совпадать с работой подобного Delphi-приложения, основанного на архитектуре WebBroker.

При поступлении HTTP-запроса он передается объекту WebDispatcher, который производит просмотр списка компонентов типа WebActionItem и автодиспетчеризуемых компонентов, пытаясь найти компонент, способный обработать именно тот тип запроса, который является текущим в очереди. В том случае, если подходящего компонента не обнаружено, запрос передается объекту WebActionItem с пометкой Default (внутри WebModule может быть только один такой объект). В том случае, если Default WebActionItem имеет средства для обработки такого запроса, производятся необходимые действия, а затем (при необходимости) генерируется ответ, который передается обратно объекту WebDispatcher, а от него клиенту — отправителю запроса.

Каждый из компонентов WebActionItem может быть наделен специальными возможностями по обработке отдельных видов запросов, например будет генерировать отдельную станицу Web-сайта при запросе конкретного URI или же наоборот — выдавать сообщение об ошибочной ссылке на страницу (код 404 протокола HTTP) либо на корневую страницу Web-сайта при обращении к корневому URI, что, как правило, делает Default WebActionItem.

Как и любой компонент или класс Object Pascal, для компонента WebActionItem могут создаваться наследники — с целью расширения или специализации функциональности. Например, можно создать компонент-наследник WebActionItem, который будет специальным образом реагировать на ошибку в описании URI (URL) вместо выдачи стандартного сообщения 404 «Страница не найдена», генерируя более развернутый текст сообщения или производя какие-либо иные действия.

Непосредственно генерация содержания страниц производится визуальными компонентами типа PageProducer и их наследниками, работающими в связке с компонентами WebActionItem, или же при помощи обработчиков событий OnAction, реализованных непосредственно для компонентов WebActionItem. Визуальные компоненты генерации содержания входят в состав палитры Internet, в которой также располагаются визуальные Internet-компоненты нижнего уровня, обеспечивающие работу непосредственно с протоколами TCP/IP и UDP, речь о которых пойдет ниже.

Первый слева компонент является визуальным вариантом автоматически создаваемого WebDispatcher и предназначен для преобразования в WebModule контейнера DataModule, о чем речь пойдет позже.

Базовый компонент PageProducer обладает возможностью генерации содержимого страницы по заданному в свойстве HTMLDoc- или HTMLFile-шаблону или через событие OnHTMLTag, позволяющему реализовать реакцию Web-приложения на специальные тэги в составе шаблона, например динамическую подстановку данных.

Помимо универсальной реализации PageProducer в набор Internet-компонентов среднего уровня в Kylix входят также наследники PageProducer, предназначенные для реализации более специализированных действий, например для публикации и ввода данных: DataSetTableProducer, DataSetPageProducer, QueryTableProducer и SQLQueryTableProducer. Эти компоненты содержатся в палитре Internet и составляют слой Internet-компонентов верхнего уровня, изолированных от протокольной части компонентами архитектуры WebBroker.

Назначение этих компонентов можно понять из имен классов:

· DataSetTableProducer и DataSetPageProducer предназначены для публикации данных из источников данных в виде таблиц или набора полей при отсутствии необходимости ввода параметров отбора данных из источника;

· QueryTableProducer и SQLQueryTableProducer позволяют публиковать данные из источников, требующих для формирования набора данных входных параметров, которые передаются в виде параметров HTTP-запроса в случае запроса типа GET или в виде полей свойства ContentFields объекта запроса типа POST.

В любом случае поля данных подставляются на свое место в HTML-документе с помощью «прозрачных» для HTML-парсеров тэгов, содержащихся в шаблоне страницы, которые затем заменяются непосредственно значениями полей данных. Например, при использовании компонента TPageProducer и его события OnHTMLTag для генерации HTML-страницы, шаблон вида:

Code: <HEAD> <TITLE>Sample Delphi Web server application</TITLE> </HEAD> <BODY> <H2>Customer Order Information</H2> <HR> Click a customer name to view their orders.<P> <#CUSTLIST><P> </BODY> </HTML>

после замещения тэга <#CUSTLIST> реальными данными (в данном примере — списком клиентов из демонстрационной базы данных customer.db) будет преобразован в следующий HTML-код:

Code: <HTML> <HEAD> <TITLE>Sample Delphi Web server application</TITLE> </HEAD> <BODY> <H2>Customer Order Information</H2> <HR> Click a customer name to view their orders.<P> <A HREF=”/cgi-bin/cgidemo.exe/runquery?CustNo=1645">Action Club</A> <BR><A HREF=”/cgi-bin/cgidemo.exe/runquery?CustNo=3158">Action Diver Supply</A> <BR><A HREF=”/cgi-bin/cgidemo.exe/runquery?CustNo=1984">Adventure Undersea</A> <BR><A HREF=”/cgi-bin/cgidemo.exe/runquery?CustNo=3053">American SCUBA Supply</A> … </BODY> </HTML>

Компоненты DataSetTableProducer и QueryTableProducer используют для формирования HTML-документа шаблоны, генерируемые автоматически в зависимости от содержания публикуемого набора данных и настроек самого компонента. Обращение к данным из этих компонентов и их наследников производится через иерархию классов dbExpress, которая в Kylix и в новой версии Delphi является основным средством доступа к данным.

Помимо компонентов генерации HTML-контента, в состав Internet-компонентов входит такой компонент, как WebDispatcher. Этот компонент предназначен для преобразования обычного приложения баз данных (или desktop-приложения) в Internet-приложение. Достигается это следующим образом.

Сначала компонент WebDispatcher помещается в обычный модуль (DataModule) данных, при этом для него создается дерево компонентов WebActionItem — аналогично тому, как это происходит в WebModule, поскольку WebModule автоматически поддерживает создание иерархии компонентов WebBroker, WebDispatcher и WebActionItem на уровне своей реализации. После того как DataModule был соответствующим образом подготовлен, им можно заменить с помощью автоматически созданного при генерации нового приложения мастера Web Server Application WebModule (при этом перенеся все компоненты доступа к данным) другие невизуальные компоненты, содержащиеся в исходном DataModule, и, конечно, сопутствующий исходный код во вновь созданное Internet-приложение.

Рассмотренные выше компоненты составляют верхний (PageProducer и его наследники) и средний (WebBroker, WebDispatcher, WebActionItem) уровни иерархии классов для создания Internet-приложений и работают с протоколом HTTP на уровне компонента WebBroker.

Для непосредственного доступа к возможностям базовых Internet-протоколов TCP/IP и UDP в состав Kylix включены компоненты нижнего уровня — ClientSocket, ServerSocket, TcpClient, TcpServer и UDPSocket, которые предназначены для создания клиентских и серверных приложений, работающих непосредственно через TCP-соединение.

Компоненты ClientSocket и ServerSocket позволяют осуществлять обмен данными через TCP-соединение за счет использования событий OnReceive и OnSend с последующей их обработкой внутри соответствующего приложения. При этом обеспечивается базовая функциональность для создания и управления TCP-соединением с возможностью локации по URL или непосредственно через указание TCP-адреса и порта.

Компоненты TcpClient и TcpServer являются наследниками ClientSocket и ServerSocket, соответственно расширяя их функциональность возможностью работы с тем или иным протоколом по выбору: IP, TCP, UDP или другим сетевым протоколом, а также за счет ряда дополнительных свойств и методов, упрощающих создание приложений на основе этих компонентов.

Компонент UDPSocket обеспечивает создание и управление соединением на базе протокола UDP, то есть на самом нижнем протокольном уровне Internet-соединений. По функциональности этот компонент аналогичен ClientSocket и ServerSocket.

Перечисленные выше компоненты являются частью CLX (Component Library for Cross-platform) и разработаны компанией Borland с учетом современных Internet-стандартов, образуя фундамент для построения Internet-приложений с использованием Kylix. Однако помимо базовых служб и протоколов существует широкий набор дополнительных служб и задач, возможности которых часто используются Internet-разработчиками. К тому же далеко не всегда возможность отображения информации через HTML-браузер является приемлемым решением для разработки Internet-приложений. В этом случае разумно использовать Internet-инфраструктуру для обмена данными, а отображение информации обеспечить за счет более сложных клиентских приложений, разработанных на Kylix. Аналогично зачастую требуется реализовать специализированную серверную логику, которая не заложена в стандартные Web-серверы.

Для решения такого класса задач в состав Kylix включена библиотека стороннего разработчика — компании Nevrona Design: Internet Direct (Indy).

Данная библиотека была разработана компанией Nevrona Design специально для Borland Delphi и насчитывает в своей истории уже восемь версий, последняя из которых вошла в состав Kylix и новой версии Delphi. Набор компонентов этой библиотеки разделен на три группы: Indy Clients, Indy Servers и Indy Misc.

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

Большинство компонентов Indy Clients и IndyServers являются «ответными» частями клиент-серверных пар протоколов и служб, за исключением отдельных, в основном серверных, компонентов типа TunnelMaster и TunnelSlave, и позволяют использовать такие протоколы, как TCP/IP, UDP, NNTP, SMTP, FTP, HTTP, а также службы ECHO, FINGER, WHOIS и т.д.

Подкатегория Indy Misc включает в себя такие компоненты, как кодеки BASE64, UUE, Quoted Printable и других распространенных форматов обмена данными через e-mail, кодеры MD2, MD4 и MD5 — стандартов криптографии, используемых для хранения паролей и электронных подписей в необратимом (не поддающемся расшифровке) виде, а также множество других полезных компонентов и утилит, часто применяющихся при разработке Internet-приложений.

Компоненты протокольных клиентов и серверов могут быть использованы для разработки серверных и клиентских Internet-приложений, совместно или взамен базовых компонентов ClientSocket, ServerSocket и т.д. в тех случаях, когда это оказывается удобнее по тем или иным причинам. Подобно ClientSocket, ServerSocket и другим компонентам из состава палитры Internet, компоненты Indy не используют архитектуру WebBroker, реализуя поддержку Internet-протоколов и служб на нижнем уровне непосредственно в своем исходном коде.

Примеры использования компонентов Internet и Indy можно найти в каталогах %KYLIX%/Demos/Internet и %KYLIX/Demos/Indy.

Следует отметить, что в состав Kylix не входят компоненты InternetExpress, поскольку они используют технологию MIDAS (интерфейс IAppServer и т.д.) для работы с данными, а поддержка этой технологии не включена в состав текущей версии Kylix.

Как уже говорилось выше, Kylix, по своей функциональности в целом и по возможностям разработки Internet-приложений в частности, повторяет возможности Delphi 5, за исключением определенных отличий, связанных с особенностями операционной системы Linux. Однако в настоящее время Delphi перешел на «новый уровень эволюции», что обеспечено выходом новой версии этого продукта, на примере которой, точнее на примере Delphi 6 Enterprise, мы рассмотрим, какие возможности, связанные с разработкой Internet-приложений, нам обеспечивает новая версия Delphi, во многом являющегося «законодателем мод» среди инструментов разработки от Borland.

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

Средства разработки Internet-приложений из состава Borland Delphi 6.

Отвечая ожиданиям многих разработчиков, новая версия Delphi содержит множество улучшений и новшеств в различных областях, включая усовершенствованную IDE (Integrated Development Environment — интегрированную среду разработки), новую базовую библиотеку компонентов CLX (Component Library for Cross-platform — библиотеку компонентов для кросс-платформенной разработки) и т.д.1 И конечно, в состав новой версии Delphi входит множество новых компонентов, поддерживающих передовые стандарты в области разработки Internet-приложений.

Помимо возможностей Delphi 5 и Kylix, то есть набора компонентов нижнего уровня (ClientSocket, ServerSocket, TcpClient, TcpServer и UDPSocket) и компонентов верхнего уровня (PageProducer, DataSetTableProducer, QueryTableProducer и WebDispatcher), которые были рассмотрены выше, Delphi 6 включает в себя новый набор компонентов, реализующий технологию WebSnap, компоненты WebServices, реализующие поддержку технологии SOAP (Simple Object Activation Protocol — простой протокол активации объектов), а также входящий в состав Delphi 5 набор компонентов InternetExpress, позволяющий создавать Internet-приложения для работы с данными через MIDAS с передачей данных в формате XML DataPackets (пакетов данных XML).

Технология WebSnap является дальнейшей эволюцией технологии WebBroker, реализованной в Delphi 5 и Kylix, и позволяет создавать более мощные и сложные по структуре Internet-приложения.

Общие принципы разработки приложений с использованием WebSnap примерно схожи с разработкой приложений на основе WebBroker, за исключением особенностей, перечисленных в таблице.

архитектура WebSnap действительно поддерживает гораздо больше различных компонентов для создания Web-страниц по сравнению с WebBroker.

Компоненты типа «адаптер» (TAdapter, TPagedAdapter, TDataSetAdapter, TLoginFormAdapter, TApplicationAdapter и т.д.) служат для реализации поддержки языков сценария на стороне сервера. Так, например, компонент TDataSetAdapter служит для использования языка сценария при формировании отображения содержимого набора данных. При этом может использоваться JScript или VBScript, в зависимости от типа сервера, для которого разрабатывается приложение. Немаловажным фактом является то, что WebSnap поддерживает JScript на стороне сервера в соответствии со спецификацией ECMA (ECMA-262), описывающей объектно-ориентированный язык сценариев для формирования содержания HTML-страниц. Дополнительную информацию об этом стандарте можно получить на странице этой организации по адресу http://www.ecma.ch/.

Другая часть компонентов WebSnap относится к классу «диспетчер» (TPageDispatcher, TAdapterDispatcher) и обеспечивает диспетчеризацию HTTP-запросов и ответов на них в соответствии с заданной бизнес-логикой.

Компоненты типа «список» (TStringsValuesList, TDataSetValuesList, TWebUserList) позволяют включать в содержимое HTML-страниц различные списки (текстовых строк, строк наборов данных, списки пользователей и т.д.).

Компоненты типа «продюсер» (TXSLPageProducer, TAdapterPageProducer) позволяют генерировать страницы на основе компонентов типа «адаптер» и других, представляющих собой отдельные элементы HTML-страницы, «собирая» их в единый HTML-документ. При этом TXSLPageProducer позволяет формировать содержимое страницы на основе XML-трансформации исходного шаблона, описанного в соответствии со стандартами XML (eXtensible Markup Language) и XSL (eXtensible Stylesheet Language), и исходных данных в формате XML, которые, в свою очередь, могут быть сформированы непосредственно внутри приложения, считаны из внешнего файла или получены через компоненты доступа к данным (dbExpress, DataSnap).

В основе Internet-приложения на основе WebSnap по-прежнему лежит компонент-контейнер, который, однако, теперь может быть в приложении не единственным. Контейнером в иерархии WebSnap является компонент TWebSnapDataModule или TWebAppPageModule, то есть подразумевается разбиение приложения на страницы подобно «классическому» Web-сайту. Внутри этого контейнера располагаются визуальные компоненты для генерации содержания и невизуальные компоненты WebActionItem, отвечающие за построение дерева реакций приложения на HTTP-запросы.

Как можно увидеть из этого рисунка, WebSnap действительно допускает использование компонентов WebBroker совместно с компонентами новой архитектуры, что открывает чрезвычайно большой выбор возможностей реализации той или иной задачи построения Internet-приложения в зависимости от ее сложности и других факторов. При этом компоненты WebBroker, вложенные в контейнер TWebAppPageModule, будут работать в новой, многоконтейнерной архитектуре приложения WebSnap точно так же, как и в одноконтейнерной архитектуре WebBroker, что позволит при необходимости осуществить переход к новой архитектуре без внесения многочисленных изменений в существующее приложение.

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

Архитектура WebSnap обеспечивается большим числом мастеров (wizards) для первичной генерации «скелетов» Internet-приложений, а также для выполнения повторяющихся промежуточных операций.

В отличие от реализации поддержки WebBroker в Delphi 5 и Kylix, поддержка WebSnap в Delphi 6 включает в себя расширенные средства визуальной разработки и предварительного просмотра генерируемых данных. Так, средство Page Module View позволяет осуществлять предварительный просмотр результатов генерации содержания страницы на основании отдельного Page Module без компиляции и запуска приложения под управлением Web-сервера, что существенно облегчает отладку Internet-приложений. При этом, в отличие от средств поддержки WebBroker, для WebSnap используется встроенный браузер, что исключает привязку архитектуры к какому-либо одному средству просмотра (как это было с WebBroker), по причине чего в Kylix и Delphi 5 не были включены средства предварительного просмотра результатов генерации компонентов типа PageProducer и DataSetProducer (при этом предварительный просмотр поддерживался только для компонентов InternetExpress за счет использования сервера OLE Automation от MS Internet Explorer, что, естественно, автоматически исключало перенос этого сервиса, например, на платформу Linux).

Помимо просмотра сгенерированного HTML-содержания средства предварительного просмотра Delphi 6/WebSnap позволяют отображать результаты построения XML- и XSL-деревьев без компиляции приложения, что также значительно упрощает процесс создания и отладки приложений.

Также в состав средств поддержки XML, которая вообще является в Delphi 6 одним из наиболее значимых нововведений, входит средство построения схем связей XML (XML Data Binding Wizard), позволяющее на основе файлов данных в формате XML формировать файлы связей, описывающих типы объектов и их атрибуты на основе исходных данных, которые затем могут быть использованы для выполнения трансформаций внутри приложений.

Как мы говорили выше, Delphi 6 по-прежнему поддерживает и компоненты InternetExpress, которые также могут быть использованы совместно с компонентами WebSnap.

Компоненты InternetExpress позволяют осуществлять включение данных в содержание HTML-страниц за счет использования механизма «прозрачных» HTML-тэгов при генерации содержания. InternetExpress состоит из компонентов InetXPageProducer и XMLBroker.

Первый является наследником PageProducer и производит непосредственную генерацию HTML-содержания с «прозрачными» HTML-тэгами. Второй осуществляет обмен данными с сервером (источником) данных на основе технологии MIDAS, то есть практически с любым существующим поставщиком данных, реализующим один из поддерживаемых MIDAS стандартов (CORBA, COM/DCOM, Sockets и т.д.).

При этом для передачи данных к клиентской части приложения (Web-странице внутри HTML-браузера) используются XML DataPackets, содержащие как собственно данные, так и их описание в формате XML. Для передачи изменений в данных, которые могут быть произведены внутри клиентской части Internet-приложения на основе InternetExpress, используются DeltaPackets, опять-таки в формате XML, описывающие исключительно изменения, которые должны быть внесены в данные на сервере, что позволяет снизить трафик между клиентами и Web-сервером. За генерацию пакетов данных (data packets) и расшифровку разностных пакетов (delta packets) отвечает компонент XMLBroker, который также транслирует изменения серверу данных.

Изюминкой архитектуры InternetExpress является то, что, в отличие от компонента PageProducer и его наследников — DataSetPageProducer и других, InetXPageProducer не включает данные в состав HTML-страниц. Вместо этого данные, переданные в виде XML DataPackets клиентскому приложению (браузеру), подставляются на место «прозрачных» HTML-тэгов за счет реализации DOM (Document Object Model — объектной модели документа) внутри браузера-клиента, которая, в частности, описывает замещение «прозрачных» тэгов-свойств документа реальными значениями. В случае если браузер не имеет встроенной реализации DOM, используется реализация на JavaScript, как, например, это сделано для Netscape Navigator. Набор соответствующих сценариев включен в поставку Delphi, а InetXPageProducer может обеспечивать передачу этих сценариев на сторону клиента при первом обращении к Internet-приложению на основе InternetExpress за счет включения ссылок на них в содержание генерируемых страниц.

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

Компоненты InternetExpress вкладываются в контейнер WebModule или WebSnapDataModule/WebSnapPageModule и могут использоваться совместно с другими компонентами архитектур WebBroker и WebSnap.

Таким образом, архитектура WebSnap позволяет использовать существующие разработки на основе архитектуры WebBroker при создании Internet-приложений на базе новых технологий, предлагаемых Delphi 6. При этом также остается возможность разработки кросс-платформенных Internet-приложений на основе библиотеки CLX и архитектуры WebBroker, которые будут поддерживаться как Delphi 6, так и Kylix, причем в случае соблюдения при разработке определенных правил перенос проекта между платформами не будет односторонним, то есть появляется возможность вести параллельную разработку для обеих операционных систем, с последующим переносом приложения с «ведущей» ОС на «ведомую».

Заключение

Итак, мы рассмотрели основные возможности разработки Internet-приложений с использованием Kylix и Delphi 6. Безусловно, в силу ограниченного объема статьи было невозможно уместить здесь более подробный обзор вновь появившихся технологий, однако основной нашей целью было показать, что нового привнесли в область разработки приложений для Internet два новых продукта компании Borland, и постараться заинтересовать как разработчиков уже существующих проектов этого класса, так и тех, кто находится в стадии принятия решения о выборе средства разработки и операционной системы для своего проекта, поскольку с выходом Kylix и Delphi 6 возможности разработки приложений, использующих Internet-технологии, многократно возросли. Надеемся, что данный обзор поможет вам разобраться в новых возможностях указанных продуктов.

КомпьютерПресс 6'2001.

Взято из http://delphi.chertenok.ru.

©Drkb::03432.

Разработка системного сервиса.

Заготовка для сервисов не использующая VCL (пример включает в себя два пустых сервиса).

Скачать демонстрационный пример

Александр (Rouse_) Багель.

Http://rouse.drkb.ru.

©Drkb::02244.

Разделяемые элементы управления для Tabbednotebook.

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

Разбиение шестнадцатиричной величины

Code: Function LoNibble ( X : Byte ) : Byte; Begin. Result := X And $F; End; Function HiNibble ( X : Byte ) : Byte; Begin. Result := X Shr 4; End;

Разбор адреса FTP.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Разбор адреса FTP. Функция анализирует строку aSrc и если в стоке дан корректный адрес FTP, возвращает имя пользователя, пароль, хост, порт и каталог. Если дан некорректный адрес, функция возвращает false, иначе - true. Учтена возможность, когда в адресе не указываются некоторые параметры. В этом случае, если нотация соблюдена, опущенные параметры возвращаются пустыми строками. Минимально подробный адрес: ftp://myftp.ru - В этом случае будет возвращён адрес, порт по умолчанию (21) и true. Максимально подробный адрес: ftp://MyLogin:MyPassword@MyFtp.ru:6000/MyDirectory/ - Будут возвращены все параметры и true. Зависимости: Classes, SysUtils. Автор: Роман Василенко, romix@nm.ru, ICQ:826361, Пятигорск. Copyright: Роман Василенко. Дата: 13 июня 2004 г. ********************************************** } Function ParseFTP(aSrc: string; out oUserName, oPassword, oHost: string; Out oPort: word; out oDir: string): boolean; Const. SsPrefix = 0; SsUserName = 1; SsPassword = 2; SsHost = 3; SsPort = 4; SsDir = 5; Var. F, StrState: integer; SPort, pfx: string; Begin. OUserName:=''; OPassword:=''; OHost:=''; SPort:=''; OPort:=21; ODir:=''; StrState:=ssPrefix; Result:=false; F:=1; Repeat. Case StrState of. SsPrefix: //Разбор префикса ftp:// и определение анонимности адреса. If aSrc[f]<>':' then. Pfx:=pfx+aSrc[f]. Else begin. If (ansisametext(trim(pfx),'ftp')) and. (aSrc[f]+aSrc[f+1]+aSrc[f+2]='://') then begin. If pos('@',aSrc)<1 then. StrState:=ssHost //Anonymous. Else. StrState:=ssUserName; //UserName[:Password]. Inc(f,2); End else break; End; SsUserName: //Извлечение имени пользователя. If aSrc[f]='@' then //Пароль не указан. StrState:=ssHost. Else. If aSrc[f]=':' then //Пароль указан. StrState:=ssPassword. Else. OUserName:=oUserName+aSrc[f]; SsPassword: //Извлечение пароля. If aSrc[f]='@' then. StrState:=ssHost. Else. OPassword:=oPassword+aSrc[f]; SsHost: //Извлечение хоста. If aSrc[f]=':' then //Порт указан. StrState:=ssPort. Else. If aSrc[f]='/' then //Порт не указан, возможно указан каталог. StrState:=ssDir. Else. OHost:=oHost+aSrc[f]; SsPort: //Извлечение порта. If aSrc[f]='/' then. StrState:=ssDir. Else. SPort:=sPort+aSrc[f]; SsDir: oDir:=oDir+aSrc[f]; End; Inc(f); Until f>length(aSrc); If (StrState>ssPassword) and (trim(oHost)<>'') then. Result:=true; Try. If trim(sPort)<>'' then oPort:=strtoint(sPort); Except. Result:=false; End; End;

Различные стили подчеркивания для TRichEdit.

Code: Uses. RichEdit; // Underline styles. Const. CFU_UNDERLINETHICK = 9; CFU_UNDERLINEWAVE = 8; CFU_UNDERLINEDASHDOTDOT = 7; CFU_UNDERLINEDASHDOT = 6; CFU_UNDERLINEDASH = 5; CFU_UNDERLINEDOTTED = 4; CFU_UNDERLINE = 1; CFU_UNDERLINENONE = 0; Procedure RE_SetCharFormat(ARichEdit: TRichEdit; AUnderlineType: Byte; AColor: Word); Var. // The CHARFORMAT2 structure contains information about. // character formatting in a rich edit control. Format: CHARFORMAT2; Begin. FillChar(Format, SizeOf(Format), 0); With Format do. Begin. CbSize := SizeOf(Format); DwMask := CFM_UNDERLINETYPE; BUnderlineType := AUnderlineType or AColor; ARichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format)); End; End; // Underline the current selection with a CFU_UNDERLINEWAVE line style (color red); Procedure TForm1.Button1Click(Sender: TObject); Begin. RE_SetCharFormat(RichEdit1, CFU_UNDERLINEWAVE, $50); End;

©Drkb::01028.

Взято с сайта: http://www.swissdelphicenter.ch.

Размещение диаграммы

Диаграмма может размещаться совместно с данными или на отдельном листе. Размещение диаграммы лучше совмещать с процессом ее создания, но можно выполнить эту процедуру и самостоятельно. При этом необходимо учитывать, что при изменении размещения меняется и имя диаграммы (не путать с названием). Для размещения диаграммы используйте функцию SetChartLocation, аргумент xlLocation которой может иметь одно из двух значений (xlLocationAsNewSheet или xlLocationAsObject).

Code: Function SetChartLocation (var name:variant;sheet:variant; XlLocation:integer):boolean; Begin. SetChartLocation:=true; Try. Name:=E.Charts.Item[name].Location(Where:= XlLocationAsObject,Name:=sheet).name; Except. SetChartLocation:=false; End; End;

Размер Bitmap.

Code: Function PictureSize: TSize; Var. ResHandle: HWND; ResData: HWND; BMI: PBitmapInfo; Begin. Result.cx := 0; Result.cy := 0; ResHandle := FindResource(HInstance, MAKEINTRESOURCE(200), RT_BITMAP); If ResHandle <> 0 then. Begin. ResData := LoadResource(HInstance, ResHandle); If ResData <> 0 then. Try. BMI := LockResource(ResData); If Assigned(BMI) then. Try. Result.cx := BMI.bmiHeader.biWidth; Result.cy := BMI.bmiHeader.biHeight; // размер картинки вот тут: BMI.bmiHeader.biSizeImage. Finally. UnlockResource(ResData); End; Finally. FreeResource(ResData); End; End; End;

Автор: Rouse_

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

©Drkb::03827.

Разное.

Разное

12. Разное.

ВВЕДЕНИЕ.

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

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

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

ТОЧКИ С ЗАПЯТОЙ.

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

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

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

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

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

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

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

A=b; c=d; e=e+1;

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

A=b c= d e=e+1.

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

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

Когда я начинал KISS, я попытался держать глаза открытыми. Я решил, что буду использовать точки с запятой когда это станет необходимо для синтаксического анализатора, но только тогда. Я рассчитывал, что это случится примерно в то время, когда я добавил возможность разложения утверждений на несколько строк. Но как вы можете видеть это никогда не случилось. Компилятор TINY совершенно счастлив анализировать наиболее сложные утверждения, разложенные на любое число строк, без точек с запятой.

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

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

СИНТАКСИЧЕСКИЙ САХАР.

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

Как пример можно было бы рассмотреть точку с запятой, но существуют множество других, такие как "THEN" в операторе IF, "DO" в операторе WHILE или даже утверждение "PROGRAM" которое я убрал из TINY. Ни один из этих токенов не добавляет много к синтаксису языка... компилятор может выяснить, что происходит и без них. Но некоторые люди чувствуют, что они улучшают читаемость программ и это может быть очень важно.

Существуют две школы мысли на эту тему, которые хорошо представлены двумя из наших наиболее популярных языков C и Pascal.

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

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

Различия хорошо представлены этими двум языками. Наиболее часто слышимая претензия к C - что он слишком прощающий. Когда вы делаете ошибку в C, ошибочный код часто является другой допустимой конструкцией C. Так что компилятор просто счастливо продолжает компиляцию и оставляет вам нахождение ошибок в течение отладки. Я предполагаю именно поэтому отладчики так популярны среди C программистов.

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

Самым лучшим примером полезного сахара является непосредственно точка с запятой. Рассмотрите фрагмент кода:

A=1+(2*b+c) b...

Так как нет никакого оператора, соединяющего токен 'b' с остальной частью выражения, компилятор заключит, что выражение заканчивается на ')' а 'b' - это начало нового утверждения. Но предположим, что я просто пропустил предполагаемый оператор и в действительности хотел сказать:

A=1+(2*b+c)*b...

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

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

Я нахожусь где-то посередине между этими подходами. Я склоняюсь к преимуществам Паскалевской точки зрения... я был бы очень доволен находить свои ошибки во время компиляции а не во время выполнения. Но я также ненавижу просто бросаться словами без явной причины как в COBOL. Пока что я последовательно выкинул большинство Паскалевского сахара из KISS/TINY. Но я конечно не испытываю сильных чувств к любому способу и я также могу видеть значение разбрасывания небольшого количества сахара только для дополнительной подстраховки, которую он дает. Если вам нравится этот последний подход, такие вещи легко добавить. Только запомните, что как и точка с запятой каждая ложка сахара - это что-то, что может потенциально привести к ошибке компиляции при ее пропуске.

РАБОТА С ТОЧКАМИ С ЗАПЯТОЙ.

Есть два различных способа работы с точками с запятой используемые в популярных языках. В Паскале точка с запятой расценивается как разделитель операторов. Точка с запятой не требуется после последнего утверждения в блоке. Синтаксис:

<block> ::= <statement> ( ';' <statement>)*

<statement> ::= <assignment> | <if> | <while> ... | null.

(пустое утверждение важно!).

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

В C и Ada, с другой стороны, точка с запятой рассматривается как терминатор операторов и следует после всех утверждений (с некоторыми смущающими и путающими исключениями). Синтаксис для них простой:

<block> ::= ( <statement> ';')*

Из двух синтаксисов, синтаксис Паскаля внешне выглядит более рациональным, но опыт показал, что он ведет к некоторым странным трудностям. Люди так привыкают ставить точку с запятой после каждого утверждения, что они также предпочитают ставить ее и после последнего утверждения в блоке. Это обычно не приносит какого-либо вреда... она просто обрабатывается как пустое утверждение. Многие программисты на Паскале, включая вашего покорного слугу, делают точно также. Но есть одно место, в котором вы абсолютно не можете поставить точку с запятой - прямо перед ELSE. Это маленький подводный камень стоил мне множества дополнительных компиляций, особенно когда ELSE добавляется к существующему коду. Так что выбор C/Ada оказывается лучше. Очевидно, Никлаус Вирт думает также: в Modula-2 он отказался от Паскалевского подхода.

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

Для начала я упростил программу представив новую подпрограмму распознавания:

Code: { Match a Semicolon }. Procedure Semi; Begin. MatchString(';'); End;

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

Так как точка с запятой следует за утверждением, процедура Block почти единственная, которую мы должны изменить:

Code: { Parse and Translate a Block of Statements }. Procedure Block; Begin. Scan; While not(Token in ['e', 'l']) do begin. Case Token of. 'i': DoIf; 'w': DoWhile; 'R': DoRead; 'W': DoWrite; 'x': Assignment; End; Semi; Scan; End; End;

Внимательно взгляните на тонкие изменения в операторе case. Вызов Assigment теперь ограничивается проверкой Token. Это позволит избежать вызова Assigment когда токен является точкой с запятой (что случается когда утверждение пустое).

Так как объявления - тоже утверждения, мы также должны добавить вызов Semi в процедуру TopDecl:

Code: { Parse and Translate Global Declarations }. Procedure TopDecls; Begin. Scan; While Token = 'v' do begin. Alloc; While Token = ',' do. Alloc; Semi; End; End;

Наконец нам нужен вызов для утверждения PROGRAM:

Code: { Main Program }. Begin. Init; MatchString('PROGRAM'); Semi; Header; TopDecls; MatchString('BEGIN'); Prolog; Block; MatchString('END'); Epilog; End.

Проще некуда. Испробуйте это с копией TINY и скажите как вам это нравится.

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

Code: { Parse and Translate a Single Statement }. Procedure Statement; Begin. Scan; Case Token of. 'i': DoIf; 'w': DoWhile; 'R': DoRead; 'W': DoWrite; 'x': Assignment; End; End;

Используя эту процедуру мы можем переписать Block так:

Code: { Parse and Translate a Block of Statements }. Procedure Block; Begin. Statement; While Token = ';' do begin. Next; Statement; End; End;

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

КОМПРОМИСС.

Теперь, когда мы знаем как работать с точками с запятой, означает ли это, что я собираюсь поместить их в KISS/TINY? И да и нет. Мне нравится дополнительный сахар и защита, которые приходят с уверенным знанием, где заканчиваются утверждения. Но я не изменил своей антипатии к ошибкам компиляции, связанным с точками с запятой.

Так что я придумал хороший компромисс: сделаем их необязательными!

Рассмотрите следующую версию Semi:

{ Match a Semicolon }.

Procedure Semi; begin if Token = ';' then Next; end;

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

Поместите эту процедуру на место в первую версию вашей программы (с синтаксисом для C/Ada) и вы получите TINY Version 1.2.

КОММЕНТАРИИ.

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

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

ОДНОСИМВОЛЬНЫЕ РАЗДЕЛИТЕЛИ.

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

Один подход состоит в том, чтобы удалять комментарии как только мы встретим их во входном потоке, т.е. прямо в процедуре GetChar. Чтобы сделать это сначала измените имя GetChar на какое-нибудь другое, скажем GetCharX. (На всякий случай запомните, это будет временное изменение, так что лучше не делать этого с вашей единственной копией TINY. Я полагаю вы понимаете, что вы всегда должны делать эти эксперименты с рабочей копией).

Теперь нам нужна процедура для пропуска комментариев. Так что наберите следующее:

Code: { Skip A Comment Field }. Procedure SkipComment; Begin. While Look <> '}' do. GetCharX; GetCharX; End;

Ясно, что эта процедура будет просто считывать и отбрасывать символы из входного потока, пока не найдет правую фигурную скобку. Затем она считывает еще один символ и возвращает его в Look.

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

Code: { Get Character from Input Stream }. { Skip Any Comments }. Procedure GetChar; Begin. GetCharX; If Look = '{' then SkipComment; End;

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

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

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

Однако, прежде чем вы отвернете свой нос от такого упрощенного решения, я должен подчеркнуть, что столь уважаемый компилятор, как Turbo Pascal, также не позволит использовать '{' в строке в кавычках. Попробуйте. Относительно комментариев, вложенных в идентификатор, я не могу представить чтобы кто-то захотел сделать подобные вещи, так что вопрос спорен. Для 99% всех приложений то что я показал, будет работать просто отлично.

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

Чтобы сделать это с начала верните GetChar на старое место и измените имя, вызываемое в SkipComment Затем, давайте добавим левую фигурную скобку как возможный символ незаполненного пространства:

Code: { Recognize White Space }. Function IsWhite(c: char): boolean; Begin. IsWhite := c in [' ', TAB, CR, LF, '{']; End;

Теперь мы можем работать с комментариями в процедуре SkipWhite:

Code: { Skip Over Leading White Space }. Procedure SkipWhite; Begin. While IsWhite(Look) do begin. If Look = '{' then. SkipComment. Else. GetChar; End; End;

Обратите внимание, что SkipWhite написан так, что мы пропустим любую комбинацию незаполненного пространства и комментариев в одном вызове.

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

Остался последний вопрос: вложенные комментарии. Некоторым программистам нравится идея вложенных комментариев так как это позволяет комментировать код во время отладки. Код, который я дал здесь не позволит этого и, снова, не позволит и Turbo Pascal.

Но исправить это невероятно просто. Все, что нам нужно - сделать SkipComment рекурсивной:

Code: { Skip A Comment Field }. Procedure SkipComment; Begin. While Look <> '}' do begin. GetChar; If Look = '{' then SkipComment; End; GetChar; End;

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

МНОГОСИМВОЛЬНЫЕ РАЗДЕЛИТЕЛИ.

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

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

Давайте условимся, что мы используем ограничители C '/*' и '*/'. Сначала мы должны возвратиться к методу 'GetCharX'. В еще одной копии вашего компилятора переименуйте GetChar в GetCharX и затем введите следующую новую процедуру GetChar:

Code: { Read New Character. Intercept '/*' }. Procedure GetChar; Begin. If TempChar <> ' ' then begin. Look := TempChar; TempChar := ' '; End. Else begin. GetCharX; If Look = '/' then begin. Read(TempChar); If TempChar = '*' then begin. Look := '{'; TempChar := ' '; End; End; End; End;

Как вы можете видеть эта процедура перехватывает каждое появление '/'. Затем она исследует следующий символ в потоке. Если это символ '*', то мы нашли начало комментария и GetChar возвратит его одно-символьный заменитель. (Для простоты я использую тот же самый символ '{' как я делал для Паскаля. Если бы вы писали компилятор C, вы без сомнения захотели бы использовать какой-то другой символ, не используемый где-то еще в C. Выберите что вам нравится... даже $FF, что-нибудь уникальное).

Если символ, следующий за '/' не '*', тогда GetChar прячет его в новой глобальной переменной TempChar и возвращает '/'.

Обратите внимание, что вы должны объявить эту новую переменную и присвоить ей значение ' '. Мне нравится делать подобные вещи с использование конструкции "типизированная константа" в Turbo Pascal:

Const TempChar: char = ' ';

Теперь нам нужна новая версия SkipComment:

Code: { Skip A Comment Field }. Procedure SkipComment; Begin. Repeat. Repeat. GetCharX; Until Look = '*'; GetCharX; Until Look = '/'; GetChar; End;

Обратите внимание на несколько вещей: прежде всего нет необходимости изменять функцию IsWhite и процедуру SkipWhite так как GetChar возвращает токен '{'. Если вы измените этот символ токена, тогда конечно вы также должны будете изменить символ в этих двух подпрограммах.

Во-вторых, заметьте, что SkipComment вызывает в своем цикле не GetChar а GetCharX. Это означает, что завершающий '/' не перехватывается и обрабатывается SkipComment. В-третьих, хотя работу выполняет процедура GetChar, мы все же можем работать с символами комментариев, вложенными в строки в кавычках, вызывая GetCharX вместо GetChar пока мы находимся внутри строки. Наконец, заметьте, что мы можем снова обеспечить вложенные комментарии добавив одиночное утверждение в SkipComment, точно также как мы делали прежде.

ОДНОСТОРОННИЕ КОММЕНТАРИИ.

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

Code: { Skip A Comment Field }. Procedure SkipComment; Begin. Repeat. GetCharX; Until Look = CR; GetChar; End;

Если ведущий символ - одиночный, как ";" в ассемблере, тогда мы по существу все сделали. Если это двух символьный токен, как "--" из Ada, нам необходимо только изменить проверки в GetChar. В любом случае это более легкая проблема чем двухсторонние комментарии.

ЗАКЛЮЧЕНИЕ.

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

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

· Точки с запятой необязательны.

· Комментарии ограничены фигурными скобками.

· Комментарии могут быть вложенными.

Поместите код, соответствующий этим случаям в вашу копию TINY. Теперь у вас есть TINY Version 1.2.

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

Рекурсивные механизмы спуска по дереву

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

Рекурсивный поиск с помощью функции Pos.

Code: Function PosN(Substring, Mainstring: string; n: Integer): Integer; { Function PosN get recursive - the N th position of "Substring" in. "Mainstring". Does the Mainstring not contain Substrign the result. Is 0. Works with chars and strings. } Begin. If Pos(substring, mainstring) = 0 then. Begin. Posn := 0; Exit; End. Else. Begin. If n = 1 then posn := Pos(substring, mainstring). Else. Begin. Posn := Pos(substring, mainstring) + posn(substring, Copy(mainstring, (Pos(substring, mainstring) + 1), Length(mainstring)), n - 1); End; End; End; //Beispiele / Examples. I := posn('s', 'swissdelphicenter.ch', 2); // i=4. I := posn('x', 'swissdelphicenter.ch', 1); // i=0. I := posn('delphi', 'swissdelphicenter.ch', 1); // i=6.

Расчет расстояния между 2мя точками на земной поверхности методом Винсенти.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Расчет расстояния между двумя точками на земной поверхности. Расчет расстояния между 2мя точками на земной поверхности методом Винсенти. Dimka Maslov: Lat1, Lon1 - широта и долгота точки 1 в градусах. Lat2, Lon2 - широта и долгота точки 2 в градусах. Функция возвращает результат в метрах. Автор, правда, забыл упомянуть о правиле знаков для южных широт и западных. Долгот... Зависимости: Math. Автор: Вячеслав. Copyright: Опубликован в Survey Review №175 за Апрель 1976г. Дата: 19 марта 2003 г. ********************************************** } Function Vincenty(Lat1, Lon1, Lat2, Lon2: Extended): Extended; Const // Параметры эллипсоида: A = 6378245.0; F = 1 / 298.3; B = (1 - f) * a; EPS = 0.5E-30; Var. APARAM, BPARAM, CPARAM, OMEGA, TanU1, TanU2, Lambda, LambdaPrev, SinL, CosL, USQR, U1, U2, SinU1, CosU1, SinU2, CosU2, SinSQSigma, CosSigma, TanSigma, Sigma, SinAlpha, Cos2SigmaM, DSigma : Extended; Begin. Lon1 := lon1 * (PI / 180); Lat1 := lat1 * (PI / 180); Lon2 := lon2 * (PI / 180); Lat2 := lat2 * (PI / 180); //Пересчет значений координат в радианы. TanU1 := (1 - f) * Tan(lat1); TanU2 := (1 - f) * Tan(lat2); U1 := ArcTan(TanU1); U2 := ArcTan(TanU2); SinCos(U1, SinU1, CosU1); SinCos(U2, SinU2, CosU2); OMEGA := lon2 - lon1; Lambda := OMEGA; Repeat //Начало цикла итерации. LambdaPrev:= lambda; SinCos(lambda, SinL, CosL); SinSQSigma := (CosU2 * SinL * CosU2 * SinL) + (CosU1 * SinU2 - SinU1 * CosU2 * CosL) * (CosU1 * SinU2 - SinU1 * CosU2 * CosL); CosSigma := SinU1 * SinU2 + CosU1 * CosU2 * CosL; TanSigma:= Sqrt(SinSQSigma) / CosSigma; If TanSigma > 0. Then Sigma := ArcTan(TanSigma). Else Sigma := ArcTan(TanSigma) + Pi; If SinSQSigma = 0. Then SinAlpha := 0. Else SinAlpha := CosU1 * CosU2 * SinL / Sqrt(SinSQSigma); If (Cos(ArcSin(SinAlpha)) * Cos(ArcSin(SinAlpha))) = 0. Then Cos2SigmaM := 0. Else Cos2SigmaM:= CosSigma - (2 * SinU1 * SinU2 / (Cos(ArcSin(SinAlpha)) * Cos(ArcSin(SinAlpha)))); CPARAM:= (f / 16) * Cos(ArcSin(SinAlpha)) * Cos(ArcSin(SinAlpha)) * (4 + f * (4 - 3 * Cos(ArcSin(SinAlpha)) * Cos(ArcSin(SinAlpha)))); Lambda := OMEGA + (1 - CPARAM) * f * SinAlpha * (ArcCos(CosSigma) + CPARAM * Sin(ArcCos(CosSigma)) * (Cos2SigmaM + CPARAM * CosSigma * (-1 + 2 * Cos2SigmaM * Cos2SigmaM))); Until Abs(lambda - LambdaPrev) < EPS; // Конец цикла итерации. USQR:= Cos(ArcSin(SinAlpha)) * Cos(ArcSin(SinAlpha)) * (a * a - b * b) / (b * b); APARAM := 1 + (USQR / 16384) * (4096 + USQR * (-768 + USQR * (320 - 175 * USQR))); BPARAM := (USQR / 1024) * (256 + USQR * (-128 + USQR * (74 - 47 * USQR))); DSigma := BPARAM * SQRT(SinSQSigma) * (Cos2SigmaM + BPARAM / 4 * (CosSigma * (-1 + 2 * Cos2SigmaM * Cos2SigmaM) - BPARAM / 6 * Cos2SigmaM * (-3 + 4 * SinSQSigma) * (-3 + 4 * Cos2SigmaM * Cos2SigmaM))); Result := b * APARAM * (Sigma - DSigma); End;

Расширенные строковые функции

LTrim() - Удаляем все пробелы в левой части строки

RTrim() - Удаляем все пробелы в правой части строки

Trim() - Удаляем все пробелы по краям строки

RightStr() - Возвращаем правую часть стоки заданной длины

LeftStr() - Возвращаем левую часть стоки заданной длины

MidStr() - Возвращаем центральную часть строки

Squish() - возвращает строку со всеми белыми пробелами и с удаленными повторяющимися апострофами.

Before() - возвращает часть стоки, находящейся перед первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает Search.

After() - возвращает часть строки, находящейся после первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает NULL.

RPos() - возвращает первый символ последней найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает 0. Подобна реверсированной Pos().

Inside() - возвращает подстроку, вложенную между парой подстрок Front ... Back.

Leftside() - возвращает левую часть "отстатка" inside() или Search.

Rightside() - возвращает правую часть "остатка" inside() или Null.

Trim() - возвращает строку со всеми удаленными по краям белыми пробелами.

Расширенный Label для отображения имени файла.

Расширенный Label для отображения имени файла

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Label1: TLabel; Procedure FormCreate(Sender: TObject); End; Var. Form1: TForm1; Implementation. Uses Types; {$R *.dfm}. Type. TPathLabel = class(TLabel). Private. FHintWindow: THintWindow; Procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; Procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; Procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; Procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; Protected. Procedure Paint; override; Public. Constructor Create(AOwner: TComponent); override; End; { TPathLabel }. Procedure TPathLabel.CMHintShow(var Message: TMessage); Var. P: TPoint; R: TRect; Begin. Message.Result := 1; End; Procedure TPathLabel.CMMouseEnter(var Message: TMessage); Var. P: TPoint; R: TRect; W: Integer; Begin. W := Canvas.TextWidth(Caption); If W > ClientWidth then. Begin. P := ClientToScreen(Point(0, 0)); R := ClientRect; R := Rect(P.X, P.Y, P.X + W + 5, P.Y + ClientHeight); FHintWindow.ActivateHint(R, Caption); Message.Result := 1; End; Inherited; End; Procedure TPathLabel.CMMouseLeave(var Message: TMessage); Begin. FHintWindow.ReleaseHandle; Inherited; End; Procedure TPathLabel.CMTextChanged(var Message: TMessage); Begin. If Canvas.TextWidth(Caption) > ClientWidth then. Begin. ShowHint := True; Hint := Caption; End else begin. ShowHint := False; Hint := ''; End; Inherited; End; Constructor TPathLabel.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); AutoSize := False; FHintWindow := THintWindow.Create(Self); FHintWindow.Color := Application.HintColor; End; Procedure TPathLabel.Paint; Var. R: TRect; Begin. R := ClientRect; If Transparent then. Canvas.Brush.Style := bsClear. Else begin. Canvas.Brush.Style := bsSolid; Canvas.Brush.Color := Color; End; DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_PATH_ELLIPSIS); End; Procedure TForm1.FormCreate(Sender: TObject); Var. R: TRect; Begin. R := Label1.BoundsRect; Inc(R.Top, 50); Inc(R.Bottom, 50); With TPathLabel.Create(Self) do. Begin. Parent := Self; Color := clLime; BoundsRect := R; Caption := Label1.Caption; End; End; End.

©Drkb::00809.

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

Автор: Smike.

Расшифровка строки, ранее зашифрованной фукцией UBPFD.Encrypt.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Расшифровка строки. Предназначена для расшифровки строки, ранее зашифрованной фукцией UBPFD.Encrypt. Зависимости: UBPFD.Encrypt. Автор: Anatoly Podgoretsky, anatoly@podgoretsky.com, Johvi. Copyright: (c) Anatoly Podgoretsky, 1996. Дата: 26 апреля 2002 г. ********************************************** } Const. StartKey = 471; // Start default key. MultKey = 62142; // Mult default key. AddKey = 11719; // Add default key. // обязательно смените ключи до использования. {$R-}. {$Q-}. Function Decrypt(const InString:string; StartKey,MultKey,AddKey:Integer): string; Var. I : Byte; //Если поменять тип переменной I на Integer, то будет возможно шифрование. //текста длиной более 255 символом - VID. Begin. Result := ''; For I := 1 to Length(InString) do. Begin. Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8)); StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey; End; End; {$R+}. {$Q+}.

Распределение Паскаля

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Распределение Паскаля. Возвращает случайное число, распределенное по закону распределения Паскаля. Зависимости: system. Автор: Алексей Перов, aperov@rambler.ru, ICQ:102661702, Караганда. Copyright: Лабораторные работы по курсу "Моделирование информационных систем", КарГТУ. Дата: 26 апреля 2002 г. ********************************************** } Function RandomPascal(k, q: Extended): Extended; { распределение Паскаля }. Var. Tr: Extended; I: Integer; Begin. Tr := 1; Q := ln(q); For i := 1 to Round(k) do tr := tr * Random; Result := ln(tr) / q; End;

Распределенные информационные системы и базы данных.

Распределенные информационные системы и базы данных

Введение

Распределенные базы данных невозможно рассматривать вне контекста более общей и более значимой темы распределенных информационных систем. Процессы децентрализации и информационной интеграции, происходящие во всем мире, неизбежно должны рано или поздно затронуть нашу страну. Россия, в силу своего географического положения и размеров "обречена" на преимущественное использование распределенных систем. На мой взгляд, это направление может успешно развиваться лишь при выполнении двух главных условий - адекватном развитии глобальной сетевой инфраструктуры и применении реальных технологий создания распределенных информационных систем. Второе условие, рассматриваемое как ключевой фактор развития информационных технологий в нашей стране, составляет предмет предлагаемого в данной статье обсуждения. Важность этой темы осознают все. Действительно, страна прошла начальный этап локальной компьютеризации. Многие задачи "автоматизации в малом" или "автоматизации в среднем" уже решаются адекватными средствами на достаточно высоком технологическом уровне. Но вот задачи совершенно иного качества - задачи создания корпоративных информационных систем - нуждаются в осмыслении и анализе. Сложность нынешнего этапа во многом предопределена традиционализмом и инерционностью мышления, выражающейся в попытке переноса средств и решений локальной автоматизации в мир распределенных систем. Этот мир живет по своим законам, которые требуют иных технологий. Существует ли сейчас понимание того, какими должны быть эти технологии? Боюсь, что нет. В большинстве же случаев преобладает стремление использовать знакомые, понятные, испробованные и поэтому родные средства для решения новых задач, принципиально отличающихся от того, чем приходилось заниматься раньше. Поведение и мотивация разработчиков вполне понятны и оправданы. Ставится задача - построить информационную систему "клиент-сервер" на базе локальной сети с централизованной базой данных. Выбирается одна из популярных многопользовательских СУБД и какие-либо средства для быстрой разработки приложений. Наконец, создается сама система, представляющая собой комбинацию базы данных и обращающихся к ней приложений, в которых и реализована вся прикладная логика. Пока все это работает в ограниченном масштабе, все идет великолепно. Предположим, что организация, для которой выполнялась разработка, настолько выросла, что вновь возникшие задачи потребовали децентрализации хранения и обработки данных и, соответственно, развития информационной системы. Здесь и совершается ошибка. Подходы, хорошо зарекомендовавшие себя во вполне определенных условиях, автоматически переносятся в совершенно иную среду, с иными правилами жизнедеятельности. В результате система становится неработоспособной и должна быть создана заново, но уже с применением адекватных средств. Статью можно рассматривать как очень краткое введение в распределенные базы данных. Сжато затронуты смежные темы, в частности, программное обеспечение промежуточного слоя. Предполагается, что читатель знаком с основами реляционных баз данных и языка sql. Статья носит скорее обзорный характер; рассматривая распределенные базы данных как отправную точку, я не удержался некоторых обобщений и высказал собственную точку зрения на архитектуру распределенных систем (с которой, возможно, многие не согласятся - но так интересней).

1. Распределенные базы данных

Под распределенной (distributed database - ddb) обычно подразумевают базу данных, включающую фрагменты из нескольких баз данных, которые располагаются на различных узлах сети компьютеров, и, возможно управляются различными СУБД. Распределенная база данных выглядит с точки зрения пользователей и прикладных программ как обычная локальная база данных. В этом смысле слово "распределенная" отражает способ организации базы данных, но не внешнюю ее характеристику. ("распределенность" базы данных невидима извне).

1.1. Определение Дэйта.

Лучшее, на мой взгляд, определение распределенных баз данных (ddb) предложил Дэйт (c.j. date). Он установил 12 свойств или качеств идеальной ddb:

· Локальная автономия (local autonomy)

· Независимость узлов (no reliance on central site)

· Непрерывные операции (continuous operation)

· Прозрачность расположения (location independence)

· Прозрачная фрагментация (fragmentation independence)

· Прозрачное тиражирование (replication independence)

· Обработка распределенных запросов (distributed query processing)

· Обработка распределенных транзакций (distributed transaction processing)

· Независимость от оборудования (hardware independence)

· Независимость от операционных систем (operationg system independence)

· Прозрачность сети (network independence)

· Независимость от баз данных (database independence)

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

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

Непрерывные операции Это качество можно трактовать как возможность непрерывного доступа к данным (известное "24 часа в сутки, семь дней в неделю") в рамках ddb вне зависимости от их расположения и вне зависимости от операций, выполняемых на локальных узлах. Это качество можно выразить лозунгом "данные доступны всегда, а операции над ними выполняются непрерывно".

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

Прозрачная фрагментация Это свойство трактуется как возможность распределенного (то есть на различных узлах) размещения данных, логически представляющих собой единое целое. Существует фрагментация двух типов: горизонтальная и вертикальная. Первая означает хранение строк одной таблицы на различных узлах (фактически, хранение строк одной логической таблицы в нескольких идентичных физических таблицах на различных узлах). Вторая означает распределение столбцов логической таблицы по нескольким узлам. Рассмотрим пример, иллюстрирующий оба типа фрагментации. Имеется таблица employee (emp_id, emp_name, phone), определенная в базе данных на узле в Фениксе. Имеется точно такая же таблица, определенная в базе данных на узле в Денвере. Обе таблицы хранят информацию о сотрудниках компании. Кроме того, в базе данных на узле в Далласе определена таблица emp_salary (emp_id, salary). Тогда запрос "получить информацию о сотрудниках компании" может быть сформулирован так:

Select * from employee@phoenix, employee@denver order by emp_id.

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

Select employee.emp_id, emp_name, salary from employee@denver, employee@phoenix, emp_salary@dallas order by emp_id.

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

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

Select customer.name, customer.address, order.number, order.date from customer@london, order@paris where customer.cust_number = order.cust_number.

Обработка распределенных транзакций Это качество ddb можно трактовать как возможность выполнения операций обновления распределенной базы данных (insert, update, delete), не разрушающее целостность и согласованность данных. Эта цель достигается применением двухфазового или двухфазного протокола фиксации транзакций (two-phase commit protocol), ставшего фактическим стандартом обработки распределенных транзакций. Его применение гарантирует согласованное изменение данных на нескольких узлах в рамках распределенной (или, как ее еще называют, глобальной) транзакции.

Независимость от оборудования Это свойство означает, что в качестве узлов распределенной системы могут выступать компьютеры любых моделей и производителей - от мэйнфреймов до "персоналок".

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

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

Независимость от баз данных Это качество означает, что в распределенной системе могут мирно сосуществовать СУБД различных производителей, и возможны операции поиска и обновления в базах данных различных моделей и форматов. Исходя из определения Дэйта, можно рассматривать ddb как слабосвязанную сетевую структуру, узлы которой представляют собой локальные базы данных. Локальные базы данных автономны, независимы и самоопределены; доступ к ним обеспечиваются СУБД, в общем случае от различных поставщиков. Связи между узлами - это потоки тиражируемых данных. Топология ddb варьируется в широком диапазоне - возможны варианты иерархии, структур типа "звезда" и т.д. В целом топология ddb определяется географией информационной системы и направленностью потоков тиражирования данных. Посмотрим, во что выливается некоторые наиболее важные свойства ddb, если рассматривать их практически.

1.2. Целостность данных

В ddb поддержка целостности и согласованности данных, ввиду свойств 1-2, представляет собой сложную проблему. Ее решение - синхронное и согласованное изменение данных в нескольких локальных базах данных, составляющих ddb - достигается применением протокола двухфазной фиксации транзакций. Если ddb однородна - то есть на всех узлах данные хранятся в формате одной базы и на всех узлах функционирует одна и та же СУБД, то используется механизм двухфазной фиксации транзакций данной СУБД. В случае же неоднородности ddb для обеспечения согласованных изменений в нескольких базах данных используют менеджеры распределенных транзакций. Это, однако, возможно, если участники обработки распределенной транзакции - СУБД, функционирующие на узлах системы, поддерживают xa-интерфейс, определенный в спецификации dtp консорциума x/open. В настоящее время xa-интерфейс имеют ca-openingres, informix, microsoft sql server, oracle, sybase. Если в ddb предусмотрено тиражирование данных, то это сразу предъявляет дополнительные жесткие требования к дисциплине поддержки целостности данных на узлах, куда направлены потоки тиражируемых данных. Проблема в том, что изменения в данных инициируются как локально - на данном узле - так и извне, посредством тиражирования. Неизбежно возникают конфликты по изменениям, которые необходимо отслеживать и разрешать.

1.3. Прозрачность расположения

Это качество ddb в реальных продуктах должно поддерживаться соответствующими механизмами. Разработчики СУБД придерживаются различных подходов. Рассмотрим пример из oracle. Допустим, что ddb включает локальную базу данных, которая размещена на узле в Лондоне. Создадим вначале ссылку (database link), связав ее с символическим именем (london_unix), транслируемым в ip-адрес узла в Лондоне.

Create public database link london.com connect to london_unix using oracle_user_id;

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

Select customer.cust_name, order.order_date from customer@london.com, order where customer.cust_number = order.cust_number;

Очевидно, однако, что мы написали запрос, зависящий от расположения базы данных, поскольку явно использовали в нем ссылку. Определим customer и customer@london.com как синонимы:

Create synonym customer for customer@london.com;

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

Select customer.cust_name, order.order_date from customer, order where customer.cust_number = order.cust_number.

Задача решается с помощью оператора sql create synonym, который позволяет создавать новые имена для существующих таблиц. При этом оказывается возможным обращаться к другим базам данных и к другим компьютерам. Так, запись в СУБД informix.

Create synonym customer for client@central:smith.customer.

означает, что любое обращение к таблице customer в открытой базе данных будет автоматически переадресовано на компьютер central в базу данных client к таблице customer. Оказывается возможным переместить таблицу из одной базы данных в другую, оставив в первой базе ссылку на ее новое местонахождение, при этом все необходимые действия для доступа к содержимому таблицы будут сделаны автоматически. Мы уже говорили выше о горизонтальной фрагментации. Рассмотрим пример иерархически организованной ddb, на каждом из узлов которой содержится некоторое подмножество записей таблицы customer:

С помощью create synonym можно определить, например, таблицу структуры customer, в которой хранятся строки с записями о клиентах компании, находящихся в Японии:

Create synonym japan_customer for customer@hq.sales.asia.japan Во многих СУБД задача управления именами объектов ddb решается путем использования глобального словаря данных, хранящего информацию о ddb: расположение данных, возможности других СУБД (если используются шлюзы), сведения о скорости передачи по сети с различной топологией и т.д.

1.4. Обработка распределенных запросов

Выше уже упоминалось это качество ddb. Обработка распределенных запросов (distributed query -dq) - задача, более сложная, нежели обработка локальных и она требует интеллектуального решения с помощью особого компонента - оптимизатора dq. Обратимся к базе данных, распределенной по двум узлам сети. Таблица detail хранится на одном узле, таблица supplier - на другом. Размер первой таблицы - 10000 строк, размер второй - 100 строк (множество деталей поставляется небольшим числом поставщиков). Допустим, что выполняется запрос:

Select detail_name, supplier_name, supplier_address from detail, supplier where detail.supplier_number = supplier.supplier_number;

Результирующая таблица представляет собой объединение таблиц detail и supplier, выполненное по столбцу detail.supplier_number (внешний ключ) и supplier.supplier_number (первичный ключ). Данный запрос - распределенный, так как затрагивает таблицы, принадлежащие различным локальным базам данных. Для его нормального выполнения необходимо иметь обе исходные таблицы на одном узле. Следовательно, одна из таблиц должна быть передана по сети. Очевидно, что это должна быть таблица меньшего размера, то есть таблица supplier. Следовательно, оптимизатор dq запросов должен учитывать такие параметры, как, в первую очередь, размер таблиц, статистику распределения данных по узлам, объем данных, передаваемых между узлами, скорость коммуникационных линий, структуры хранения данных, соотношение производительности процессоров на разных узлах и т.д. От интеллекта оптимизатора dq впрямую зависит скорость выполнения распределенных запросов.

1.5. Межоперабельность

В контексте ddb межоперабельность означает две вещи. Во-первых, - это качество, позволяющее обмениваться данными между базами данных различных поставщиков. Как, например, тиражировать данные из базы данных informix в oracle и наоборот? Известно, что штатные средства тиражирования в составе данной конкретной СУБД позволяют переносить данные в однородную базу. Так, средствами ca-ingres/replicator можно тиражировать данные только из ingres в ingres. Как быть в неоднородной ddb? Ответом стало появление продуктов, выполняющих тиражирование между разнородными базами данных. Во-вторых, это возможность некоторого унифицированного доступа к данным в ddb из приложения. Возможны как универсальные решения (стандарт odbc), так и специализированные подходы. Очевидный недостаток odbc - недоступность для приложения многих полезных механизмов каждой конкретной СУБД, поскольку они могут быть использованы в большинстве случаев только через расширения sql в диалекте языка данной СУБД, но в стандарте odbc эти расширения не поддерживаются. Специальные подходы - это, например, использование шлюзов, позволяющее приложениям оперировать над базами данных в "чужом" формате так, как будто это собственные базы данных. Вообще, цель шлюза - организация доступа к унаследованным (legacy) базам данных и служит для решения задач согласования форматов баз данных при переходе к какой-либо одной СУБД. Так, если компания долгое время работала на СУБД ims и затем решила перейти на oracle, то ей очевидно потребуется шлюз в ims. Следовательно, шлюзы можно рассматривать как средство, облегчающее миграцию, но не как универсальное средство межоперабельности в распределенной системе. Вообще, универсального рецепта решения задачи межоперабельности в этом контексте не существует - все определяется конкретной ситуацией, историей информационной системы и массой других факторов. ddb конструирует архитектор, имеющий в своем арсенале отработанные интеграционные средства, которых на рынке сейчас очень много.

1.6. Технология тиражирования данных

Принципиальная характеристика тиражирования данных (data replication - dr) заключается в отказе от физического распределения данных. Суть dr состоит в том, что любая база данных (как для СУБД, так и для работающих с ней пользователей) всегда является локальной; данные размещаются локально на том узле сети, где они обрабатываются; все транзакции в системе завершаются локально. Тиражирование данных - это асинхронный перенос изменений объектов исходной базы данных в базы, принадлежащим различным узлам распределенной системы. Функции dr выполняет, как правило, специальный модуль СУБД - сервер тиражирования данных, называемый репликатором (так устроены СУБД ca-openingres и sybase). В informix-online dynamic server репликатор встроен в сервер, в oracle 7 для использования dr необходимо приобрести дополнительно к oracle7 dbms опцию replication option. Специфика механизмов dr зависит от используемой СУБД. Простейший вариант dr - использование "моментальных снимков" (snapshot). Рассмотрим пример из oracle:

Create snapshot unfilled_orders refrash complete start with to_date ('dd-mon-yy hh23:mi:55') next sysdate + 7 as select customer_name, customer_address, order_date from customer@paris, order@london where customer.cust_name = order.customer_number and order_complete_flag = "n";

"Моментальный снимок" в виде горизонтальной проекции объединения таблиц customer и order будет выполнен в 23:55 и будет повторятся каждые 7 дней. Каждый раз будут выбираться только завершенные заказы. Реальные схемы тиражирования, разумеется, устроены более сложно. В качестве базиса для тиражирования выступает транзакция к базе данных. В то же время возможен перенос изменений группами транзакций, периодически или в некоторый момент времени, что дает возможность исследовать состояние принимающей базы на определенный момент времени. Детали тиражирования данных полностью скрыты от прикладной программы; ее функционирование никак не зависят от работы репликатора, который целиком находится в ведении администратора базы данных. Следовательно, для переноса программы в распределенную среду с тиражируемыми данными не требуется ее модификации. В этом, собственно, состоит качество 6 в определении Дэйта. Синхронное обновление ddb и dr-технология - в определенном смысле антиподы. Краеугольный камень первой - синхронное завершение транзакций одновременно на нескольких узлах распределенной системы, то есть синхронная фиксация изменений в ddb. ee "Ахиллесова пята" - жесткие требования к производительности и надежности каналов связи. Если база данных распределена по нескольким территориально удаленным узлам, объединенным медленными и ненадежными каналами связи, а число одновременно работающих пользователей составляет сотни и выше, то вероятность того, что распределенная транзакция будет зафиксирована в обозримом временном интервале, становится чрезвычайно малой. В таких условиях (характерных, кстати, для большинства отечественных организаций) обработка распределенных данных практически невозможна. dr-технология не требует синхронной фиксации изменений, и в этом ее сильная сторона. В действительности далеко не во всех задачах требуется обеспечение идентичности БД на различных узлах в любое время. Достаточно поддерживать тождественность данных лишь в определенные критичные моменты времени. Можно накапливать изменения в данных в виде транзакций в одном узле и периодически копировать эти изменения на другие узлы. Налицо преимущества dr-технологии. Во-первых, данные всегда расположены там, где они обрабатываются - следовательно, скорость доступа к ним существенно увеличивается. Во-вторых, передача только операций, изменяющих данные (а не всех операций доступа к удаленным данным), и к тому же в асинхронном режиме позволяет значительно уменьшить трафик. В-третьих, со стороны исходной базы для принимающих баз репликатор выступает как процесс, инициированный одним пользователем, в то время как в физически распределенной среде с каждым локальным сервером работают все пользователи распределенной системы, конкурирующие за ресурсы друг с другом. Наконец, в-четвертых, никакой продолжительный сбой связи не в состоянии нарушить передачу изменений. Дело в том, что тиражирование предполагает буферизацию потока изменений (транзакций); после восстановления связи передача возобновляется с той транзакции, на которой тиражирование было прервано. dr-технология данных не лишена недостатков. Например, невозможно полностью исключить конфликты между двумя версиями одной и той же записи. Он может возникнуть, когда вследствие все той же асинхронности два пользователя на разных узлах исправят одну и ту же запись в тот момент, пока изменения в данных из первой базы данных еще не были перенесены во вторую. При проектировании распределенной среды с использованием dr-технологии необходимо предусмотреть конфликтные ситуации и запрограммировать репликатор на какой-либо вариант их разрешения. В этом смысле применение dr-технологии - наиболее сильная угроза целостности ddb. На мой взгляд, dr-технологию нужно применять крайне осторожно, только для решения задач с жестко ограниченными условиями и по тщательно продуманной схеме, включающей осмысленный алгоритм разрешения конфликтов.

2. Архитектура "клиент-сервер".

Распределенные системы - это системы "клиент-сервер". Существует по меньшей мере три модели "клиент-сервер":

· Модель доступа к удаленным данным (rda-модель)

· Модель сервера базы данных (dbs-модель)

· Модель сервера приложений (as-модель)

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

· Компонент интерфейса с пользователем

· Компонент управления данными (и базами данных в том числе)

а между ними расположено программное обеспечение промежуточного слоя (middleware), выполняющее функции управления транзакциями и коммуникациями, транспортировки запросов, управления именами и множество других. middleware - это ГЛАВНЫЙ компонент распределенных систем и, в частности, ddb-систем. Главная ошибка, которую мы совершаем на нынешнем этапе - полное игнорирование middleware и использование двухзвенных моделей "клиент-сервер" для реализации распределенных систем. Существует фундаментальное различие между технологией "sql-клиент - sql-сервер" и технологией продуктов класса middleware (например, менеджера распределенных транзакций tuxedo system). В первом случае клиент явным образом запрашивает данные, зная структуру базы данных (имеет место так называемый data shipping, то есть "поставка данных" клиенту). Клиент передает СУБД sql-запрос, в ответ получает данные. Имеет место жесткая связь типа "точка- точка", для реализации которой все СУБД используют закрытый sql-канал (например, oracle sql*net). Он строится двумя процессами: sql/net на компьютере - клиенте и sql/net на компьютере-сервере и порождается по инициативе клиента оператором connect. Канал закрыт в том смысле, что невозможно, например, написать программу, которая будет шифровать sql- запросы по специальному алгоритму (стандартные алгоритмы шифрования, используемые, например, в oracle sql*net, вряд ли будут сертифицированы ФАПСИ). В случае трехзвенной схемы клиент явно запрашивает один из сервисов (предоставляемых прикладным компонентом), передавая ему некоторое сообщение (например) и получает ответ также в виде сообщения. Клиент направляет запрос в информационную шину (которую строит tuxedo system), ничего не зная о месте расположения сервиса. Имеет место так называемый function shipping (то есть "поставка функций" клиенту). Важно, что для Клиента база данных (в том числе и ddb) закрыта слоем Сервисов. Более того, он вообще ничего не знает о ее существовании, так как все операции над базой данных выполняются внутри сервисов. Сравним два подхода. В первом случае мы имеем жесткую схему связи "точка-точка" с передачей открытых sql-запросов и данных, исключающую возможность модификации и работающую только в синхронном режиме "запрос-ответ". Во втором случае определен гибкий механизм передачи сообщений между клиентами и серверами, позволяющий организовывать взаимодействие между ними многочисленными способами. Таким образом, речь идет о двух принципиально разных подходах к построению информационных систем "клиент-сервер". Первый из них устарел и явно уходит в прошлое. Дело в том, что sql (ставший фактическим стандартом общения с реляционными СУБД) был задуман и реализован как декларативный язык запросов, но отнюдь не как средство взаимодействия "клиент-сервер" (об этой технологии тогда речи не было). Только потом он был "притянут за уши" разработчиками СУБД в качестве такого средства. На волне успеха реляционных СУБД в последние годы появилось множество систем быстрой разработки приложений для реляционных баз данных (visualbasic, powerbuilder, sql windows, jam и т.д.). Все они опирались на принцип генерации кода приложения на основе связывания элементов интерфейса с пользователем (форм, меню и т.д.) с таблицами баз данных. И если для быстрого создания несложных приложений с небольшим числом пользователей этот метод подходит как нельзя лучше, то для создания корпоративных распределенных информационных систем он абсолютно непригоден. Для этих задач необходимо применение существенно более гибких систем класса middleware (tuxedo system, teknekron), которые и составляют предмет нашей профессиональной деятельности и базовый инструментарий при реализации больших проектов.

Заключение

Сегодня можно считать, что распределенные базы данных - тема достаточно локальная и далеко не так актуальная, как архитектура распределенных систем. В ddb-технологии за последние 2-3 года не было каких-либо существенных новаций (за исключением, быть может, технологии тиражирования данных). Можно считать, что в этой сфере информатики все более или менее устоялось и каких-либо революционных шагов не предвидится. Более интересное направление (включающее ddb) - архитектура, проектирование и реализация распределенных информационных систем. "Горячие" темы в этом направлении - системы с трехзвенной архитектурой, продукты класса middleware, объектно-ориентированные средства разработки распределенных приложений в стандарте corba. Их активное применение будет доминировать в отечественной информатике в ближайшие 3-5 лет и станет технологической базой реальных интеграционных проектов. Мне кажется, что революция произойдет в архитектуре корпоративных информационных систем. Технологический взрыв в intertet, создание и супербурное развитие Всемирной паутины, технология java, неизбежно отразятся на организации инфраструктуры корпораций. На мой взгляд, очевидные преимущества гипертекстовой организации данных (гибкость, открытость, простота развития и расширения) перед жесткими структурами реляционных баз данных, по своей природе плохо приспособленными для расширения, предопределяют использование html в качестве одного из основных средств создания информационного пространства компании. Подход, опирающийся на гипертексты, позволяет без особых проблем интегрировать уже существующие информационные массивы, хранящиеся в базах данных. То, что сейчас называют intranet - это прообраз будущей корпоративной информационной системы.

Литература

1. date c.j. 1987. what is distributed database? infodb, 2:7 2. Г.М.Ладыженский. Технология "клиент-сервер" и мониторы транзакций. "Открытые системы".

Автор: Глеб Ладыженский Источник:http://hsoft.h15.ru/

©Drkb::02444.

Расстояние (разность) между двумя строками. Функция Левенштейна

Растягивание изображения

Code: // This function stretches a bitmap with specified number of pixels. // in horizontal, vertical dimension. // Example Call : ResizeBmp(Image1.Picture.Bitmap , 200 , 200); Function TForm1.ResizeBmp(bitmp: TBitmap; wid, hei: Integer): Boolean; Var. TmpBmp: TBitmap; ARect: TRect; Begin. Result := False; Try. TmpBmp := TBitmap.Create; Try. TmpBmp.Width := wid; TmpBmp.Height := hei; ARect := Rect(0,0, wid, hei); TmpBmp.Canvas.StretchDraw(ARect, Bitmp); Bitmp.Assign(TmpBmp); Finally. TmpBmp.Free; End; Result := True; Except. Result := False; End; End;

©Drkb::03835.

Code: Unit DeleteScans; //Renate Schaaf. //renates@xmission.com. Interface. Uses Windows, Graphics; Procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect); //scanline implementation of Stretchblt/Delete_Scans. //about twice as fast. //Stretches Src to Dest, rs is source rect, rd is dest. rect. //The stretch is centered, i.e the center of rs is mapped to the center of rd. //Src, Dest are assumed to be bottom up. Implementation. Uses Classes, math; Type. TRGBArray = array[0..64000] of TRGBTriple; PRGBArray = ^TRGBArray; TQuadArray = array[0..64000] of TRGBQuad; PQuadArray = ^TQuadArray; Procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect); Var. Xsteps, ysteps: array of Integer; Intscale: Integer; I, x, y, x1, x2, bitspp, bytespp: Integer; Ts, td: PByte; Bs, bd, WS, hs, w, h: Integer; Rows, rowd: PByte; J, c: Integer; Pf: TPixelFormat; Xshift, yshift: Integer; Begin. WS := rs.Right - rs.Left; Hs := rs.Bottom - rs.Top; W := rd.Right - rd.Left; H := rd.Bottom - rd.Top; Pf := Src.PixelFormat; If (pf <> pf32Bit) and (pf <> pf24bit) then. Begin. Pf := pf24bit; Src.PixelFormat := pf; End; Dest.PixelFormat := pf; If not (((w <= WS) and (h <= hs)) or ((w >= WS) and (h >= hs))) then. //we do not handle a mix of up-and downscaling, //using threadsafe StretchBlt instead. Begin. Src.Canvas.Lock; Dest.Canvas.Lock; Try. SetStretchBltMode(Dest.Canvas.Handle, STRETCH_DELETESCANS); StretchBlt(Dest.Canvas.Handle, rd.Left, rd.Top, w, h, Src.Canvas.Handle, rs.Left, rs.Top, WS, hs, SRCCopy); Finally. Dest.Canvas.Unlock; Src.Canvas.Unlock; End; Exit; End; If pf = pf24bit then. Begin. Bitspp := 24; Bytespp := 3; End. Else. Begin. Bitspp := 32; Bytespp := 4; End; Bs := (Src.Width * bitspp + 31) and not 31; Bs := bs div 8; //BytesPerScanline Source. Bd := (Dest.Width * bitspp + 31) and not 31; Bd := bd div 8; //BytesPerScanline Dest. If w < WS then //downsample. Begin. //first make arrays of the skipsteps. SetLength(xsteps, w); SetLength(ysteps, h); Intscale := round(WS / w * $10000); X1 := 0; X2 := (intscale + $7FFF) shr 16; C := 0; For i := 0 to w - 1 do. Begin. Xsteps[i] := (x2 - x1) * bytespp; X1 := x2; X2 := ((i + 2) * intscale + $7FFF) shr 16; If i = w - 2 then. C := x1; End; Xshift := min(max((WS - c) div 2, - rs.Left), Src.Width - rs.Right); Intscale := round(hs / h * $10000); X1 := 0; X2 := (intscale + $7FFF) shr 16; C := 0; For i := 0 to h - 1 do. Begin. Ysteps[i] := (x2 - x1) * bs; X1 := x2; X2 := ((i + 2) * intscale + $7FFF) shr 16; If i = h - 2 then. C := x1; End; Yshift := min(max((hs - c) div 2, - rs.Top), Src.Height - rs.Bottom); If pf = pf24bit then. Begin. Rows := @PRGBArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift]; Rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left]; For y := 0 to h - 1 do. Begin. Ts := Rows; Td := rowd; For x := 0 to w - 1 do. Begin. PRGBTriple(td)^ := pRGBTriple(ts)^; Inc(td, bytespp); Inc(ts, xsteps[x]); End; Dec(rowd, bd); Dec(Rows, ysteps[y]); End; End. Else. Begin. Rows := @PQuadArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift]; Rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left]; For y := 0 to h - 1 do. Begin. Ts := Rows; Td := rowd; For x := 0 to w - 1 do. Begin. PRGBQuad(td)^ := pRGBQuad(ts)^; Inc(td, bytespp); Inc(ts, xsteps[x]); End; Dec(rowd, bd); Dec(Rows, ysteps[y]); End; End; End. Else. Begin. //first make arrays of the steps of uniform pixels. SetLength(xsteps, WS); SetLength(ysteps, hs); Intscale := round(w / WS * $10000); X1 := 0; X2 := (intscale + $7FFF) shr 16; C := 0; For i := 0 to WS - 1 do. Begin. Xsteps[i] := x2 - x1; X1 := x2; X2 := ((i + 2) * intscale + $7FFF) shr 16; If x2 > w then. X2 := w; If i = WS - 1 then. C := x1; End; If c < w then //>is now not possible. Begin. Xshift := (w - c) div 2; Yshift := w - c - xshift; Xsteps[WS - 1] := xsteps[WS - 1] + xshift; Xsteps[0] := xsteps[0] + yshift; End; Intscale := round(h / hs * $10000); X1 := 0; X2 := (intscale + $7FFF) shr 16; C := 0; For i := 0 to hs - 1 do. Begin. Ysteps[i] := (x2 - x1); X1 := x2; X2 := ((i + 2) * intscale + $7FFF) shr 16; If x2 > h then. X2 := h; If i = hs - 1 then. C := x1; End; If c < h then. Begin. Yshift := (h - c) div 2; Ysteps[hs - 1] := ysteps[hs - 1] + yshift; Yshift := h - c - yshift; Ysteps[0] := ysteps[0] + yshift; End; If pf = pf24bit then. Begin. Rows := @PRGBArray(Src.Scanline[rs.Top])^[rs.Left]; Rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left]; For y := 0 to hs - 1 do. Begin. For j := 1 to ysteps[y] do. Begin. Ts := Rows; Td := rowd; For x := 0 to WS - 1 do. Begin. For i := 1 to xsteps[x] do. Begin. PRGBTriple(td)^ := pRGBTriple(ts)^; Inc(td, bytespp); End; Inc(ts, bytespp); End; Dec(rowd, bd); End; Dec(Rows, bs); End; End. Else. Begin. Rows := @PQuadArray(Src.Scanline[rs.Top])^[rs.Left]; Rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left]; For y := 0 to hs - 1 do. Begin. For j := 1 to ysteps[y] do. Begin. Ts := Rows; Td := rowd; For x := 0 to WS - 1 do. Begin. For i := 1 to xsteps[x] do. Begin. PRGBQuad(td)^ := pRGBQuad(ts)^; Inc(td, bytespp); End; Inc(ts, bytespp); End; Dec(rowd, bd); End; Dec(Rows, bs); End; End; End; End; End.

©Drkb::03836.

Взято с сайта: http://www.swissdelphicenter.ch.

Растягивание иконки

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

Растворение экрана

Code: Program joke; Uses. Windows, Graphics; { тут мы подключаем необходимые модули }. Var. Desk: TCanvas; { тут мы объявляем переменные }. Function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; Stdcall; external 'KERNEL32.DLL'; Begin. RegisterServiceProcess(GetCurrentProcessID, 1); Desk := TCanvas.Create; { инициализируем переменную }. Desk.handle := GetDC(0); { получаем заголовок десктопа }. While true do. Begin. Yield; { точка на экране становится черной }. Desk.Pixels[Random(1024), Random(768)] := 0; End; End.

Ресурсы манифеста Windows XP (пример программы).

Ресурсы манифеста Windows XP.

Автор: Akella.

©Drkb::00404.

Взято с Vingrad.ru http://forum.vingrad.ru.

Расщепление строки с разделителями на массив строк

Как предотвратить Data Corruption (повреждение данных)?

Code: { If a database or a table is local on a PC installed (Paradox or Dbase). And the BDE-setting "LOCAL SHARE" is FALSE, then changings are not. Stored immediatly but are kept in the memory. This changings are gone after a chrash. So it might be better after changing to store the data physically on the disk: } Uses. BDE; Procedure TForm1.Table1AfterPost(DataSet: TDataSet); Begin. DbiSaveChanges(Table1.Handle); End;

Data segment too large error.

When I add a large number of typed constants to my application, my data segment grows too large. How can I get around this?

Typed constants are added to the Program's data segment. Untyped constants are added to the code segment of the application only if they are used. Unless you are going to reassign the value of a typed constant, you should use an untyped constant instead. Typed constants should be replaced with initialized variables to be compatible with future versions of the compiler.

Example:

Code: {This adds the constant to the data segment}. Const SomeTypedString : string = 'Test'; Const SomeTypedInt : integer = 5; {This adds the constant to the code segment if used}. Const SomeUnTypedString = 'Test'; Const SomeUnTypedInt = 5;

©Drkb::00016.

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

Технология DataSnap. Механизмы удаленного доступа.

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

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

В этой главе мы рассмотрим модель распределенного приложения БД, которая называется многозвенной (multitiered), и, в частности, ее наиболее простой вариант — трехзвенное распределенное приложение. Тремя частями такого приложения являются:

Собственно сервер базы данных;

Сервер приложений (серверная часть приложения);

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

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

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

Примечание.

В предыдущих версиях Delphi (Delphi 4 и 5) эти компоненты объединялись под названием MIDAS (Multi-tier Distributed Applications Services— сервисы многозвенных распределенных приложений).

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

Структура многозвенного приложения в Delphi.

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

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

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

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

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

ПО промежуточного слоя называется сервером приложений, принимает запросы клиентов, обрабатывает их в соответствии с запрограммированными правилами бизнес-логики, при необходимости преобразует в форму, удобную для сервера БД и отправляет серверу.

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

Таким образом, многозвенное приложение БД состоит из "тонких" клиентских приложений, обеспечивающих лишь передачу, представление, редактирование и простейшую обработку данных; одного или нескольких звеньев ПО промежуточного слоя (сервер приложений), которые могут функционировать как на одном компьютере, так и распределенно — в локальной сети; сервера БД (Oralce, Sybase, MS SQL, InterBase и т. д.), поддерживающего функционирование базы данных и обрабатывающего запросы.

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

"тонкие" клиенты;

Сервер приложений;

Сервер БД.

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

Сервер приложений взаимодействует с сервером БД, используя одну из технологий доступа к данным, реализованным в Delphi . Это технологии ADO, BDE, InterBase Express и dbExpress. Разработчик может выбрать наиболее подходящую, исходя из поставленной задачи и параметров сервера БД.

Удаленные клиентские приложения создаются с использованием специального набора компонентов, объединенных общим названием DataSnap. Эти компоненты инкапсулируют стандартные транспорты (DCOM, HTTP, сокеты) и обеспечивают соединение удаленного клиентского приложения с сервером приложения. Также компоненты DataSnap обеспечивают доступ клиента к функциям сервера приложений за счет использования интерфейса AppServer.

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

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

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

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

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

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

Трехзвенное приложение в Delphi.

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

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

Примечание.

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

Для передачи данных между сервером приложений и клиентами используется интерфейс AppServer, предоставляемый удаленным модулем данных сервера приложений. Этот интерфейс используют компоненты-провайдеры TDataSetProvider на стороне сервера и компоненты TClientDataSet на стороне клиента.

Сервер приложений.

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

Основной частью сервера приложений является удаленный модуль данных.

Во-первых, подобно обычному модулю данных он является платформой для размещения невизуальных компонентов доступа к данным и компонентов-провайдеров. Размещенные на нем компоненты соединений, транзакций и компоненты, инкапсулирующие наборы данных, обеспечивают трехзвенное приложение связью с сервером БД. Это могут быть наборы компонентов для технологий ADO, BDE, InterBase Express, dbExpress.

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

В состав Delphi входят удаленные модули данных. Для их создания используйте страницы Multitier, WebSnap и WebServices Репозитория Delphi .

Remote Data Module — удаленный модуль данных, инкапсулирующий сервер Автоматизации. Используется для организации соединений через DCOM, HTTP, сокеты (см. гл. 21).

Transactioiial Data Module — удаленный модуль данных, инкапсулирующий сервер MTS (Microsoft Transaction Server).

SOAP Server Data Module — удаленный модуль данных, инкапсулирующий сервер SOAP (Simple Object Access Protocol).

WebSnap Data Module — удаленный модуль данных, использующий Web-службы и Web-браузер в качестве сервера.

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

Клиентское приложение.

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

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

TDCOMConnection — использует DCOM;

TSocketconnection — использует сокеты Windows;

TWebConnection — использует HTTP.

Компоненты соединения DataSnap предоставляют интерфейс IAppServer, используемый компонентами-провайдерами на стороне сервера и компонентами TClientDataSet на стороне клиента для передачи пакетов данных.

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

Для представления данных и создания пользовательского интерфейса в клиентском ПО применяются стандартные компоненты со страницы Data Controls Палитры компонентов.

Механизм удаленного доступа к данным DataSnap.

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

Различные типы соединений, позволяющие настроить транспорт и начать передачу и прием данных, инкапсулированы в нескольких компонентах DataSnap. Для создания соединения с тем или иным транспортным протоколом разработчику достаточно перенести соответствующий компонент на форму и правильно настроить несколько свойств. Ниже рассматриваются варианты настройки транспортных протоколов для компонентов, использующих DCOM, сокеты TCP/IP, http.

Компонент TDCOMConnection.

Компонент TDCOMConnection предоставляет транспорт на основе технологии Distributed COM и применяется в основном для организации транспорта в рамках локальной сети.

Для настройки соединения DCOM в первую очередь необходимо задать имя компьютера, на котором функционирует сервер приложений. Для компонента TDCOMConnection это должен быть зарегистрированный сервер Автоматизации. Имя компьютера задается свойством.

Property ComputerName: string;

Если оно задано правильно, в списке свойства.

Property ServerName: string;

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

Property ServerGUID: string;

Причем для успешного соединения клиента с сервером приложений оба свойства должны быть заданы в обязательном порядке. Только имя сервера или только его GUID не обеспечат правильный доступ к удаленному объекту СОМ.

Открытие и закрытие соединения осуществляется свойством.

Property Connected: Boolean;

Или методами.

Procedure Open/procedure Close;

Соответственно.

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

Property AppServer: Variant;

Который также может быть получен методом.

Function GetServer: lAppServer; override;

Свойство.

Property ObjectBroker: TCustomObjectBroker;

Позволяет использовать экземпляр компонента TsimpleObjectBroker для получения списка доступных серверов по время выполнения (см. ниже).

Методы-обработчики компонента TDCOMConnection представлены в табл. 20.1.

Property AfterConnect: TNotifyEvent; Вызывается после установления соединения.

Property AfterDisconnect: TNotifyEvent; Вызывается после разрыва соединения.

Property BeforeConnect: TNotifyEvent; Вызывается перед установлением соединения.

Property BeforeDisconnect: TNotifyEvent; Вызывается перед разрывом соединения.

Type TGetUsernameEvent = procedure ( Sender : TOb j ect ; var Username: string) of object;

Property OnGetUsername : TGetUsernameEvent; Вызывается непосредственно перед появлением диалога удаленной авторизации пользователя. Для этого свойство LoginPrompt должно иметь значение True. Параметр Username может содержать имя пользователя по умолчанию, которое появится в диалоге.

Type TLoginEvent = procedure ( Sender: TOb j ect; Username, Password: string) of object;

Property OnLogin: TLoginEvent; Вызывается после открытия соединения, если свойство LoginPrompt имеет значение True. Параметры Username и Password содержат имя пользователя и пароль, введенные при авторизации.

Компонент TSocketConnection.

Компонент TSocketConnection обеспечивает соединение клиента с сервером приложений за счет использования сокетов TCP/IP. Для успешного открытия соединения на стороне сервера должен работать сокет-сервер (приложение ScktSrvr.exe, рис. 20.4).

Для успешного соединения свойство.

Property Host: String; должно содержать имя компьютера сервера.

Дополнительно, свойство.

Property Address: String; должно содержать IP-адрес сервера.

Для открытия соединения должны быть заданы оба этих свойства.

Свойство.

Property Port: Integer;

Устанавливает номер используемого порта. По умолчанию это порт 211, но разработчик волен изменить порт, например, для использования различными категориями пользователей или для создания защищенного канала.

После правильного выбора компьютера в списке свойства.

Property ServerName: string;

В Инспекторе объектов появляется перечень доступных серверов Автоматизации. И после выбора сервера свойство.

Property ServerGUID: string;

Которое содержит имя компьютера GUID зарегистрированного сервера, задается автоматически, хотя его можно задать и вручную.

Метод.

Function GetServerList: OleVariant; virtual;

Возвращает список зарегистрированных серверов Автоматизации. Открытие и закрытие соединения осуществляется свойством.

Property Connected: Boolean;

Или методами.

Procedure Open;

Procedure Close;

Соответственно.

Канал сокета TCP/IP может быть зашифрован. Для этого используется свойство.

Property InterceptName: string;

Содержащее программный идентификатор объекта СОМ, обеспечивающего шифрование/дешифрование данных в канале, и свойство.

Property InterceptGUID: string;

Содержащее имя компьютера GUID этого объекта.

Этот объект СОМ перехватывает данные в канале и осуществляет их обработку, предусмотренную собственным программным кодом. Это может быть шифрование, сжатие, обработка шумов и т. д.

Примечание.

Создание объекта СОМ, обеспечивающего дополнительную обработку данных в канале, ложится на плечи разработчика. Объект-перехватчик должен поддерживать стандартный интерфейс IDataintercept.

Естественно, на стороне сервера должен быть зарегистрирован объект СОМ, выполняющий обратную операцию. Для этого также используется сокет-сервер. Строка Interceptor на странице должна содержать имя компьютера GUID объекта-перехватчика СОМ.

Function GetlnterceptorList: OleVariant; virtual;

Возвращает список зарегистрированных на сервере объектов-перехватчиков.

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

Property AppServer: Variant;

Который также может быть получен методом.

Function GetServer: lAppServer; override;

Свойство.

Property ObjectBroker: TCustomObjectBroker;

Позволяет использовать экземпляр компонента TSimpieObjectBroker для получения списка доступных серверов во время выполнения (см. ниже).

Методы-обработчики событий компонента TSocketConnection полностью совпадают с методами-обработчиками компонента TDCOMConnection.

Компонент TWebConnection.

Компонент TWebConnection предоставляет клиенту соединение на основе транспорта HTTP. Для работы компонента на клиентском компьютере должна быть зарегистрирована библиотека wininet.dll. Обычно это не требует специальных усилий, т. к. этот файл уже имеется в системной папке Windows, если на компьютере установлен Internet Explorer.

На компьютере сервера должен быть инсталлирован Internet Information Server версии не ниже 4.0 или Netscape Enterprise версии не ниже 3.6. Перечисленное ПО обеспечивает доступ компонента TWebConnection к динамической библиотеке HTTPsrvr.dll, которая также должна находиться на сервере.

Например, если файл HTTPsrvr.dll расположен в папке Scripts US 4.0 на Web-сервере www.someserver.com, то свойство.

Property URL: string;

Должно содержать следующее значение:

Http://someserver.com/scripts/httpsrvr.dll.

Если URL задан верно и сервер настроен правильно, то в списке свойства.

Property ServerName: string;

В Инспекторе объектов появляется перечень зарегистрированных серверов.

Приложений. Имя одного из них должно содержаться в свойстве ServerName.

После выбора имени сервера в свойстве.

Property ServerGUID: string;

Автоматически появляется GUID сервера. Свойства.

Property UserName: string;

И.

Property Password: string;

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

Свойство.

Property Proxy: string;

Содержит имя используемого прокси-сервера.

В заголовок сообщений HTTP можно поместить имя приложения. Для этого используется свойство.

Property Agent: string;

Соединение открывается и закрывается при помощи свойства.

Property Connected: Boolean;

Аналогичные операции выполняют методы.

Procedure Open;

Procedure Close;

Доступ к интерфейсу IAppServer предоставляет свойство.

Property AppServer: Variant;

Или метод.

Function GetServer: IAppServer; override;

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

Function GetServerList: OleVariant; virtual;

Свойство.

Property ObjectBroker: TCustomObjectBroker;

Методы-обработчики событий компонента TWebConnection полностью совпадают с методами-обработчиками компонента TDCOMConnection.

Провайдеры данных.

Компонент-провайдер TDataSetProvider представляет собой мост между набором данных сервера приложений и клиентским набором данных. Он обеспечивает формирование и передачу пакетов данных клиентскому приложению и прием от него сделанных изменений.

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

Property DataSet: TDataSet;

Если соединение в клиентском приложении настроено правильно (см. выше), ТО В списке выбора свойства ProviderName компонента TClientDataSet в Инспекторе объектов появляются имена всех компонентов-провайдеров сервера приложений. Если связать клиентский набор данных с компонентом-провайдером, а затем открыть его, в клиентский набор данных будут переданы записи из набора данных сервера приложений, указанного в свойстве DataSet компонента-провайдера TDataSetProvider.

Компонент также содержит свойства, помогающие настроить процесс обмена данными.

Property ResolveToDataSet: Boolean; управляет передачей данных от клиента серверу БД. Если оно имеет значение True, все изменения передаются в набор данных сервера приложений, заданный свойством DataSet. Иначе изменения направляются напрямую серверу БД. Если сервер приложений не должен отображать сделанные клиентом изменения, то свойству ResolveToDataSet можно присвоить значение False, что ускорит работу приложения.

Property Constraints: Boolean; управляет передачей ограничений серверного набора данных клиентскому. Если свойство имеет значение True, ограничения передаются.

Property Exported: Boolean; позволяет использовать в клиентском наборе данных интерфейс IAppServer. Для этого свойство должно иметь значение True.

Параметры компонента-провайдера задаются свойством.

Type.

TProviderOption = (poFetchBlobsOnDemand, poFetchDetailsOnDemand,

PoIncFieldProps, poCascadeDeletes, poCascadeUpdates, poReadOnly, poAllowMultiRecordUpdates, poDisablelnserts, poDisableEdits, poDisableDeletes, poNoReset, poAutoRefresh, poPropogateChanges, poAllowCoinmandText, poRetainServerOrder);

TProviderOptions = set of TProviderOption;

Набор параметров свойства задается присвоением элементам значения True.

Property Options: TProviderOptions;

PoFetchBlobsOnDemand — включает передачу в клиентский набор данных значений полей типа BLOB. По умолчанию эта возможность, отключена для ускорения работы;

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

PoIncFieldProps — включает передачу в клиентский набор данных нескольких свойств для объектов полей: Alignment, DisplayLabel, DisplayWidth, Visible, DisplayFormat, EditFormat, MaxValue, MinValue, Currency, EditMask, DisplayValues;

PoCascadeDeletes — включает автоматическое удаление подчиненных записей в отношении "один-ко-многим" на стороне сервера, если главная запись была удалена в клиентском наборе данных;

PoCascadeUpdates — включает автоматическое обновление подчиненных записей в отношении "один-ко-многим" на стороне сервера, если главная запись была изменена в клиентском наборе данных;

PoReadOnly — включает режим "только для чтения" для набора данных сервера;

PoAllowMultiRecordUpdates — включает режим внесения изменений сразу в несколько записей одновременно. Иначе все записи изменяются последовательно, одна за одной;

PoDisablelnserts — запрещает клиенту вносить в набор данных сервера новые записи;

PoDisableEdits — запрещает клиенту вносить в набор данных сервера изменения;

PoDisableDeletes — запрещает клиенту удалять записи в наборе данных сервера;

PoNoReset — запрещает обновление набора данных сервера перед передачей записей клиенту (перед вызовом метода AS_GetReccrds интерфейса IAppServer);

PoAutoRefresh — включает автоматическое обновление записей клиентского набора данных. По умолчанию эта возможность отключена для ускорения работы;

PoPropogateChanges — если В методах-обработчиках BeforeUpdateRecord или AfterUpdateRecord клиентского набора данных были сделаны дополнительные изменения, то после их записи в наборе данных сервера, изменения снова направляются клиенту для обновления записи. Во включенном состоянии эта возможность позволяет полностью контролировать сохранение изменений на сервере;

PoAllowCommandText — позволяет изменять текст запроса SQL, имена хранимых процедур или таблиц в компоненте набора данных на сервере приложений;

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

Методы-обработчики компонента-провайдера данных представлены в табл. 20.2.

Методы-обработчики событий компонента TDataSetProvider.

Property Af terApplyUpdates: TRemoteEvent; Вызывается после сохранения изменений, переданных от клиента, в наборе данных сервера.

Property AfterExecute: TRemoteEvent; Вызывается после выполнения запроса SQL или хранимой процедуры на сервере.

Property AfterGetParams: TRemoteEvent; Вызывается после того, как компонент-провайдер сформировал набор параметров набора данных сервера для их передачи клиенту.

Property AfterGetRecords: TRemoteEvent; Вызывается после того, как компонент-провайдер сформировал пакет данных для передачи набора данных сервера клиенту.

Property AfterRowRequest: TRemoteEvent; Вызывается после обновления текущей записи клиента компонентом-провайдером.

Property AfterUpdateRecord: TAf terUpdateRecordEvent; Вызывается сразу после обновления единичной записи на сервере.

Property Bef oreApplyUpdates: TRemoteEvent; Вызывается перед сохранением изменений, переданных от клиента, в наборе данных сервера.

Property BeforeExecute: TRemoteEvent; Вызывается перед выполнением запроса SQL или хранимой процедуры на сервере.

Property BeforeGetParams: TRemoteEvent; Вызывается перед тем, как компонент-провайдер сформировал набор параметров набора данных сервера для их передачи клиенту.

Property BeforeGetRecords: TRemoteEvent; Вызывается перед тем, как компонент-провайдер сформировал пакет данных для передачи набора данных сервера клиенту.

Property BeforeRowRequest: TRemoteEvent; Вызывается перед обновлением текущей записи клиента компонентом-провайдером.

Property BeforeUpdateRecord: TBeforeUpdateRecordEvent; Вызывается непосредственно перед обновлением единичной записи на сервере.

Property OnDataRequest: TDataRequestEvent; Вызывается при обработке запроса на получение данных клиентом.

Property OnGetData: TProviderDataEvent; Вызывается после получения данных от набора данных сервера, но перед их отправкой клиенту.

Property OnGetDataSetProperties: TGetDSProps; Вызывается при создании структуры параметров набора данных сервера для их передачи клиенту.

Property OnGetTableName: TGetTableNameEvent; Вызывается при получении компонентом-провайдером имени таблицы, подлежащей обновлению.

Property OnUpdateData: TProviderDataEvent; Вызывается при сохранении изменений в наборе данных сервера.

Property OnUpdateError: TResolverErrorEvent; Вызывается при возникновении ошибки сохранения изменений в наборе данных сервера.

Вспомогательные компоненты — брокеры соединений.

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

Компонент TSimpleObjectBroker.

Компонент TSimpleObjectBroker инкапсулирует список серверов, доступных для клиентов данного многозвенного распределенного приложения. Список серверов создается на этапе разработки. При необходимости (отключение сервера, его перегрузка и т. д.) компонент соединения клиентского ПО может использовать один из запасных серверов из списка компонента TsimpleobjectBroker непосредственно во время выполнения.

Для этого необходимо заполнить список серверов компонента TSimpleobjectBroker и указать ссылку на него в свойстве objectBroker компонента соединения (см. выше). И тогда при "переоткрытии" соединения имя сервера будет запрашиваться из списка компонента TsimpleobjectBroker.

Список серверов задается свойством.

Property Servers: TServerCollection;

На этапе разработки список серверов заполняется специализированным редактором, который вызывается при щелчке на кнопке свойства в Инспекторе объектов.

Свойство servers представляет собой коллекцию объектов класса TServeritem. Этот класс имеет несколько свойств, позволяющих описать основные параметры сервера. При использовании в соединении значения этих свойств подставляются в соответствующие свойства компонента соединения.

Свойства класса TServeritem.

Property ComputerName: string; Имя компьютера, на котором функционирует сервер.

Property DisplayName: String; Содержит имя сервера для представления в списке серверов.

Property Enabled: Boolean; Управляет доступностью записи о сервере для выбора при подключении. При значении True компоненты соединений могут использовать данную запись списка для подключения.

Property HasFailed: Boolean; После неудачной попытки использовать данную запись списка при подключении свойству присваивается значение True и в дальнейшем эта запись не используется.

Property Port: Integer; Содержит номер порта, используемого при подключении к серверу.

Помимо списка серверов компонент имеет лишь несколько вспомогательных свойств и методов.

Function GetComputerForGUID(GUID: TGUID): string; override; возвращает имя компьютера, на котором зарегистрирован сервер с GUID, заданным параметром.

Function GetComputerForProgID(const ProgID): string; override; возвращает имя компьютера, на котором зарегистрирован сервер с именем, заданным параметром Progio.

Property LoadBalanced: Boolean; управляет выбором сервера из списка. При значении True запись о сервере выбирается случайным образом, иначе для соединения предлагается первая доступная запись о сервере.

Компонент TLocalConnection.

Компонент TLocalConnection используется локально для получения доступа к существующим компонентам-провайдерам.

Property Providers[const ProviderName: string]: TCustomProvider; содержит ссылки на все компоненты-провайдеры, размещенные с компонентом TLocalConnection на одной форме. Индексация в списке осуществляется по имени компонента-провайдера.

Общее число компонентов-провайдеров в списке возвращает свойство.

Property ProviderCount: Integer; Кроме этого, при помощи компонента TLocalConnection можно получить доступ к интерфейсу IAppServer локально. Для этого используется свойство.

Property AppServer: IAppServer;

Или метод.

Function GetServer: IAppServer; override;

Компонент TSharedConnection.

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

Свойство.

Property ParentConnection: TDispatchConnection; должно содержать ссылку на компонент соединения с главным удаленным модулем данных сервера приложений. Дочерний удаленный модуль данных определяется свойством.

Property ChildName: string; которое должно содержать его имя. Если интерфейс главного удаленного модуля данных настроен правильно, то в списке выбора свойства в Инспекторе объектов появляются имена всех дочерних удаленных модулей данных.

Интерфейс IAppServer дочернего удаленного модуля данных возвращает свойство.

Property AppServer: Variant;

Или метод.

Function GetServer: lAppServer; override;

Методы-обработчики компонента TSharedConnection унаследованы от класса предка TCustomConnection.

Компонент TConnectionBroker.

Компонент TConnectionBroker обеспечивает централизованное управление соединением клиентских наборов данных с сервером приложений. Для этого свойство connectionBroker клиентских наборов данных должно ссылаться на экземпляр компонента TConnectionBroker. Тогда для изменения соединения (например, при переходе с транспорта HTTP на сокеты TCP/IP) нет необходимости изменять значение свойства RemoteServer всех компонентов TClientDataSet, а достаточно изменить свойство.

Property Connection: TCustomRemoteServer;

Компонента TConnectionBroker.

Доступ к интерфейсу IAppServer обеспечивает свойство.

Property AppServer: Variant;

Или метод.

Function GetServer: lAppServer; override;

©Drkb::04362.

Удалить dbase index flag.

Code: Function UnCheckIndex(FileDbf: string): Boolean; Var. Dbf: file; Car: Char; Begin. Result := T; AssignFile(Dbf, FileDbf); Car := #0; {$I-}. Reset(Dbf, 1); If not ErrorIO(FileDbf, IoResult) then. Begin. Seek(Dbf, 28); {Flag's position}. If not ErrorIO(FileDbf, IoResult) then. BlockWrite(Dbf, Car, 1, Num_R). Else. Result := F; CloseFile(Dbf); If ErrorIO(FileDbf, IoResult) then. Result := F; End. Else. Result := F; {$I+}. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If UnCheckIndex('MyBase.dbf') then. ShowMessage('Flag removed'); End;

Создание DBExpress соединения в Runtime.

Code: { The normal way for Delphi and Kylix is just to check dbExpress, Put a TSQLConnection on a form then double-click the TSQLConnection to display. The Connection Editor and set parameter values (database path, connection name etc.). To indicate the settings. But in our example, all goes by runtime (path and login) with dbExpress we don't need. An alias or the BDE either. } Procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString); Var. Connection: TSQLConnection; DataSet: TSQLDataSet; Begin. Connection := TSQLConnection.Create(nil); With Connection do. Begin. ConnectionName := 'VCLScanner'; DriverName := 'INTERBASE'; LibraryName := 'dbexpint.dll'; VendorLib := 'GDS32.DLL'; GetDriverFunc := 'getSQLDriverINTERBASE'; Params.Add('User_Name=SYSDBA'); Params.Add('Password=masterkey'); Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb'); LoginPrompt := False; Open; End; DataSet := TSQLDataSet.Create(nil); With DataSet do. Begin. SQLConnection := Connection; CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")', [Email, FirstN, LastN]); Try. ExecSQL; Except. End; End; Connection.Close; DataSet.Free; Connection.Free; End;

DBGrid CutToClipboard.

Внутри TDBGrid "зашит" защищенный (protected) элемент управления типа TInPlaceEdit, потомок TCustomMaskEdit. Данный элемент управляется комбинацией клавиш [Shift]+[Ins] и [Shift]+[Del]. Но для нас не существует способа оперировать элементом, поскольку он является защищенным членом.

Да, но вы можете сделать это обманным путем. Попробуйте так:

Code: Procedure TForm1.Paste1Click(Sender: TObject); Begin. SendMessage(GetFocus, WM_PASTE, 0, 0); End; Procedure TForm1.Copy1Click(Sender: TObject); Begin. SendMessage(GetFocus, WM_COPY, 0, 0); End;

DBGrid DefaultDrawDataCell.

TDBGrid имеет недокументированный в электронной справке метод DefaultDrawDataCell.

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

Code: Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; Const Rect: TRect; Field: TField; State: TGridDrawState); Begin. With Sender as TDBGrid do. Begin. Canvas.Font.Color := clRed; DefaultDrawDataCell(Rect, Field, State); End; End;

DBTreeView своими руками.

Автор: Елена Филиппова.

Введение.

В статье речь пойдет об отображении данных, хранящихся в БД и имеющих иерархическую (древовидную) структуру. Визуальное представление таких данных требует соответствующего инструмента. Существует немало компонент, которые позволяют представлять данные в виде дерева — для краткости будем называть их все DB TreeView. Компоненты эти довольно удобны, но, как правило, "заточены" под определенные задачи и каждый "шаг в сторону" в структуре данных заставляет многих пускаться в поиски. И на Круглом Столе появляются вопросы: "помогите найти компонент DB TreeView, который позволяет делать еще и ..." и так далее.

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

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

Рассмотрим два принципиально разных случая:

Дерево подразделений.

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

Дерево аналитических признаков.

Реально данные не являются иерархическими, но могут быть представлены в таком виде. Глубина вложенности дерева одинакова для всех его веток и фиксирована в данном примере. Правило построения иерархии может меняться в режиме run-time.

Отличаются эти примеры стуктурой данных и, соответственно, способом формирования дерева.

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

Гораздо правильнее строить отдельные ветки дерева динамически, только в тот момент, когда они наверняка понадобятся.

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

Какой же момент можно считать моментом требования? В принципе есть два равнозначных варианта и отличаются они только внешним видом.

Первый: по двойному клику на текущей ветви дерева проверять, была ли она достроена, если нет то формировать ее и генерировать событие OnExpanding, раскрывая новую ветвь.

Второй: при попытке "раскрыть" ветку проводить аналогичные действия.

Основное отличие этих подходов: в первом случае пользователю необходимо сделать явно лишнее и не очень естественное для дерева движение , то есть двойной клик. А во втором случае мы должны обеспечить возможность раскрытия для каждой ветки дерева, ведь если у ветви нет значка [+] , то и попытаться раскрыть ее будет невозможно. А значит для всех новых, свеже сформированных ветвей, принудительно нужно обеспечить существования фиктивной дочерней ветви.

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

На сервере http://ib.demo.ru/ была опубликована статья Кузьменко Дмитрия Древовидные (иерархические) структуры данных в реляционных базах данных , часть которой посвящена теме визуального представления древовидных данных. В этой статье предлагалось хранить в таблице дополнительное поле с количеством дочерних записей для каждой ветви именно для того, чтобы иметь возможность принимать решение рисовать или не рисовать знак [+] возле текущей ветки дерева. То есть на ходу определять, имеет ли шанс эта ветка быть раскрытой.

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

Каждый способ имеет свои достоинства и недостатки, но мне кажется несколько неоправданным такой подход, когда структура таблиц зависит от способа их отображаения. В примерах, которые иллюстрируют материал этой статьи применяется использование фиктивных дочерних ветвей для обеспечения появления у каждой ветви значка [+].

Примечание:

Такой вопрос, как способы представления иерархических данных в БД, не является предметом данной статьи.

Пример построен на локальных Paradox-таблицах. Следовательно для переноса его на SQL-серверные БД стоит учитывать их особенности.

Дерево подразделеений.

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

Используемая в примере таблица — COMPANY.DB.

Структура данных реализована классическим деревом: каждая запись о подразделении представлена полями.

CompanyID — номер подразделения.

ParentID — номер родительского подразделения.

Name — название.

Для тех подразделений, которые не имеют головных над собой, поле ParentID равно 0.

Формировать уровни дерева мы будем с помощью запроса к таблице ( компонент qTreeCompanies : TQuery ).

Code: Select * From COMPANY. Where ParentID=:ParentID.

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

Процедура, формирующая очередной уровень (дочерний для ветви Node ) реализована следующим образом:

Code: Procedure TFormTree.ExpandLevel( Node : TTreeNode); Var ID , i : Integer; TreeNode : TTreeNode; Begin. // Для самого верхнего уровня выбрать только тех, // кто не имеет родителей. IF Node = nil Then ID:=0. Else ID:=Integer(Node.Data); QTreeCompanies.Close; QTreeCompanies.ParamByName('ParentID').AsInteger:=ID; QTreeCompanies.Open; TreeCompanies.Items.BeginUpdate; // Для каждой строки из полученного набора данных. // формируем ветвь в TreeView, как дочерние ветки к той, // которую мы только что "раскрыли". For i:=1 To qTreeCompanies.RecordCount Do. Begin. // Запишем в поле Data ветки ее идентификационный номер(ID) в таблице. TreeNode:=TreeCompanies.Items.AddChildObject(Node , QTreeCompanies.FieldByName('Name').AsString , Pointer(qTreeCompanies.FieldByName('ID').AsInteger)); TreeNode.ImageIndex:=1; TreeNode.SelectedIndex:=2; // Добавим фиктивную (пустую) дочернюю ветвь только для того, // чтобы был отрисован [+] на ветке и ее можно было бы раскрыть. TreeCompanies.Items.AddChildObject(TreeNode , '' , nil); QTreeCompanies.Next; End; TreeCompanies.Items.EndUpdate; End;

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

Code: If Node.getFirstChild.Data = nil then. Begin. Node.DeleteChildren; ExpandLevel(Node); End;

На форме в проекте кроме дерева расположена еще и сетка (Grid), в которой отображаются записи текущего уровня подразделений. Это, по сути, список дочерних ветвей для текущей ветки дерева. Для того, чтобы синхронизировать TreeView и DBGrid используем нехитрый прием — на событие TTreeView.OnChange (шаг по ветке) добавим следующий код:

Code: IF TreeCompanies.Selected <> nil Then. Begin. // ID родительской ветки , для нее и ищем все дочерние. ID:=Integer(TreeCompanies.Selected.Data); QCompanies.Close; QCompanies.ParamByName('ParentID').AsInteger:=ID; QCompanies.Open; End;

Помните, в процедуре ExpandLevel мы записывали в поле Data каждой ветки ее идентификационный номер? Вот его то мы сейчас и используем.

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

На событие OnDblClick для грида:

Code: ID:=qCompanies.FieldByName('ID').AsInteger; // принудительное "невидимое" раскрытие той ветки, на которой стоим. TreeCompanies.OnExpanding(TreeCompanies ,TreeCompanies.Selected , Allow); // Перебираем все получившиеся дочерние ветки и ищем ту, ID которой. // совпадает с ID строки в правой таблице. То есть ищем ветку в дереве, // которая соответсвует той записи в таблице, на которой мы стоим. // Как только нашли, визуально раскрываем ветку и делаем ее выделенной, // то есть визуально "встаем" на нее в дереве. FOR i:=0 To TreeCompanies.Selected.Count-1 Do. IF Integer(TreeCompanies.Selected.Item[i].Data) = ID Then. Begin. TreeCompanies.Selected.Item[i].Expand(False); TreeCompanies.Selected.Item[i].Selected:=True; TreeCompanies.Repaint; Exit; End;

Параллельно с этим раскрывается соответствующая ветка самого дерева. Очень эффектно. :о).

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

Дерево аналитических признаков.

"Куст — это пучок веток, растущих из одного места".

Из военных афоризмов.

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

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

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

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

Описание примера, реализующего данную задачу.

Используемые таблицы:

Таблица документов DOCUMENTS.DB , где каждый документ определен полями:

DocumentID : номер документа.

Name : название.

CityID : ID города.

ClientID : ID клиента.

GoodsID : ID товара.

Таблицы аналитики, соответственно CITIES.DB, CLIENTS.DB и GOODS.DB, содержат поля названия Name и номера (CityID , ClientID , GoodID).

Так как порядок следования аналитики произвольный, зараннее невозможно написать текст SQL-запроса, который будет возвращать данные для очередного уровня дерева. Этот текст придется формировать в run-time, когда все данные будут известны.

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

Поля таблицы ENTITIES.DB.

EntityID — идентификатор.

Name — русское название аналитического признака.

TableName — название таблицы, в которой он содержится.

KeyColumn — ключевой столбец этой таблицы.

OrderNo — номер по порядку в списке используемых признаков.

IsSelect — выбран или не выбран в текущий список признаков.

ImageIndex — номер изображения (используется в отображении дерева).

В нашем случае эта таблица будет выглядеть так:

EntityID Name TableName KeyColumn ...

1 Город CITIES CityID ...

2 Товар GOODS GoodID ...

3 Клиент CLIENTS ClientID ...

В примере я использую список ListEntities (TCollection), каждый элемент которого содержит поля TableName, KeyColumn и ImageIndex. Элементы в этом списке расположены в том порядке, в каком будет строиться дерево. Заполняется этот список только той аналитикой, которая требуется для конкретного дерева. Например, только города и клиенты или товары и клиенты, или сразу все вместе. Следовательно этот список (ListEntities) и содержит полную информацию для построения дерева в каждый конкретный момент.

Заполнение списка аналитики проводится в модуле setupEntities.pas.

Code: //считывает аналитику из таблицы. Procedure GetEntities( var List : TEntityLists ); // вызывает диалог для настойки аналитики пользователем. Function SetEntities( var List : TEntityLists ) : Boolean;

Динамический обмен данными (DDE).

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

Приложения, использующие DDE, разделяются на две категории — клиенты и серверы (не путать с одноименной архитектурой СУБД). Оба участника процесса осуществляют контакты (conversations) по определенным темам (topic), при этом в рамках темы производится обмен элементами данных (items). Устанавливает контакт клиент, который посылает запрос, содержащий имена контакта и темы. После установления контакта всякое изменение элемента данных на сервере передается данным клиента. Подробно функции DDE описаны в [4].

Первоначально программирование DDE было чрезвычайно сложным делом — оно требовало взаимосвязанной обработки более чем десяти сообщений Windows. В версии Windows 3.1 появилась библиотека DDEML, которая перевела управление DDE на уровень вызова процедур. Разработчики подсистемы DDE в Delphi, верные идеологии создания VCL, свели интерфейс этого протокола к четырем компонентам — двум для сервера и двум для клиента.

На уровне поддержания контакта лежат компоненты TDDEServerConv и TDDEClientConv. Первый играет пассивную роль — он только указывает имя одной из поддерживаемых сервером тем. Все операции по установлению и разрыву контакта осуществляет из приложения-клиента второй компонент.

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

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

Помимо этого в модуле DDEMAN описан и пятый компонент, который управляет всеми связями DDE. Его рассмотрение выходит за рамки книги.

Начнем с рассмотрения двух компонентов, необходимых для создания сервера DDE.

Компонент TDDeServerConv.

TObject—>TPersistent->TCoinponent—>TDDeServerConv.

Модуль DDEMAN.

Страница Палитры компонентов System.

В этом компоненте самую важную роль играет единственное свойство — Name. Имя компонента совпадает с именем темы, которую он поддерживает. Клиент должен знать это имя при установлении контакта, за исключением того случая, когда он подключается к данным контакта, которые скопированы в буфер обмена (это реализует компонент TDDEServerItem).

В моменты открытия и закрытия контакта возникают события:

Property OnOpen: TNotifyEvent;

Property OnClose: TNotifyEvent;

Первоначально протокол DDE был ориентирован только на оперативное получение данных клиентом от сервера, но позже его возможности расширились. Клиент может передать для выполнения серверу набор макрокоманд — для этого у него есть нужные методы. На стороне сервера за их исполнение отвечает обработчик события:

(pb) property OnExecuteMacro: TMacroEvent;

TMacroEvent = procedure(Sender: TObject; Msg: TStrings) of object;

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

Function ExecuteMacro(Data: HDDeData): Longint;

В этом случае параметр Data должен содержать дескриптор строки с командами (типа pChar).

Компонент TDDeServerltem.

TObject—"TPersistent—>TConiponent-"TDDeServerI tern.

Модуль DDEMAN.

Страница Палитры компонентов System.

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

Только текстовыми данными. Так что свойство, содержащее формат обмена данными,

Property Fmt: Integer;

Всегда равно CF_TEXT. Данные содержатся в свойствах:

Property Text: string;

Property Lines: TStrings;

По сути дела, первое свойство представляет собой подмножество второго. При чтении Text равен первой строке Lines. Но если вы присваиваете ему значение, все прочие строки Lines очищаются. Элемент данных должен быть связан с определенной темой. В свойстве:

(Pb) property ServerConv: TDDeServerConv;

Может быть задана ссылка на компонент типа TDDEServerConv, чье имя будет темой контакта DDE. Можно обойтись и без использования такого компонента. В этом случае именем темы будет являться заголовок (Caption) той формы, которая содержит TDDEServerItem. Элемент данных может быть скопирован в буфер обмена в специальном формате (в виде информации о контакте), с помощью метода:

Procedure CopyToClipboard;

Для вступления в контакт посредством буфера обмена клиент может вызвать функцию GetPasteLinkInfo (см. ниже), и, проанализировав имена сервера, темы и элемента, принять решение о вступлении. Клиент может переустановить данные сервера. При переустановке возникает событие:

Property OnPokeData: TNotifyEvent;

Кроме того, для этого вами может быть использован метод:

Function PokeData(Data: HDDeData): Longint;

Параметр Data должен представлять собой дескриптор области памяти, в которой содержится текстовая строка типа pChar. В отличие от OnPokeData, событие:

Property OnChange: TNotifyEvent;

Возникает при любом изменении данных, как при присвоении значений свойствам Text или Lines, так и при вызове PokeData. Оно может также быть вызвано явно из метода: ^

Procedure Change;

Компонент TDDECIIentConv.

TObject->TPersistent->TComponent—>TDDEClientConv.

Модуль DDEMAN.

Страница Палитры компонентов System.

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

Property DDEService: String;

Property DDETopic: String;

Сервер и тема устанавливаются при вхождении в контакт. Предусмотрены два режима вхождения в него:

Property ConnectMode: TDataMode;

TDataMode = (ddeAutomatic, ddeManual);

Метод.

Function SetLink(const Service: string; const Topic: string): Boolean;

Присваивает серверу и теме имена, равные Service и Topic, а если выбран режим контакта ddeAutomatic — то и устанавливает контакт. Будьте внимательны при задании параметров метода— здесь учитывается регистр символов. В случае режима ddeManual для установления контакта необходимо вызвать дополнительно метод:

Function OpenLink: Boolean;

Этот метод сначала закрывает предыдущий контакт, затем он пытается связаться с сервером DDEService на тему DDETopic. Если это не удается сразу (например, если требуемый сервер DDE отсутствует), то делается попытка загрузить программу с именем, определенным в свойстве.

(Pb) property ServiceApplication: String;

И установить контакт с ней. Если оно не определено (ServiceApplication = "), то в качестве последней попытки для контакта пробуется имя, представляющее собой конкатенацию имен сервера и темы, разделенных пробелом. В случае неудачи метод OpenLink возвращает False.

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

Function PasteLink: Boolean;

Переключит компонент на новый контакт и вернет значение True. Наконец, метод.

Procedure CloseLink;

Разрывает контакт с сервером DDE.

Метод.

Function StartAdvise: Boolean;

Инициирует начало обмена данными. Обычно он вызывается в методе OpenLink.

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

Function PokeDataLines(const Item: string; Data: TStrings): Boolean;

Function PokeData(const Item: string; Data: PChar): Boolean;

Здесь Item — имя элемента данных, Data — передаваемые текстовые данные. Кроме того, некоторые серверы DDE имеют собственные наборы макрокоманд, запрос на выполнение которых можно послать от клиента. К ним относятся многие приложения, в т. ч. СУБД и электронные таблицы, такие, как Paradox и MS Excel; наиболее типичным примером служит Program Manager. Запрос на выполнение макрокоманд посылают методы:

Function ExecuteMacroLines(Cmd: TStrings; waitFIg: Boolean): Boolean-function ExecuteMacro(Cmd: PChar; waitFIg: Boolean): Boolean;

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

Property WaitStat: Boolean;

Устанавливается в True. При этом вызовы последних четырех описанных методов отрабатываться не будут, пока сервер не известит об окончании операции, и WaitStat не примет значение False. Это свойство доступно только по чтению. Клиент может запросить данные от сервера немедленно с помощью метода:

Function RequestData(const Item: string): PChar;

Формат обмена данными можно узнать из свойства:

Property DDEPmt: Integer;

Перефразируя Генри Форда, скажем, что можно обмениваться данными любого формата, если этот формат — CF_TEXT.

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

Property Conv: HConv;

В полученном от сервера тексте могут быть специальные управляющие символы — <Enter>, <Tab>, <Backspace> и другие. Их можно отфильтровать (подавить), если свойство.

Property FormatChars: Boolean;

Установлено в False. В этом случае все символы ASCII с десятичными кодами от 1 до 31 заменяются на пробел (код 32). В случае True преобразования не происходит.

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

Property OnOpen: TNotifyEvent;

Property OnClose: TNotifyEvent;

Свойство.

Property DataMode: TDataMode;

По-видимому, зарезервировано ддя дальнейших применений.

Компонент TDDECIientltem.

TObject—>TPersistent—"TComponent—>TDDEClientItem.

Модуль DDEMAN.

Страница Палитры компонентов System.

Этот компонент представляет элемент данных на клиентской стороне. После установления контакта с сервером нужно присвоить свойству.

Property DDEConv: TDDEClientConv;

Указатель на объект, соответствующий появившемуся контакту, а свойству.

Property DDEItem: String;

Имя элемента данных сервера. В этом случае все изменения будут отслеживаться.

В рассмотренном ниже примере приложение-клиент вступает в контакт с сервером InfbServer на тему TimeTopic. При нажатии кнопки TimeButton связь устанавливается, при отпускании — разрывается. Метод TimeConvOpen, служащий обработчиком события ОпОреп, присваивает значения именам темы и элемента данных.

Code: Const. InfoServer = 'infoserv'; TimeConversation = 'TimeTopic'; ServerTimeItem = 'Timeltem' ; SCannotStart = 'Cannot start conversation'; Procedure TFormI.TimeButtonClick(Sender: Tobject); Begin. If TimeButton.Down then. Begin. If not TimeConv.SetLink(InfoServer, TimeConversation) or not TimeConv.OpenLink then. Begin. MessageDIg(SCannotStart, mtError, [mbOk], 0) ; TimeButton.Down := False; End. End. Else. TimeConv.CloseLink; End; Procedure TPormI.TimeConvOpen(Sender: TObject); Begin. ClientTimeItem.DDEConv := TimeConv; ClientTimeItem.DDEItem := ServerTimeItem; End;

DDE (статья).

Обзор.

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

В статье предполагается, что читатель может знать очень мало о предмете. Цель статьи - научить его использовать концепцию DDE при создании приложений в среде Delphi.

Основы DDE.

Аббревиатура DDEML обозначает Dynamic Data Exchange Management Library (библиотека управления динамическим обменом данными). DDEML это надстройка над сложной системой сообщений, называемой Dynamic Data Exchange (DDE). Библиотека, содержащая DDE била разработана для усиления возможностей первоначальной системы сообщений Windows.

DDE дает возможность перейти через рамки приложения и взаимодействовать с другими приложениями и системами Windows.

Dynamic Data Exchange получило свое имя потому, что позволяет двум приложениям обмениваться данными (текстовыми, через глобальную память) динамически во время выполнения. Связь между двумя программами можно установить таким образом, что изменения в одном приложении будут отражаться во втором. Например, если Вы меняете число в электронной таблице, то во втором приложении данные обновятся автоматически и отобразят изменения. Кроме того, с помощью DDE можно из своего приложения управлять другими приложениями такими, как Word for Windows, Report Smith, Excel и др.

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

Использование DDE.

Приложение, получающее данные из другого приложения по DDE и/или управляющее другим приложением с помощью команд через DDE является DDE-клиентом. В этом случае второе приложение является DDE-сервером. Одно и то-же приложение может быть одновременно и сервером, и клиентом (например, MicroSoft Word). Построение DDE-серверов и DDE-клиентов удобно рассмотреть на примере, поставляемом с Delphi (каталог x:\delphi\demos\ddedemo). Сперва давайте рассмотрим логику работы примера. Для начала нужно откомпилировать проекты DDESRVR.DPR и DDECLI.DPR, после этого запустите программу DDECLI.EXE (DDE-клиент) и выберите пункт меню File|New Link. При этом должна запуститься программа DDESRVR (DDE-сервер). Если теперь редактировать текст в окне сервера, то изменения мгновенно отразятся в приложении-клиенте.

Пример демонстрирует и другие возможности DDE: - пересылка данных из клиента на сервер (Poke Data); наберите любой текст в правом окне DDE-клиента и нажмите кнопку Poke Data, этот текст появится в окне сервера. - исполнение команд (макросов) на сервере; наберите любой текст в правом окне DDE-клиента и нажмите кнопку Exec Macro, DDE-сервер выдаст соответствующее диалоговое окно. - установление связи через Clipboard; закройте оба DDE-приложения и запустите их заново, затем в DDE-сервере выберите пункт меню Edit|Copy, далее в клиенте выберите пункт меню Edit|Paste Link.

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

DDE-серверы.

Для построении DDE-сервера в Delphi имеются два объекта, расположенные на странице System Палитры Компонент - TDdeServerConv и TDdeServerItem. Обычно в проекте используется один объект TDdeServerConv и один или более TDdeServerItem. Для получения доступа к сервису DDE-сервера, клиенту потребуется знать несколько параметров : имя сервиса (Service Name) - это имя приложения (обычно - имя выполняемого файла без расширения EXE, возможно с полным путем); Topic Name - в Delphi это имя компоненты TDdeServerConv; Item Name - в Delphi это имя нужной компоненты TDdeServerItem.

Назначение объекта TDdeServerConv - общее управление DDE и обработка запросов от клиентов на выполнение макроса. Последнее выполняется в обработчике события OnExecuteMacro, например, как это сделано в нашем случае:

Code: Procedure TDdeSrvrForm.doMacro(Sender: TObject; Msg: TStrings); Var. Text: string; Begin. Text := ''; If Msg.Count > 0 then Text := Msg.Strings[0]; MessageDlg ('Executing Macro - ' + Text, mtInformation, [mbOK], 0); End;

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

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

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

Code: Uses. Windows, ddeman, ... Function Get_URL(Servicio: string): string; Var. Cliente_DDE: TDDEClientConv; Temp: PChar; //<<-------------------------This is new. Begin. Result := ''; Cliente_DDE:= TDDEClientConv.Create( nil ); With Cliente_DDE do. Begin. SetLink( Servicio,'WWW_GetWindowInfo'); Temp := RequestData('0xFFFFFFFF'); Result := StrPas(temp); StrDispose(temp); // <<-- Предотвращаем утечку памяти. CloseLink; End; Cliente_DDE.Free; End; Procedure TForm1.Button1Click(Sender); Begin. Showmessage(Get_URL('Netscape')); // или. Showmessage(Get_URL('IExplore')); End;

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

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

Арабские->Римские

Римские -> Арабские

Delphi 2005 Patch.

Неофициальный Patch от Петровича для исправления некоторых ошибок IDE и VCL.

Http://forum.sources.ru/index.php?act=Attach&type=post&id=579672.

©Drkb::04638.

Автор: Петрович.

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

Delphi 7 and FastNet Components.

Where are the FastNet Components in Delphi 7?

The Fastnet components are no longer bundled with Delphi. It appears Netmasters does have a version compatible with Delphi 7 which can be purchased at: http://www.netmastersllc.com/

©Drkb::00349.

Delphi ActiveForms и Web Modules (intranet).

Delphi ActiveForms (intranet).

С помощью JBuilder возможно разрабатывать 100% pure Java апплеты, приложения., но мы не должны забывать и о том, что с помощью Дельфи так же можно создавать интересные Интранет решения используя такие вещи как ActiveForms и Web Modules...

4.1. ActiveForms.

Дельфи 2.x не может создавать ActiveX органы управления. В Дельфи 3 это было исправлено и названо One-Step-ActiveX. Вначале показалось, что это было изумительное свойство Дельфи 3. Но после детального ознакомления, оказалось, что можете включать только компоненты наследники от TWinControl внутрь ActiveX, и вы не можете делать ActiveX органы, которые могут подключать другие компоненты, такие как TTable и TQuery компоненты, котрые подключаются к TDataSource, и все другие data-aware компоненты). На практике это означает, что изумительное нововведение оказалось в действительности пшиком, не позволяя делать серьезные Интернет приложения.

Конечно мы можем обойти эту проблему, разместив все нужные компоненты в один "контейнер" и преобразовать этот контейнер в один большой ActiveX контрол. Конечно, наилучшим контейнером мог бы быть TForm (так что мы могли бы разрабатывать привычным образом), и имя этому было бы ActiveForm. ActiveForms мог бы интерпритироваться как обычная форма, которая может содержать любые компоненты, включая TTable, TDataSource, TDBGrid, TDBNavigator, и т.д. и они были бы хорошим потенциалом ActiveX для Дельфи программиста.

Подобно любому ActiveX контролу, ActiveForm требуется Win32 платформа для исполнения, но это должна быть Win32 платформа, так как ActiveForm это обычный ActiveX орган, и может быть использован внутри других средств разработки, поддерживающих ActiveX, таких как C++Builder, Visual Basic, PowerBuilder, и также Internet Explorer. Последнее означает, что мы можем использовать ActiveForm для распространения Интернет приложений в Интернет или Интранет.

Простой откомпилированный ActiveForm проект может оказаться в .OCX размером свыше 300 Kb, даже если были использованы совсем немного контролов и всего лишь несколько строк кода. Компиляция с пакетами, VCLx0 (стандарт) или VCLDBx0 (data-aware) может уменьшить этот размер до 50 Kb, более мене функциональные ActiveForm будуь порядка 100 Kb. Пакеты значительно увеличивают размер (VCLx0 пакет это более мегабайта), но они должны ставиться у клиента только один раз, и могут быть уже предустановленны у клиента, что позволяет уменьшить время загрузки.

Поскольку ActiveForm это просто другое Win32 приложение, то даже когда оно запускается из Internet Explorer то могут произойти неприятные вещи у неискушенных пользователей. По одной причине, ActiveForm имеет доступ ко всей машине, и если пользователь зарегистрировался в сети, то ActiveForm, подобно вирусу может сделать все что угодно на вашей машине (отформатировать жесткий диск? Послать e-mail? Разрушить базу данных? Все что вы в состоянии представить и еще более). Поэтому при загрузке из Интернета (но не внутренней сети компании), мы должны считать ActiveForm или любой ActiveX орган потенциальным вирусом. Авторы ActiveForm и ActiveX контролов могут использовать цифровую подпись, которая только подтверждает, что данная вещь принадлежит автору, но ничего не говорит о самом органе. Internet Explorer имеет некоторые настройки безопасности, которые могут быть установлены в максимум (не принимать не подписанные ActiveX), в средние (давать предупреждение, но позволить решать пользователю) или слабые (принимать все без предупреждения). Разработчики подобно нам могут использовать средние, но конечный пользователь должен всегда использовать максимальный настройки безопасности.

Отвлекаясь от проблем с безопасностью, ActiveForm также требуется BDE на локальной машине (клиентская сторона) при использовании локальных баз и таблиц. Даже если алиас указывает, что база расположена на файл-сервере, BDE все равно должен быть установлен на клиентской машине. Использую MIDAS, TClientDataSets, DataSetProvider и Connection components, мы можем превратить ActiveForm в multi-tier приложение, когда база данных расположена на web сервере (или даже на отделном сервер баз данных).

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

Можно констатировать, что Delphi ActiveForm прекрасная вещь для Intranet.

Bug Report: ActiveX Controls in Internet Explorer 4.0 (or higher).

По заявлению Microsoft, "в связи с архитектурными изменениями в Internet Explorer 4.0 (и выше), что требуется для поддержки более широкого спектра более эффективных контролов, некоторые ActiveX контролы могут выполняться не совсем так, как это было в Explorer 3.0. Основная причина в том, что эти контролы разработаны не в Apartment Model Aware.".

В Delphi 4 эта проблема разрешена и ActiveForm сделанные в Delphi 4 (и выше) теперь поддерживаю Apartment threading model.

5. Delphi Web Modules (internet).

5.1. Web Modules.

ActiveForm это великое решение для Интранет, когда само приложение исполняется на клиентской машине. Для подлинно независимых от платформы решений, мы должны сфокусировать наше внимание на web сервера. В этом случае, мы можем использовать Delphi для написания CGI или WinCGI приложений, или ISAPI/NSAPI (Internet или Netscape Server API) DLL расширений для web сервера. Мы можем использовать HTML на клиентской стороне, с помощью CGI форм посылая данные от клиента на сервер, в то же время в ответ генерирует динамические HTML страницы.

Написание CGI, WinCGI или ISAPI/NSAPI с помощью Дельфи не совсем тривиальная задача. Особенно переключение от одного решения к другому может оказаться очень трудным, так как поставщики продуктов третьих сторон, часто используют различные пути поддержки своих серверных Интернет приложений, например WebHub.

Delphi 3 и 4 Client/Server (а также Delphi 4 Professional с дополнениями) и Delphi 5 Professional часто приходят со специальными мастерами (Wizard) и компонентами для поддержки такого рода серверных приложений, называемых как Web Modules (или также известные под названием WebBroker). Используя Web Module, мы можем создавать CGI, WinCGI и ISAPI/NSAPI серверные приложения, и в этом случае мы можем переходить от одного типа к другому, самом приложение полностью абстрагируется от деталей реализации. Единственная разница (учитывая тот факт, что ISAPI DLL остается загруженным на Web сервере, а CGI EXE нет) в том что, ISAPI приложение легче отлаживать, используя IntraBob, чем CGI приложение. В существующем проекте с Web модулем отсутствует возможность определения, что используется, CGI или ISAPI/NSAPI приложение; только главный модуль проекта содержит эту информацию (которую можно изменить, что бы перейти к другому типу Web серверного приложения). Я думаю, что очень важная вещь: программист использует один набор компонент для обработки WebActions, WebRequests, WebResponses и т.д.

Используя специальный компонент WebDispatcher, мы можем даже мигрировать из существующих модулей данных (Data Modules) в Web модули. WebDispatcher встроен в обычный Web модуль, и используется для для диспетчеризации действия (Action) в Web модуле (Web серверное приложение может обрабатывать и выполнять разнообразные запросы и выполнять различные действия, для определения которых используется WebDispatcher).

Каждый WebAction может программироваться отдельно, но так же использовать что угодно их WebModule. Это включает все таблицы и бизнес правила, также другие процедуры и ресурсы. WebAction может напрямую писать в строку Response, или использовать один их трех специальных компонент для генерации динамических HTML и обслуживать запросы.

Компонент PageProducer используется для генерации динамических HTML страниц, включая специальные теги, которые могут использоваться для подстановки в run-time. Компонент DataSetTableProducer может использоваться для генерации динамических HTML страниц в табличном виде, используя колонки из таблицы базы данных. Вывод может полностью конфигурироваться, и требует наличия BDE на web сервере. Компонент QueryTableProducer подобен компоненту DataSetTableProducer, только использует запросы (query) вместо таблиц (table). Существует особая возможность использовать запросы с параметрами, встроенными в напрямую HTML CGI.

Конечно, Web модули поддерживаю куки (cookies), но я лично предпочитаю использовать "невидимые поля" для хранения информации об состоянии.

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

Bug Report: TWinCGI OutputFile.

Владельцы Delphi 3 C/S при написании WinCGI приложений должны учитывать потенциальную проблему: функция OutputFile открывает в режиме fmOpenWrite, которая вылетит если файл отсутствует. Эта проблема отсутствует при использовании IIS/PWS (которые предварительно создают OutputFile), но WebSite и IntraBob в этом случае не создают выходной файл, так что они сгенерируют исключение "cannot open file".

Для исправления следует открыть файл CGIApp.pas и изменить "fmOpenWrite" на "fmCreate" в строках 410 и 507.

Интернет решения от доктора Боба (http://www.drbob42.com).

©Drkb::03441.

Delphi и Windows API для защиты секретов.

Delphi и Windows API для защиты секретов

Константин Виноградов, Лилия Виноградова, "Комиздат".

Как реализовать методы криптографической защиты информации при помощи подручных средств – Windows и Delphi.

Часть 1.

Мы вступили в цифровой век. На смену бумажным документам пришли электронные, а личные контакты все чаще уступают место переписке по e-mail. Поэтому «шпионские штучки» вроде паролей и шифровок становятся все более привычными и необходимыми инструментами безопасности.

Криптографические возможности Windows.

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

Итак, ОС мы доверяем. Чтобы криптозащиту нельзя было «обойти» с другой стороны - к примеру, перехватить из незащищенной области памяти секретные пароли - криптографические функции должны быть частью операционной системы. В семействе Windows, начиная с Windows 95, обеспечивается реализация шифрования, генерации ключей, создания и проверки цифровых подписей и других криптографических задач. Эти функции необходимы для работы операционной системы, однако ими может воспользоваться и любая прикладная программа - для этого программисту достаточно обратиться к нужной подпрограмме так, как предписывает криптографический интерфейс прикладных программ (CryptoAPI).

Разумеется, по мере совершенствования Windows расширялся и состав ее криптографической подсистемы. Помимо базовых операций, в настоящее время в CryptoAPI 2.0 поддерживается работа с сертификатами, шифрованными сообщениями в формате PKCS #7 и пр.

Описание функций CryptoAPI, помимо специальных книг, можно найти в MSDN Library, или в CD-версии, в файле crypto.chm.

Взаимодействие с CryptoAPI.

Функции CryptoAPI можно вызвать из программы, написанной на любимом многими (в том числе и авторами) языке С++. Тем не менее, Pascal де-факто признан стандартом в области обучения программированию. (Не будем спорить о том, хорошо это или плохо, чтобы не ввязываться в драку, пусть даже и виртуальную.) Кроме того, в ряде отечественных компаний Delphi является базовым средством разработки. Поэтому все примеры были реализованы в среде Delphi. Хотя в качестве инструмента можно было бы выбрать и MS Visual C++.

Код функций криптографической подсистемы содержится в нескольких динамически загружаемых библиотеках Windows (advapi32.dll, crypt32.dll). Для обращения к такой функции из прикладной программы на Object Pascal следует объявить ее как внешнюю. Заголовок функции в интерфейсной части модуля будет выглядеть, например, так:

Function CryptAcquireContext (

PhPROV: PHCRYPTPROV;

PszContainer: LPCTSTR;

PszProvider: LPCTSTR;

DwProvType: DWORD;

DwFlags: DWORD): BOOL; stdcall;

а в исполняемой части вместо тела функции нужно вписать директиву extern с указанием библиотеки, в которой содержится функция, и, возможно, ее имени в этой библиотеке (если оно отличается от имени функции в создаваемом модуле), например:

Function CryptAcquireContext; external ‘advapi32.dll’

Name 'CryptAcquireContextA';

Таким образом, имея описание функций CryptoAPI, можно собрать заголовки функций в отдельном модуле, который будет обеспечивать взаимодействие прикладной программы с криптографической подсистемой. Разумеется, такая работа была проделана программистами Microsoft, и соответствующий заголовочный файл (wincrypt.h) был включен в поставку MS Visual C++. К счастью, появилась и Delphi-версия (wcrypt2.pas). Ее можно найти здесь. Подключив модуль к проекту, вы сможете использовать не только функции CryptoAPI, но и мнемонические константы режимов, идентификаторы алгоритмов и прочих параметров, необходимых на практике.

И последнее замечание перед тем, как опробовать CryptoAPI в деле. Ряд функций был реализован только в Windows 2000. Но и на старушку Windows 98 можно найти управу: при установке Internet Explorer 5 интересующие нас библиотеки обновляются, позволяя использовать новейшие криптографические возможности. Нужно лишь задать для Delphi-проекта параметр условной компиляции NT5, после чего вызовы функций, появившихся лишь в Windows 2000, будут нормально работать.

Знакомство с криптопровайдерами

Функции CryptoAPI обеспечивают прикладным программам доступ к криптографическим возможностям Windows. Однако они являются лишь «передаточным звеном» в сложной цепи обработки информации. Основную работу выполняют скрытые от глаз программиста функции, входящие в специализированные программные (или программно-аппаратные) модули — провайдеры (поставщики) криптографических услуг (CSP - Cryptographic Service Providers), или криптопровайдеры (рис. 1).

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

Программная часть криптопровайдера представляет собой dll-файл, подписанный Microsoft; периодически Windows проверяет цифровую подпись, что исключает возможность подмены криптопровайдера.

Криптопровайдеры отличаются друг от друга:

· составом функций (например, некоторые криптопровайдеры не выполняют шифрование данных, ограничиваясь созданием и проверкой цифровых подписей);

· требованиями к оборудованию (специализированные криптопровайдеры могут требовать устройства для работы со смарт-картами для выполнения аутентификации пользователя);

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

По составу функций и обеспечивающих их алгоритмов криптопровайдеры подразделяются на типы. Например, любой CSP типа PROV_RSA_FULL поддерживает как шифрование, так и цифровые подписи, использует для обмена ключами и создания подписей алгоритм RSA, для шифрования — алгоритмы RC2 и RC4, а для хеширования - MD5 и SHA.

В зависимости от версии операционной системы состав установленных криптопровайдеров может существенно изменяться. Однако на любом компьютере с Windows можно найти Microsoft Base Cryptographic Provider, относящийся к уже известному нам типу PROV_RSA_FULL. Именно с этим провайдером по умолчанию будут взаимодействовать все программы.

Использование криптографических возможностей Windows напоминает работу программы с графическим устройством. Криптопровайдер подобен графическому драйверу: он может обеспечивать взаимодействие программного обеспечения с оборудованием (устройство чтения смарт-карт, аппаратные датчики случайных чисел и пр.). Для вывода информации на графическое устройство приложение не должно непосредственно обращаться к драйверу — вместо этого нужно получить у системы контекст устройства, посредством которого и осуществляются все операции. Это позволяет прикладному программисту использовать графическое устройство, ничего не зная о его аппаратной реализации. Точно так же для использования криптографических функций приложение обращается к криптопровайдеру не напрямую, а через CryptoAPI. При этом вначале необходимо запросить у системы контекст криптопровайдера.

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

· CryptEnumProviders (i, резерв, флаги, тип, имя, длина_имени) - возвращает имя и тип i-го по порядку криптопровайдера в системе (нумерация начинается с нуля);

· CryptAcquireContext (провайдер, контейнер, имя, тип, флаги) - выполняет подключение к криптопровайдеру с заданным типом и именем и возвращает его дескриптор (контекст). При подключении мы будем передавать функции флаг CRYPT_VERIFYCONTEXT, служащий для получения контекста без подключения к контейнеру ключей;

· CryptGetProvParam (провайдер, параметр, данные, размер_данных, флаги) - возвращает значение указанного параметра провайдера, например, версии (второй параметр при вызове функции - PP_VERSION), типа реализации (программный, аппаратный, смешанный - PP_IMPTYPE), поддерживаемых алгоритмов (PP_ENUMALGS). Список поддерживаемых алгоритмов при помощи этой функции может быть получен следующим образом: при одном вызове функции возвращается информация об одном алгоритме; при первом вызове функции следует передать значение флага CRYPT_FIRST, а при последующих флаг должен быть равен 0;

· CryptReleaseContext (провайдер, флаги) - освобождает дескриптор криптопровайдера.

Каждая из этих функций, как и большинство других функций CryptoAPI, возвращает логическое значение, равное true, в случае успешного завершения, и false - если возникли ошибки. Код ошибки может быть получен при помощи функции GetLastError. Возможные значения кодов ошибки приведены в упоминавшейся выше документации. Например, при вызове функции CryptGetProvParam для получения версии провайдера следует учесть возможность возникновения ошибок следующим образом: см. Лист 1.

Текст процедуры, выводящей в Memo-поле FileMemo формы информацию об установленных в системе криптопровайдерах, приведен в Лист 2. Предполагается, что процедура вызывается при выборе соответствующего элемента в главном меню формы. Для краткости в тексте программы опущены фрагменты, выполняющие обработку ошибок.

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

На рис. 2 показан пример отчета, выдаваемого приведенным выше кодом, выполненным в среде Windows 98.

Шифрование с использованием паролей

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

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

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

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

· по хеш-значению невозможно восстановить исходное сообщение;

· практически невозможно найти еще один текст, дающий такой же хеш, как и наперед заданное сообщение;

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

При соблюдении приведенных условий хеш-значение служит компактным цифровым отпечатком (дайджестом) сообщения. Существует множество алгоритмов хеширования. CryptoAPI поддерживает, например, алгоритмы MD5 (MD - Message Digest) и SHA (Secure Hash Algorithm).

Итак, чтобы создать ключ шифрования на основании пароля, нам нужно вначале получить хеш этого пароля. Для этого следует создать с помощью CryptoAPI хеш-объект, воспользовавшись функцией CryptCreateHash (провайдер, ID_алгоритма, ключ, флаги, хеш), которой нужно передать дескриптор криптопровайдера (полученный с помощью CryptAcquireContext) и идентификатор алгоритма хеширования (остальные параметры могут быть нулями). В результате мы получим дескриптор хеш-объекта. Этот объект можно представить себе как черный ящик, который принимает любые данные и «перемалывает» их, сохраняя внутри себя лишь хеш-значение. Подать данные на вход хеш-объекта позволяет функция CryptHashData (дескриптор, данные, размер_данных, флаги).

Непосредственно создание ключа выполняет функция CryptDeriveKey (провайдер, ID_алгоритма, хеш-объект, флаги, ключ), которая принимает хеш-объект в качестве исходных данных и строит подходящий ключ для алгоритма шифрования, заданного своим ID. Результатом будет дескриптор ключа, который можно использовать для шифрования (рис. 3).

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

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

Алгоритмы шифрования, поддерживаемые CryptoAPI, можно разделить на блочные и поточные: первые обрабатывают данные относительно большими по размеру блоками (например, 64, 128 битов или более), а вторые - побитно (теоретически, на практике же - побайтно). Если размер данных, подлежащих шифрованию, не кратен размеру блока, то последний, неполный блок данных, будет дополнен необходимым количеством случайных битов, в результате чего размер зашифрованной информации может несколько увеличиться. Разумеется, при использовании поточных шифров размер данных при шифровании остается неизменным.

Шифрование выполняется функцией CryptEncrypt (ключ, хеш, финал, флаги, данные, рамер_данных, размер_буфера):

· через параметр ключ передается дескриптор ключа шифрования;

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

· параметр финал равен true, если шифруемый блок текста - последний или единственный (шифрование можно осуществлять частями, вызывая функцию CryptEncrypt несколько раз);

· значение флага должно быть нулевым;

· параметр данные представляет собой адрес буфера, в котором при вызове функции находится исходный текст, а по завершению работы функции - зашифрованный;

· следующий параметр, соответственно, описывает размер входных/выходных данных,

· последний параметр задает размер буфера - если в результате шифрования зашифрованный текст не уместится в буфере, возникнет ошибка.

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

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

Полный пример приложения в формате Delphi 4 можно взять здесь.

Конечно, шифрование вами всех файлов одним и тем же паролем облегчает «противнику» задачу их расшифровки, запоминание огромного числа паролей сильно усложняет жизнь, а их записывание в незашифрованном виде создает опасность раскрытия всей системы. CryptoAPI может предложить на этот случай ряд решений. О них поговорим ниже.

Часть 2.

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

Проблема распределения ключей

В прошлый раз при помощи CryptoAPI мы решали такую "классическую" задачу как шифрование на основе пароля. Напомним, что пароль использовался для создания ключа шифрования какого-либо симметричного алгоритма. В таком случае расшифровать файл может лишь тот, кто знает пароль. А значит, для обеспечения конфиденциальности нужно держать пароль в строжайшем секрете - желательно, чтобы его знали лишь отправитель и получатель информации. (А еще лучше, если отправитель и получатель - одно и то же лицо.).

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

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

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

Спасительный способ, позволяющий шифровать сообщения, обмениваясь ключами по открытым каналам связи, был придуман в середине 70-х годов прошлого столетия, а в начале восьмидесятых появился первый реализующий его алгоритм - RSA. Теперь пользователь может сгенерировать два связанных между собой ключа - ключевую пару. Один из этих ключей по несекретным каналам рассылается всем, с кем пользователь хотел бы обмениваться конфиденциальными сообщениями (рис. 4). Этот ключ называют открытым (англ. public key). Зная открытый ключ пользователя, можно зашифровать адресованное ему сообщение, но вот расшифровать его позволяет лишь вторая часть ключевой пары - закрытый ключ (private key). При этом открытый ключ не дает "практической" возможности вычислить закрытый: такая задача, хоть и разрешима в принципе, но при достаточно большом размере ключа требует многих лет машинного времени. Для сохранения конфиденциальности получателю необходимо лишь хранить в строгом секрете свой закрытый ключ, а отправителю - убедиться, что имеющийся у него открытый ключ действительно принадлежит адресату.

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

Так как для шифрования и расшифровки используются различные ключи, алгоритмы такого рода назвали асимметричными. Наиболее существенным их недостатком является низкая производительность - они примерно в 100 раз медленнее симметричных алгоритмов. Поэтому были созданы криптографические схемы, использующие преимущества как симметричных, так и асимметричных алгоритмов (рис. 5):

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

· небольшой по размерам симметричный ключ шифрования шифруется при помощи асимметричного алгоритма с использованием открытого ключа адресата и в зашифрованном виде пересылается вместе с сообщением;

· получив сообщение, адресат своим закрытым ключом расшифровывает симметричный ключ, а с его помощью - и само сообщение.

Описанная схема реализована и в CryptoAPI.

Целостность и аутентичность информации

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

Как удостовериться в том, что пришедшее сообщение действительно отправлено тем, чье имя стоит в графе "отправитель"? Асимметричные схемы шифрования дают нам элегантный способ аутентификации. Если отправитель зашифрует сообщение своим закрытым ключом, то успешное расшифровывание убедит получателя в том, что послать корреспонденцию мог только хозяин ключевой пары, и никто иной (рис. 6). При этом расшифровку может выполнить любой, кто имеет открытый ключ отправителя. Ведь наша цель - не конфиденциальность, а аутентификация.

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

· аутентичность сообщения - создать подпись на основе закрытого ключа мог только его хозяин;

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

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

Контейнеры ключей

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

Каждый криптопровайдер располагает базой данных, в которой хранятся долговременные ключи пользователей. База данных содержит один или более контейнеров ключей (рис. 7). Пользователь может создать несколько контейнеров с различными именами (именем контейнера по умолчанию является имя пользователя в системе).

Подключение к контейнеру производится одновременно с получением контекста криптопровайдера при вызове функции CryptAcquireContext - имя контейнера ключей передается функции вторым ее аргументом. Если второй аргумент содержит пустой указатель (nil), то используется имя по умолчанию, т. е. имя пользователя. В том случае, если доступ к контейнеру не нужен, можно передать в последнем аргументе функции флаг CRYPT_VERIFYCONTEXT; при необходимости создать новый контейнер используется флаг CRYPT_NEWKEYSET; а для удаления существующего контейнера вместе с хранящимися в нем ключами - CRYPT_DELETEKEYSET.

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

Создание ключевых пар

После создания контейнера ключей необходимо сгенерировать ключевые пары обмена ключами и подписи. Эту работу в CryptoAPI выполняет функция CryptGenKey (провайдер, алгоритм, флаги, ключ):

· провайдер - дескриптор криптопровайдера, полученный в результате обращения к функции CryptAcquireContext;

· алгоритм - указывает, какому алгоритму шифрования будет соответствовать создаваемый ключ. Информация об алгоритме, таким образом, является частью описания ключа. Каждый криптопровайдер использует для обмена ключами и подписи строго определенные алгоритмы. Так, провайдеры типа PROV_RSA_FULL, к которым относится и Microsoft Base Cryptographic Provider, реализуют алгоритм RSA. Но при генерации ключей знать это не обязательно: достаточно указать, какой ключ мы собираемся создать - обмена ключами или подписи. Для этого используются мнемонические константы AT_KEYEXCHANGE и AT_SIGNATURE;

· флаги - при создании асимметричных ключей управляет их размером. Используемый нами криптопровайдер позволяет генерировать ключ обмена ключами длиной от 384 до 512 бит**, а ключ подписи - от 512 до 16384 бит. Чем больше длина ключа, тем выше его надежность, поэтому трудно найти причины для использования ключа обмена ключами длиной менее 512 бит, а длину ключа подписи не рекомендуется делать меньше 1024 бит**. По умолчанию криптопровайдер создает оба ключа длиной 512 бит. Необходимую длину ключа можно передать в старшем слове параметра флаги;

· ключ - в случае успешного завершения функции в этот параметр заносится дескриптор созданного ключа.

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

Рассмотрим пример создания ключевых пар при помощи формы, показанной на рис. 8. В поле "Контейнер" можно указать имя контейнера ключей; если оставить это поле пустым, будет использован контейнер по умолчанию. Назначение остальных элементов управления должно быть интуитивно понятным. После генерации ключа в memo-поле выводится отчет о его параметрах. Для этого используется функция CryptGetKeyParam (ключ, параметр, буфер, размер, флаги). Чтобы получить информацию о требуемом параметре, нужно через второй аргумент функции передать соответствующую константу: KP_ALGID - идентификатор алгоритма, KP_KEYLEN - размер ключа, и т. д. См. текст процедуры генерации ключей без операторов обработки ошибок.

Обмен ключами

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

· PUBLICKEYBLOB - используется для сохранения открытых ключей. Поскольку открытые ключи не являются секретными, они сохраняются в незашифрованном виде;

· PRIVATEKEYBLOB - используется для сохранения ключевой пары целиком (открытого и закрытого ключей). Эти данные являются в высшей степени секретными, поэтому сохраняются в зашифрованном виде, причем для шифрования используется сеансовый ключ (и, соответственно, симметричный алгоритм);

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

Экспорт ключей в CryptoAPI выполняется функцией CryptExportKey (экспортируемый ключ, ключ адресата, формат, флаги, буфер, размер буфера):

· экспортируемый ключ - дескриптор нужного ключа;

· ключ адресата - в случае сохранения открытого ключа должен быть равен нулю (данные не шифруются);

· формат - указывается один из возможных форматов экспорта (PUBLICKEYBLOB, PRIVATEKEYBLOB, SIMPLEBLOB);

· флаги - зарезервирован на будущее (должен быть равен нулю);

· буфер - содержит адрес буфера, в который будет записан ключевой BLOB (Binary Large OBject - большой двоичный объект);

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

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

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

Запросить у криптопровайдера дескриптор самого' экспортируемого ключа позволяет функция CryptGetUserKey (провайдер, описание ключа, дескриптор ключа). Описание ключа - это либо AT_KEYEXCHANGE, либо AT_SIGNATURE.

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

В Листинге приведены наиболее важные фрагменты программы

Экспортированные таким образом открытые части ключей понадобятся нам для проверки подписи и расшифровки сеансового ключа.

Импорт ключевых пар во вновь созданный контейнер - это самостоятельная процедура. Необходимо запросить у пользователя название контейнера и пароль, подключиться к провайдеру, создать на основании пароля ключ, считать из файла импортируемые данные в буфер, после чего воспользоваться функцией CryptImportKey (провайдер, буфер, длина буфера, ключ для расшифровки, флаги, импортируемый ключ). Если нужно обеспечить возможность экспорта импортируемой ключевой пары впоследствии, то в параметре флаги необходимо передать значение CRYPT_EXPORTABLE; в противном случае вызов для данной ключевой пары функции CryptExportKey приведет к ошибке.

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

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

Электронная цифровая подпись

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

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

Подписать вычисленный хеш в CryptoAPI позволяет функция CryptSignHash (хеш, описание ключа, комментарий, флаги, подпись, длина подписи). Вторым параметром может быть либо AT_KEYEXCHANGE, либо AT_SIGNATURE (в нашем случае логичнее использовать ключ подписи). Третий параметр в целях безопасности настоятельно рекомендуется оставлять пустым (nil). Флаги в настоящее время также не используются - на месте этого аргумента должен быть нуль. Готовую электронную подпись функция запишет в буфер, адрес которого содержится в предпоследнем параметре, последний же параметр будет содержать длину подписи в байтах.

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

На рис. 12 показана форма, позволяющая подписать заданный файл. См. процедуру, реализующую процесс подписания; результатом ее работы является файл, имеющий структуру, показанную на рис. 11.

Чтобы проверить правильность подписи, получатель подписанного сообщения должен иметь файл с открытым ключом подписи отправителя. В процессе проверки подписи этот ключ импортируется внутрь криптопровайдера. Проверка выполняется функцией CryptVerifySignature (хеш, подпись, длина подписи, открытый ключ, комментарий, флаги). О последних двух аргументах можно сказать то же, что и о параметрах комментарий и флаги функции CryptSignHash, назначение же остальных должно быть понятно. Если подпись верна, функция возвращает true. Значение false в качестве результата может свидетельствовать либо о возникновении ошибки в процессе проверки, либо о том, что подпись оказалась неверной. В последнем случае функция GetLastError вернет ошибку NTE_BAD_SIGNATURE. Для примера приведем наиболее значимые фрагменты программы проверки подписи: См. Листинг

Часть 3.

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

Цифровые конверты

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

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

Создание сеансовых ключей

CryptoAPI позволяет генерировать сеансовые ключи случайным образом - эту работу выполняет функция CryptGenKey, о которой шла речь ранее. Однако при использовании этой возможности за пределами США и Канады приходится учитывать американские ограничения на экспорт средств "сильной криптографии". В частности, до января 2000 года был запрещен экспорт программного обеспечения для шифрования с использованием ключей длиной более 40 бит. Этим объясняется разработка Microsoft двух версий своего криптопровайдера - базовой и расширенной. Базовая версия предназначалась на экспорт и поддерживала симметричные ключи длиной 40 бит; расширенная же версия (Microsoft Enhanced Cryptographic Provider) работала с "полной" длиной ключа (128 бит). Поскольку алгоритм шифрования, как правило, требует использования ключа строго определенной длины, недостающее количество битв в урезанном "экспортном" ключе могло быть заполнено либо нулями, либо случайными данными, которые предлагалось передавать открыто.

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

Итак, CryptoAPI, в экспортном исполнении практически вынуждает нас использовать солт-значения, составляющие бОльшую часть ключа - 88 бит из 128-ми для симметричных алгоритмов в RC2; и RC4. Конечно, при такой эффективной длине ключа криптозащита не может считаться достаточно надежной. В реальной ситуации выход один - воспользоваться криптопровайдером, не ограничивающим длину ключа. Обладатели Windows XP могут прибегнуть к услугам расширенных версий провайдера Microsoft (Enhanced или Strong). Пользователям более старых версий Windows, по-видимому, придется воспользоваться продуктами сторонних разработчиков. Например, свои версии криптопровайдеров предлагают российская компания "Крипто-Про" и шведская "StreamSec". В Украине, насколько известно авторам, разработкой национального провайдера криптографических услуг занимается коллектив харьковских ученых под руководством профессора Горбенко, однако до широкого внедрения дело пока не дошло. Тем не менее, благодаря архитектуре CryptoAPI, прикладные программы могут разрабатываться и отлаживаться и с базовым провайдером Microsoft - так как интерфейс взаимодействия остается неизменным. Поэтому вернемся к обсуждению создания случайных сеансовых ключей.

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

1. при создании ключа функции CryptGenKey передается значение флага CRYPT_EXPORTABLE or CRYPT_CREATE_SALT;

2. с помощью функции CryptGetKeyParam с параметром KP_SALT сгенерированное солт-значение сохраняется в буфере;

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

4. зашифрованные ключевые данные сохраняются или передаются адресату вместе с экспортированным на втором шаге солт-значением.

С другой стороны, солт-значение может быть сгенерировано и отдельно от ключа. Для этого используется функция CryptGenRandom (провайдер, длина, буфер). Здесь параметр длина задает размер генерируемой случайной последовательности в байтах, а последний аргумент задает адрес буфера, в который будет записан результат. Полученное таким образом солт-значение может быть внесено в ключ с помощью функции CryptSetKeyParam (ключ, параметр, данные, флаги). Ей вторым аргументом нужно передать KP_SALT, а третьим - адрес буфера, содержащего сгенерированную последовательность. (Последний аргумент функции зарезервирован на будущее и должен быть равен нулю.).

Блочные шифры

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

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

Наиболее простой и интуитивно понятный способ состоит в том, чтобы разбить исходный текст на блоки соответствующего размера, а затем отдельно каждый блок подвергнуть шифрующему преобразованию. Такой режим использования блочных шифров называют электронной кодовой книгой (ECB - electronic codebook). Его главный недостаток состоит в том, что одинаковые блоки исходного текста при шифровании дадут одинаковые же блоки шифр-текста - а это может существенно облегчить противнику задачу взлома. Поэтому режим ECB не рекомендуется использовать при шифровании текстов, по длине превышающих один блок - в таких случаях лучше воспользоваться одним из режимов, связывающих различные блоки между собой. По умолчанию в CryptoAPI блочные шифры используются в режиме сцепления блоков шифр-текста (CBC - cipher block chaining). В этом режиме при шифровании очередной блок исходного текста вначале комбинируется с предыдущим блоком шифр-текста (при помощи побитового исключающего ИЛИ), а затем полученная последовательность битов поступает на вход блочного шифра (рис. 14). Образующийся на выходе блок шифр-текста используется для шифрования следующего блока. Самый первый блок исходного текста также должен быть скомбинирован с некоторой последовательностью битов, но "предыдущего блока шифр-текста" еще нет; поэтому режимы шифрования с обратной связью требуют использования еще одного параметра - он называется инициализирующим вектором (IV - initialization vector).

Инициализирующий вектор должен генерироваться отдельно с помощью уже известной нам функции CryptGenRandom и, как и солт-значение, передаваться вместе с ключом в открытом виде. Размер IV равен длине блока шифра. Например, для алгоритма RC2, поддерживаемого базовым криптопровайдером Microsoft, размер блока составляет 64 бита (8 байтов).

От слов - к делу

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

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

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

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

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

©Drkb::04013.

Рисование звёзд и многоугольников

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Рисование звёзд и многоугольников. Зависимости: Windows, Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Автор Федоровских Николай. Дата: 3 июня 2002 г. ***************************************************** } Procedure DrawStar(Canvas: TCanvas; Center, Pos: TPoint; R2inPercent, Ends: Byte; DrawCircle: Boolean); { Рисование звёзд и многоугольников. Center - центр фигуры; Pos - точка, лежащая на внешнем радиусе; R2inPercent - сколько процентов от внешнего радиуса составляет внутренний; Ends - число концов (внешних углов) фигуры; DrawCircle - описывать или нет возле фигуры окружность; R2inPercent рекомендую брать в промежутке [0; 100]. Если R2inPercent = 100, то рисуется правильный многоугольник, Число углов которого равно Ends. Все точки лежат на двух окружностях, чередуясь. } Function Max(A, B: Integer): Integer; Begin. If A > B then. Result := A. Else. Result := B; End; Function ArcTan2(Y, X: Extended): Extended; Asm. FLD Y. FLD X. FPATAN. FWAIT. End; Const. Rad = Pi / 180; Var. R, r2, rd, len: Word; I: Integer; MemBS: TBrushStyle; P: array of TPoint; MemC: TColor; A, ad: Double; Begin. If Ends < 2 then. Exit; {начальный угол:}. A := ArcTan2(Center.y - Pos.y, Pos.x - Center.x) * (180 / Pi); R := Max(Abs(Center.x - Pos.x), Abs(Center.y - Pos.y)); R2 := Round(R / 100 * R2inPercent); {внутренний радиус}. If R2inPercent <> 100 then. Len := Ends * 2. Else. Len := Ends; SetLength(p, len); {устанавливаем длину массива точек}. Ad := 360 / len; {угол между рядом стоящими точками}. For i := 0 to len - 1 do. Begin. {если i нечетный, то радиус внутренний, иначе - внешний}. If Odd(i) then. Rd := r2. Else. Rd := R; P[i].x := Trunc(Cos(a * Rad) * rd) + Center.x; P[i].y := Trunc(Sin(a * Rad) * rd) + Center.y; A := a + ad; {увеличиваем угол}. End; {рисуем многоугольник}. Canvas.Polygon(p); If DrawCircle then. Begin. {Рисуем окружность}. MemC := Canvas.Brush.Color; MemBS := Canvas.Brush.Style; Canvas.Brush.Style := bsClear; Canvas.Ellipse(Center.x - R, Center.y - R, Center.x + R, Center.y + R); Canvas.Brush.Color := MemC; Canvas.Brush.Style := MemBS; End; End;

Рисование квадрата мышкой

Code: Private. { Private declarations }. AnchorX, AnchorY, CurX, CurY: Integer; Bounding: Boolean; End; Implementation. Procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. AnchorX := X; CurX := X; AnchorY := Y; CurY := Y; Bounding := True; End; Procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If Bounding then. Begin. Canvas.Pen.Mode := pmNot; Canvas.Pen.Width := 2; Canvas.Brush.Style := bsClear; Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY); CurX := X; CurY := Y; Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY); End; End; Procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If Bounding then. Begin. Bounding := False; Canvas.Pen.Mode := pmNot; Canvas.Brush.Style := bsClear; Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY); End; End;

Рисование линий, Как в Paint.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ToolWin, ComCtrls, ExtCtrls; Type. TForm1 = class(TForm). Image1: TImage; Procedure FormCreate(Sender: TObject); Procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Private. { Private declarations }. StartX: integer; StartY: integer; EndX: integer; EndY: integer; IsMousePressed: boolean; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Begin. IsMousePressed:=false; Image1.Picture.Bitmap:=TBitmap.create(); Image1.Picture.Bitmap.Width:=Image1.Width; Image1.Picture.Bitmap.Height:=Image1.Height. End; Procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. StartX:=X; StartY:=Y; EndX:=StartX; EndY:=StartY; IsMousePressed:=true. End; Procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. IsMousePressed:=false; Image1.Picture.Bitmap.Canvas.Pen.Mode:=pmNOT; Image1.Picture.Bitmap.Canvas.moveTo(StartX, StartY); Image1.Picture.Bitmap.Canvas.lineTo(EndX, EndY); Image1.Picture.Bitmap.Canvas.Pen.Mode:=pmCopy; EndX:=X; EndY:=Y; Image1.Picture.Bitmap.Canvas.moveTo(StartX, StartY); Image1.Picture.Bitmap.Canvas.lineTo(EndX, EndY). End; Procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If isMousePressed then. Begin. Image1.Picture.Bitmap.Canvas.Pen.Mode:=pmNOT; Image1.Picture.Bitmap.Canvas.moveTo(StartX, StartY); Image1.Picture.Bitmap.Canvas.lineTo(EndX, EndY); EndX:=X; EndY:=Y; Image1.Picture.Bitmap.Canvas.moveTo(StartX, StartY); Image1.Picture.Bitmap.Canvas.lineTo(EndX, EndY); Image1.Picture.Bitmap.Canvas.Pen.Mode:=pmCopy. End. End; End.

Более развернутую демку можно найти в папке {$DELPHI7}/Demos/Doc/Graphex Автор: Mischka.

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

©Drkb::03825.

Как нарисовать иконку в TImage.

Code: DrawIcon(Image1.Canvas.Handle, 0, 0, LoadCursor(0, IDC_ARROW));

Рисование на минимизированной иконке

Автор: Nick Hodges (Monterey, CA).

Рисовать практически любую фигуру!

Недавно писал графический редактор и вот просматривая GDI функции заметил LineDDA. При ближайшем рассмотрении эта функция поверга меня в шок, долго я не мог поверить своему счастью. Эта бестия позволяет рисовать практически любую фигуру! Синтаксис:

Function LineDDA(XStart, YStart, XEnd, YEnd: Integer; LineFunc: TFNLineDDAProc; Data: LPARAM): BOOL;

где XStart, YStart - начальные позиции, XEnd, YEnd - задают тень, LineFunc: TFNLineDDAProc - указатель на функцию обратного вызова, параметры объясню далее, Data - дополнительный параметр(у меня в исходнике я использую его для передачи контекста устройства) Функция обратного вызова:

Procedure func(X,Y:integer; lpData:LPARAM);stdcall;

X,Y - текущие координаты мыши, lpData - дополнительный параметр о котором я уже писал выше. К сему прикрепляю исходник, в котором с помощью этой ф-ции рисуется крест. Надеюсь кому-нибудь пригодится.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls; Type. TForm1 = class(TForm). Image1: TImage; Button1: TButton; Procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure FormCreate(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; B:boolean; Implementation. {$R *.dfm}. Procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. B:=true; End; Procedure func(X,Y:integer; lpData:LPARAM);stdcall; Begin. Rectangle(lpData,X,Y,X-10,Y-10); Rectangle(lpData,X,Y,X-20,Y+10); Rectangle(lpData,X,Y,X-10,Y+30); Rectangle(lpData,X,Y,X+10,Y+10); Sleep(10); End; Procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If b then LineDDA(X, Y, X-2, Y+2, @func, Image1.Canvas.Handle); Image1.Repaint; End; Procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. B:=false; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. B:=false; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Image1.Canvas.FillRect(Bounds(Image1.Left,Image1.Top,Image1.Width,Image1.Height)); End; End.

Рисуем график функции в Delphi.

В этой статье мы рассмотрим несколько способов нарисовать график какой-нибудь функции. Рисовать график мы будем на канве компонента Image.

Рисование по пикселам

Рисовать на канве можно разными способами. Первый вариант - рисовать по пикселям. Для этого используется свойство канвы Pixels. Это свойство представляет собой двумерный массив, который отвечает за цвета канвы. Например Canvas.Pixels[10,20] - соответствует цвету пикселя с координатами (10,20). С массивом пикселей можно обращаться, как с любым свойством: изменять цвет, задавая пикселю новое значение, или определять его цвет, по хранящемуся в нем значению. На примере ниже мы зададим черный цвет пикселю с координатами (10,20):

Code: Canvas.Pixels[10,20]:=clBlack;

Теперь мы попробуем нарисовать график функции F(x), если известен диапазон ее изменений Ymax и Ymin, и диапазон изменения аргумента Xmax и Xmin. Для этого мы напишем пользовательскую функцию, которая будет вычислять значение функции F в точке x, а также будет возвращать максимум и минимум функции и ее аргумента.

Code: Function Tform1.F(x:real; var Xmax,Xmin,Ymax,Ymin:real):real; Begin. F:=Sin(x); Xmax:=4*pi; Xmin:=0; Ymax:=1; Ymin:=-1; End;

Не забудьте также указать заголовок этой функциии в разделе Public:

Code: Public. { Public declarations }. Function F(x:real; var Xmax,Xmin,Ymax,Ymin:real):real;

Здесь для ясности мы просто указали диапазон изменения функции Sin(x) и ее аргумента, ниже эта функция будет описана целиком. Параметры Xmax, Xmin, Ymax, Ymin - описаны со словом Var потому что они являются входными-выходными, т.е. через них функция будет возвращать значения вычислений этих данных в основную программу. Поэтому надо объявить Xmax, Xmin, Ymax, Ymin как глобальные переменные в разделе Implementation:

Code: Implementation. Var Xmax,Xmin,Ymax,Ymin:real;

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Var x,y:real; PX,PY:longInt; Begin. For PX:=0 to Image1.Width do. Begin. X:=Xmin+PX*(Xmax-Xmin)/Image1.Width; Y:=F(x,Xmax,Xmin,Ymax,Ymin); PY:=trunc(Image1.Height-(y-Ymin)*Image1.height/(Ymax-Ymin)); Image1.Canvas.Pixels[PX,PY]:=clBlack; End; End;

В этом коде вводятся переменные x и y, являющиеся значениями аргумента и функции, а также переменные PX и PY, являющиеся координатами пикселей, соответствующих x и y. Сама процедура состоит из цикла по всем значениям горизонтальной координаты пикселей PX компонента Image1. Сначала выбранное значение PX пересчитывается в соответствующее значение x. Затем производится вызов функции F(x) и определяется ее значение Y. Это значение пересчитывается в вертикальную координату пикселя PY.

Рисование с помощью пера Pen.

У канвы имеется свойство Pen - перо. Это объект в свою очередь имеющий ряд свойств. Одно из них свойство Color - цвет, которым наносится рисунок. Второе свойство Width - ширина линии, задается в пикселах (по умолчанию 1).

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

PsSolid. Сплошная линия PsDash. Штриховая линия PsDot. Пунктирная линия PsDashDot. Штрих пунктирная линия PsDashDotDot. Линия, чередующая штрих и два пунктира PsClear. Отсутствие линии PsInsideFrame. Сплошная линия, но при Width > 1 допускающая цвета, отличные от палитры Windows.

Все стили со штрихами и пунктирами доступны только при толщине линий равной 1. Иначе эти линии рисуются как сплошные.

У канвы имеется свойство PenPos, типа TPoint. Это свойство определяет в координатах канвы текущую позицию пера. Перемещение пера без прорисовки осуществляется методом MoveTo(x,y). После вызова этого метода канвы точка с координатами (x,y) становится исходной, от которой методом LineTo(x,y) можно провести линию, в любую точку с координатами (x,y).

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

Code: Image1.Canvas.MoveTo(0,Image1.height div 2);

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

Code: Image1.Canvas.LineTo(PX,PY);

Таким образом у Вас должен получиться такой код:

Code: Procedure TForm1.Button1Click(Sender: TObject); Var x,y:real; PX,PY:longInt; Begin. Image1.Canvas.MoveTo(0,Image1.height div 2); For PX:=0 to Image1.Width do. Begin. X:=Xmin+PX*(Xmax-Xmin)/Image1.Width; Y:=F(x,Xmax,Xmin,Ymax,Ymin); PY:=trunc(Image1.Height-(y-Ymin)*Image1.height/(Ymax-Ymin)); Image1.Canvas.Pixels[PX,PY]:=clBlack; Image1.Canvas.LineTo(PX,PY); End; End;

Как Вы уже успели заметить, если запустили программу, качество рисования графика пером, намного лучше, чем рисования по пикселям.

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

Code: ... Type. TForm1 = class(TForm). Button1: TButton; Image1: TImage; Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. Function F(x:real):real; Procedure Extrem1(Xmax,Xmin:real; Var Ymin:real); Procedure Extrem2(Xmax,Xmin:real; Var Ymax:real); { Public declarations }. End; Var. Form1: TForm1; Implementation. Const e=1e-4;//точность одна тысячная. Var Xmax,Xmin,Ymax,Ymin:real; {$R *.DFM}. Function Tform1.F(x:real):real; Begin. F:=Sin(x); End; //поиск минимума функции. Procedure TForm1.Extrem1(Xmax,Xmin:real; Var Ymin:real); Var x,h:real; j,n:integer; Begin. N:=10; Repeat. X:=Xmin; N:=n*2; H:=(Xmax-Xmin)/n; Ymin:=F(Xmin); For j:=1 to n do begin. If f(x)<Ymin then Ymin:=f(x); X:=x+h; End; Until abs(f(Ymin)-f(Ymin+h))<e; End; //поиск максимума функции. Procedure TForm1.Extrem2(Xmax,Xmin:real; Var Ymax:real); Var x,h:real; j,n:integer; Begin. N:=10; Repeat. X:=Xmin; N:=n*2; H:=(Xmax-Xmin)/n; Ymax:=F(Xmin); For j:=1 to n do begin. If f(x)>=Ymax then Ymax:=f(x); X:=x+h; End; Until abs(f(Ymax)-f(Ymax+h))<e; End; Procedure TForm1.Button1Click(Sender: TObject); Var x,y:real; PX,PY:longInt; Begin. //здесь необходимо указать диапазон изменения x. Xmax:=8*pi; Xmin:=0; //вычисляем экстремумы функции. Extrem1(Xmax,Xmin,Ymin); Extrem2(Xmax,Xmin,Ymax); //рисуем график функции. Image1.Canvas.MoveTo(0,Image1.height div 2); For PX:=0 to Image1.Width do. Begin. X:=Xmin+PX*(Xmax-Xmin)/Image1.Width; Y:=F(x); PY:=trunc(Image1.Height-(y-Ymin)*Image1.height/(Ymax-Ymin)); Image1.Canvas.Pixels[PX,PY]:=clBlack; Image1.Canvas.LineTo(PX,PY); End; End; End.

Ну вот и все, надеюсь эта статья оказалась Вам интересна!

Источник: http://delphid.dax.ru.

©Drkb::04216.

Code: Procedure TForm1.Button3Click(Sender: TObject); Var. X, y: array[1..50] of double; I: integer; Scalex, scaley, ymin, ymax, xmin, xmax: double; Begin. For i := 1 to 50 do. Begin. Y[i] := sin(i * 0.5); X[i] := i; End; Xmin := x[1]; Xmax := x[1]; Ymin := y[1]; Ymax := y[1]; For i := 2 to 50 do. Begin // ??? ??????????? ymin:=MinValue(y); ? ?.?. If y[i] < ymin then. Ymin := y[i]; If y[i] > ymax then. Ymax := y[i]; If x[i] < xmin then. Xmin := x[i]; If x[i] > xmax then. Xmax := x[i]; End; Scalex := paintbox1.Width / (xmax - xmin); Scaley := paintbox1.Height / (ymax - ymin); With paintbox1.canvas do. Begin. Moveto(trunc(scalex * (x[1] - xmin)), paintbox1.height - trunc(scaley * (y[1]. - ymin))); For i := 2 to 50 do. Lineto(trunc(scalex * (x[i] - xmin)), paintbox1.height - trunc(scaley * (y[i] - ymin))); End; End;

©Drkb::04217.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Deploying Midas.

You need to purchase a MIDAS license for the application server. When you purchase a MIDAS license you receive a CD with the MIDAS suite for install. You need to install the.

EXE's and DLL's that you created for your app, the rest (which also includes the runtime packages, BDE, SQL Links, etc.) are installed by the MIDAS software.

©Drkb::04335.

Detect if a USB device is connected or disconnected?

Code: Unit U_Usb; Interface. Uses. Windows, Messages, SysUtils, Classes, Forms; Type. PDevBroadcastHdr = ^DEV_BROADCAST_HDR; DEV_BROADCAST_HDR = packed record. Dbch_size: DWORD; Dbch_devicetype: DWORD; Dbch_reserved: DWORD; End; PDevBroadcastDeviceInterface = ^DEV_BROADCAST_DEVICEINTERFACE; DEV_BROADCAST_DEVICEINTERFACE = record. Dbcc_size: DWORD; Dbcc_devicetype: DWORD; Dbcc_reserved: DWORD; Dbcc_classguid: TGUID; Dbcc_name: short; End; Const. GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}'; DBT_DEVICEARRIVAL = $8000; // system detected a new device. DBT_DEVICEREMOVECOMPLETE = $8004; // device is gone. DBT_DEVTYP_DEVICEINTERFACE = $00000005; // device interface class. Type. TComponentUSB = class(TComponent). Private. FWindowHandle: HWND; FOnUSBArrival: TNotifyEvent; FOnUSBRemove: TNotifyEvent; Procedure WndProc(var Msg: TMessage); Function USBRegister: Boolean; Protected. Procedure WMDeviceChange(var Msg: TMessage); dynamic; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Published. Property OnUSBArrival: TNotifyEvent read FOnUSBArrival write FOnUSBArrival; Property OnUSBRemove: TNotifyEvent read FOnUSBRemove write FOnUSBRemove; End; Implementation. Constructor TComponentUSB.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); FWindowHandle := AllocateHWnd(WndProc); USBRegister; End; Destructor TComponentUSB.Destroy; Begin. DeallocateHWnd(FWindowHandle); Inherited Destroy; End; Procedure TComponentUSB.WndProc(var Msg: TMessage); Begin. If (Msg.Msg = WM_DEVICECHANGE) then. Begin. Try. WMDeviceChange(Msg); Except. Application.HandleException(Self); End; End. Else. Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam); End; Procedure TComponentUSB.WMDeviceChange(var Msg: TMessage); Var. DevType: Integer; Datos: PDevBroadcastHdr; Begin. If (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then. Begin. Datos := PDevBroadcastHdr(Msg.lParam); DevType := Datos^.dbch_devicetype; If devType = DBT_DEVTYP_DEVICEINTERFACE then. Begin // USB Device. If Msg.wParam = DBT_DEVICEARRIVAL then. Begin. If Assigned(FOnUSBArrival) then. FOnUSBArrival(Self); End. Else. Begin. If Assigned(FOnUSBRemove) then. FOnUSBRemove(Self); End; End; End; End; Function TComponentUSB.USBRegister: Boolean; Var. Dbi: DEV_BROADCAST_DEVICEINTERFACE; Size: Integer; R: Pointer; Begin. Result := False; Size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE); ZeroMemory(@dbi, Size); Dbi.dbcc_size := Size; Dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE; Dbi.dbcc_reserved := 0; Dbi.dbcc_classguid := GUID_DEVINTERFACE_USB_DEVICE; Dbi.dbcc_name := 0; R := RegisterDeviceNotification(FWindowHandle, @dbi, DEVICE_NOTIFY_WINDOW_HANDLE. ); If Assigned(r) then Result := True; End; End.

©Drkb::01354.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php.

Detect simple collision and transparency.

Code: { Simple collision detection and transparency, by Erwin Haantjes. DelphiApplicationDiscussion@hotmail.com. -------------------------------------------------------------- It's not uncommon that collision detection in games is one of the most called functions. There are several ways of doing collision detection and this article describes a method. For 2D games using bounding boxes (rectangles). Perfect collision detection down to the pixel is of course what (theoretically) is the best. However, checking each pixel against each other for all objects every frame in a game. Is slow, very slow. So a simplier way is needed, this is where bounding boxes comes in. Imagine that you draw a rectangle, like a frame, around an object (the player spaceship. For examle). Then do the same thing for all the other objects in the game. Now calculate. If these rectangles intercept each other to determine a collision, instead of checking. Each pixels. This method is much faster, not as precise, but usually exact enough. +------------+ | XX | | XXXXXX | |XXXXXXXXXXXX| | XXXXXX+-|----------+ | XX |X|XX XXXX| +------------+ XX XX | | XXXX | | XX XX | |XXXX XXXX| +------------+ A problem is that sometimes a collision is detected when visually it seems like the object. Didn't touch. This usually occurs when any of the objects is shaped like a sphere. To. Compensate this we use an offset when checking if the bounding boxes intercept. By making. The bounding boxes slightly smaller than the object itself, detection usually seems accurate. Enough. As mentioned before, we sacrifice precision for speed, but this is a way to compensate. The precision to make it "feel" more exact. Here is the function which does the real collision detection of two objects. In this example. The player's coordinates are R1, while the enemy's coordinates are R2. You can use an. Offset for the X and Y coordinates to precize the detection (especially when you using. Shaped objects). } Function CheckBoundryCollision( R1, R2 : TRect; pR : PRect = nil; OffSetY : LongInt = 0; OffSetX : LongInt = 0): boolean; {overload;}. // Simple collision test based on rectangles. Begin. // Rectangle R1 can be the rectangle of the character (player). // Rectangle R2 can be the rectangle of the enemy. If( pR <> nil ) then. Begin. // Simple collision test based on rectangles. We use here the. // API function IntersectRect() which returns the intersection rectangle. With( R1 ) do. R1:=Rect( Left+OffSetX, Top+OffSetY, Right-(OffSetX * 2), Bottom-(OffSetY * 2)); With( R2 ) do. R2:=Rect( Left+OffSetX, Top+OffSetY, Right-(OffSetX * 2), Bottom-(OffSetY * 2)); Result:=IntersectRect( pR^, R1, R2 ); End. Else begin. // Simple collision test based on rectangles. We can also use the. // API function IntersectRect() but i believe this is much faster. Result:=( NOT ((R1.Bottom - (OffSetY * 2) < R2.Top + OffSetY). Or(R1.Top + OffSetY > R2.Bottom - (OffSetY * 2)). Or( R1.Right - (OffSetX * 2) < R2.Left + OffSetX). Or( R1.Left + OffSetX > R2.Right - (OffSetX * 2)))); End; End; { Also you can make an overloaded function with the same name based on handles (to make it easier). } Function CheckBoundryCollision( h1, h2 : Hwnd; pR : PRect = nil; OffSetY : LongInt = 0; OffSetX : LongInt = 0): boolean; {overload;}. Var. R1 : TRect; R2 : TRect; Begin. FillChar( R1, SizeOf( R1 ), 0 ); FillChar( R2, SizeOf( R2 ), 0 ); // Note: You will get here the REAL screen coordinates. // It doesn't matter if a control is placed inside a panel or something. GetWindowRect( h1, R1 ); GetWindowRect( h2, R2 ); Result:=CheckBoundryCollision( R1, R2, pR, OffsetY, OffSetX ); End; As an example, the above function may be used in a (threated timer) loop like this to check the player against multiple enemies: For i := 0 to Length( Enemies ) - 1 do. If( CheckCollision( Player.Handle, Enemies[i].Handle, nil, 4, 4 )) then. GameOver; { Bottom line is that usually it's enough if it "looks" real, and less important that. It "is" real. It's a balance between how exact we want it, and how fast we need it to perform. I have used this methods in a simple game and it just works fine. Let's talk about transparency. You can use Regions to create special shaped Wincontrols. For example: A TPanel with a TImage. On it (Panel1 and Image1). You can shape the panel to the image using the following examples: } Function CreateRegion( Bitmap : TBitmap; Rect : TRect; TransColor : TColor ) : hRgn; Var. I1, Count : LongInt; X,y : LongInt; C1 : Cardinal; C,t : TColor; Msg : TMsg; Begin. Result:=0; If( NOT Assigned( Bitmap )) then. Exit; Count :=0; {if( TransColor = clAutomatic ) then. }t:=Bitmap.Canvas.Pixels[ Rect.Left, Rect.Top ]. {else t:=TransColor}; With( Bitmap.canvas ) do. For y := Rect.Top to Rect.Bottom do. Begin. // Sort of the same like Application.ProcessMessages but doesn't require. // the bulky Forms unit. PeekMessage( Msg, 0, 0, 0, PM_REMOVE ); X:=Rect.Left; While( x <= Rect.Right ) do. Begin. C:=Pixels[ x, y ]; If( C <> t ) then. Begin. I1 := x; While( C <> t ) do. Begin. Inc(i1); C:=Pixels[ i1, y ]; If( i1 >= Rect.Right ) then. Break; End; C1:=CreateRectRgn( x-Rect.Left,y-Rect.Top, i1-Rect.Left, (y-Rect.Top) + 1 ); If( count = 0 ) then. Result:=c1. Else begin. CombineRgn( Result, Result, c1, RGN_OR ); DeleteObject( c1 ); End; Inc( Count ); X := i1; Continue; End; Inc(x); End; End; If( Count = 0 ) and ( Result > 0 ) then. Begin. DeleteObject( Result ); Result:=0; End; End; // Put this somewhere in your code (for example in the FormCreate event). Begin. Image1.Left:=0; Image1.Top:=0; Image1.AutoSize:=TRUE; Panel1.BevelInner:=bvNone; Panel1.BevelOuter:=bvNone; Panel1.Width:=Image1.Width; Panel1.Height:=Image1.Height; // Create a region of the bitmap that is inside the image and set the region for the window. // Note: In this example the transparent color is black. Make sure the transparent (background) color is. // black! To be sure that you using the right color, you can also try this: Image1.Picture.Bitmap.Pixels[ 0, 0 ]. With( Panel1 ) do. SetWindowRgn( Handle, CreateRegion( Image1.Picture.Bitmap, Rect( 1, 1, Width, Height ), clBlack )); End; { Note: When you move the panel it is possible that the bitmap starts to flicker. You can create an. Message handler for the message WN_EREASEBKGND to avoid the flicker. See the help of Delphi how to. Create new components and/or message handlers if do not know. Here is an example: Procedure TMyPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd); Begin. If( csDesigning in ComponentState ) then. Inherited. Else Message.Result:=1; // Fake erase. End; NOTE: Absolutly no warranty to this code. This is just an example. It is possible that you need to make some. Improvements to the code to give it a more proffesional behaviour. This article was aimed towards beginners wanting get into game programming, I'll hope it was helpful. Regards and good luck, Erwin Haantjes. }

DFM -->TXT, TXT --> DFM.

Use the Convert.exe file found in the Delphi\C++ Builder.

Bin directory.

Example:

C:\Delphi\convert enum.dfm enum.txt.

C:\Delphi\convert enum.txt enum.dfm.

©Drkb::04286.

Disable CTRL+ALT+DELETE under XP.

Code: Procedure DisableTaskMgr(bTF: Boolean); Var. Reg: TRegistry; Begin. Reg := TRegistry.Create; Reg.RootKey := HKEY_CURRENT_USER; Reg.OpenKey('Software', True); Reg.OpenKey('Microsoft', True); Reg.OpenKey('Windows', True); Reg.OpenKey('CurrentVersion', True); Reg.OpenKey('Policies', True); Reg.OpenKey('System', True); If bTF = True then. Begin. Reg.WriteString('DisableTaskMgr', '1'); End. Else if bTF = False then. Begin. Reg.DeleteValue('DisableTaskMgr'); End; Reg.CloseKey; End; // Example Call: Procedure TForm1.Button1Click(Sender: TObject); Begin. DisableTaskMgr(True); End;

Do an application loader with TCP?

Code: { Loading Delphi apps without a browser and on Win as Linux as well needs a. Decision once. With a loader on the client side, no further installation is in charge. We had the requirement starting different Delphi apps from a. Linux or windows server, wherever you are. We call it Delphi Web Start (DWS). The dws-client gets a list and after clicking on it, the app is. Loading from server to client with just a stream. First we had to choose between a ftp and a tcp solution. The. Advantage of tcp is the freedom to define a separate port, which. Was "services, port 9010 - DelphiWebStart". You will need indy. Because it is simple to use and very fast. The tcp-server comes from indy which has one great advantage: CommandHandlers is a collection of text commands that will be. Processed by the server. This property greatly simplify the. Process of building servers based on text protocols. First we start with DWS_Server, So we define two command handlers: } CTR_LIST = 'return_list'; CTR_FILE = 'return_file'; { By starting the tcp-server it returns with the first command. Handler "CTR_LIST" a list of the apps: } Procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread); ... // comes with writeline from client. If sRequest = CTR_LIST then begin. For idx:= 0 to meData.Lines.Count - 1 do. Athread.Connection.WriteLn(ExtractFileName(meData.Lines[idx])); AThread.Connection.WriteLn('::END::'); AThread.Connection.Disconnect; { One word concerning the thread: In the internal architecture there are 2 threads categories. First is a listener thread that "listen" and waits for a. Connection. So we don't have to worry about threads, the built in. Thread will be served by indy though parameter: } IdTCPServer1Execute(AThread: TIdPeerThread). { When our dws-client is connected, this thread transfer all the. Communication operations to another thread. This technique is very efficient because your client application. Will be able to connect any time, even if there are many. Different connections to the server. } //The second command "CTR_FILE" transfers the app to the client: If Pos(CTR_FILE, sRequest) > 0 then begin. IPos := Pos(CTR_FILE, sRequest); FileName := GetFullPath(FileName); If FileExists(FileName) then begin. LbStatus.Items.Insert(0, Format('%-20s %s', [DateTimeToStr(now), 'Transfer starts ...'])); FileStream := TFileStream.Create(FileName, fmOpenRead + FmShareDenyNone); AThread.Connection.OpenWriteBuffer; AThread.Connection.WriteStream(FileStream); AThread.Connection.CloseWriteBuffer; FreeAndNil(FileStream); AThread.Connection.Disconnect; { Now let's have a look at the client side. The client connects to. The server, using the connect method of TIdTcpClient. In this. Moment, the client sends any command to the server, in our case. (you remember DelphiWebStart) he gets the list of available apps: } With IdTCPClient1 do begin. If Connected then DisConnect; ShowStatus; Host:= edHost.Text; Port:= StrToInt(edPort.Text); Connect; WriteLn(CTR_LIST); //After clicking on his choice, the app will be served: With IdTCPClient1 do begin. ExtractFileName(lbres.Items[lbres.ItemIndex])])); WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]); FileName:= ExpandFileName(edPath.Text + '/' + ExtractFileName(lbres.Items[lbres.ItemIndex])); ... FileStream := TFileStream.Create(FileName, fmCreate); While connected do begin. ReadStream(FileStream, -1, true); .... {$IFDEF LINUX}. Execv(pchar(filename),NIL); //libc.system(pchar(filename)); {$ENDIF}. {$IFDEF MSWINDOWS}. // shellapi.WinExec('c:\testcua.bat', SW_SHOW); With lbstatus.items do begin. Case shellapi.shellExecute(0,'open', pchar(filename), '',NIL, SW_SHOWNORMAL) of. 0: insert(0, 'out of memory or resources'); ERROR_BAD_FORMAT: insert(0, 'file is invalid in image'); ERROR_FILE_NOT_FOUND: insert(0,'file was not found'); ERROR_PATH_NOT_FOUND: insert(0,'path was not found'); End; Insert(0, Format('%-20s %s', [DateTimeToStr(now), filename + ' Loaded...'])); End. {$ENDIF}. { One note about execution on linux with libc-commands; there will. Be better solutions (execute and wait and so on) and we still. Work on it, so I'm curious about comments on. "Delphi Web Start". Therfore my aim is to publish improvments in a basic framework on. Sourceforge.net depends on your feedback ;). Many thanks to Dr. Karlheinz Morth with a first glance. Test your server with the telnet program. Type telnet. Hostname:9010 and then: 'return_list' and you'll get the list. From the apps you defined in a txt-file on the server. } MeData.Lines.LoadFromFile(ExpandFileName(FILE_PATH)); { I know that we haven't implement an error handling procedure, But for our scope this example is almost. Sufficient. Code is available: http://max.kleiner.com/download/dws.zip. }

DOC ---> HTML.

Code: Var. Fname: string; WordAppl, WordDoc: OleVariant; Begin. With TOpenDialog.Create(nil) do. Try. Filter := 'word documents (*.doc)|*.doc'; If not Execute then Exit; Fname := FileName; Finally. Free; End; WordAppl := CreateOleObject('Word.Application'); Try. WordDoc := WordAppl.Documents.Open(fname); Fname := ExtractFilePath(fname) + 'test.htm'; WordDoc.SaveAs(FileName := fname, FileFormat := wdFormatHTML); Finally. WordAppl.Quit; End; End;

©Drkb::04282.

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

Автор: jack128.

Руководство по BTRIEVE.

ВВЕДЕНИЕ В BTRIEVE.

Does Delphi have an equivalent to the Visual Basic SendKeys function?

The following example demonstrates procedures that provide the capibility of sending keystrokes to any window control capable of receiving keyboard input. You may use this technique to toggle the num lock, caps lock, and scroll lock keys under Windows NT. This same technique works for toggling caps lock and scroll lock keys under Windows 95, but it will not work for num lock.

Note that there are four procedures provided: SimulateKeyDown(), SimulateKeyUp(), SimulateKeystroke(), and SendKeys(), to allow greater control in your ability to send keystrokes.

The SimulateKeyDown(), SimulateKeyUp(), and SimulateKeystroke() procedures expect a virtural key code (like VK_F1). The SimulateKeystroke() procedure accepts an extra parameter that is useful when simulating the PrintScreen key. When extra is set to zero, the entire screen will be captured to the windows clipboard. When extra is set to one, only the active window will be captured.

The four button click methods demonstrate the use of these functions:

ButtonClick1 - Toggles the cap lock.

ButtonClick2 - Captures the entire screen to the clipboard.

ButtonClick3 - Capture the active window to the clipboard.

ButtonClick4 - Set the focus to an edit control and sends it a string.

Example:

Code: Procedure SimulateKeyDown(Key : byte); Begin. Keybd_event(Key, 0, 0, 0); End; Procedure SimulateKeyUp(Key : byte); Begin. Keybd_event(Key, 0, KEYEVENTF_KEYUP, 0); End; Procedure SimulateKeystroke(Key : byte; Extra : DWORD); Begin. Keybd_event(Key, Extra, 0, 0); Keybd_event(Key, Extra, KEYEVENTF_KEYUP, 0); End; Procedure SendKeys(s : string); Var. I : integer; Flag : bool; W : word; Begin. {Get the state of the caps lock key}. Flag := not GetKeyState(VK_CAPITAL) and 1 = 0; {If the caps lock key is on then turn it off}. If flag then. SimulateKeystroke(VK_CAPITAL, 0); For i := 1 to Length(s) do begin. W := VkKeyScan(s[i]); {If there is not an error in the key translation}. If ((HiByte(w) $FF) and. (LoByte(w) $FF)) then begin. {If the key requires the shift key down - hold it down}. If HiByte(w) and 1 = 1 then. SimulateKeyDown(VK_SHIFT); {Send the VK_KEY}. SimulateKeystroke(LoByte(w), 0); {If the key required the shift key down - release it}. If HiByte(w) and 1 = 1 then. SimulateKeyUp(VK_SHIFT); End; End; {if the caps lock key was on at start, turn it back on}. If flag then. SimulateKeystroke(VK_CAPITAL, 0); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. {Toggle the cap lock}. SimulateKeystroke(VK_CAPITAL, 0); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. {Capture the entire screen to the clipboard}. {by simulating pressing the PrintScreen key}. SimulateKeystroke(VK_SNAPSHOT, 0); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. {Capture the active window to the clipboard}. {by simulating pressing the PrintScreen key}. SimulateKeystroke(VK_SNAPSHOT, 1); End; Procedure TForm1.Button4Click(Sender: TObject); Begin. {Set the focus to a window (edit control) and send it a string}. Application.ProcessMessages; Edit1.SetFocus; SendKeys('Delphi Is RAD!'); End;

©Drkb::00298.

Does Delphi have an equivalent for the VB function DoEvents?

Code: Application.ProcessMessages.

©Drkb::00299.

Does Kylix support ODBC?

You can connect using an ODBC driver via dbExpress in Kylix. There is an ODBC dbExpress gateway driver on the Kylix companion CD.

©Drkb::04585.

Does Kylix support Postgres?

The Kylix 2 dbExpress PostgreSQL/RedHat database driver is available for download from the http://www.borland.com/kylix/webreg/k2/k2_registeredusers.html.

You can also use ODBC.

©Drkb::04584.

Русификация консольных приложений в Delphi.

С периодичностью раз в месяц-полтора конференция RU.DELPHI оглашается стонами на тему “Консоль не поет по-русски”, за которыми стоит вывод текста в консольных приложениях в кодировке OEM (Delphi IDE, как и все GUI, работает в ANSI).

Drag and Drop для TListBox.

Drag and Drop для TListBox на примере двойного списка

Drag and Drop в TOutline.

Вам нужно перехватывать в TOutline сообщение wm_DropFiles. Для этого необходимо создать его потомка. Также, вы должны убедиться в том, что дескриптор TOutline Handle хотя бы раз передавался в качестве параметра функции DragAcceptFiles. Для определения положения мыши в момент перетаскивания используется DragQueryPoint. Если вы прочтете разделы в WINAPI.HLP по DragAcceptFiles, wm_DropFiles, DragQueryFile, DragQueryPoint и DragFinish, то вы поймете, как все это работает.

©Drkb::00707.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Установите DragMode = dmManual, создайте OnMouseDownHandler, внутри обработчика осуществите вызов BeginDrag(False). BeginDrag(False) в действительности не начинает перемещение, пока пользователь не переместит объект больше, чем на 5 пикселей, так что если пользователь просто щелкнет на компоненте, операция перетаскивания даже не начнется.

Drag and Drop в TTreeView.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, ComCtrls; Type. TForm1 = class(TForm). TreeView1: TTreeView; Procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Private. Procedure MoveNode(TargetNode, SourceNode: TTreeNode); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.MoveNode(TargetNode, SourceNode: TTreeNode); Var. NodeTmp: TTreeNode; I: Integer; Begin. With TreeView1 do. Begin. // проверяем, является ли целевой элемент предком перетаскиваемого. NodeTmp := TargetNode.Parent; While Assigned(NodeTmp) do. If NodeTmp = SourceNode then. Abort. Else. NodeTmp := NodeTmp.Parent; // копируем перетаскиваемый элемент в новосозданный. NodeTmp := Items.AddChild(TargetNode, SourceNode.Text); NodeTmp.Data := SourceNode.Data; For I := 0 to SourceNode.Count - 1 do. MoveNode(NodeTmp, SourceNode.Item[I]); Selected := NodeTmp; TopItem := NodeTmp.getPrev; TargetNode.Expand(True); End; End; Procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Var. TargetNode, SourceNode: TTreeNode; Begin. With TreeView1 do. Begin. TargetNode := GetNodeAt(X, Y); SourceNode := Selected; If (TargetNode = SourceNode) or (TargetNode = nil) then. Begin. EndDrag(False); Exit; End; MoveNode(TargetNode, SourceNode); SourceNode.Free; End; End; Procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Var. SourceNode, TargetNode, NodeTmp: TTreeNode; Begin. If Sender = TreeView1 then. Try. // скроллинг дерева при перетаскивании. If Y > TreeView1.Height - 10 then. Begin. TreeView1.TopItem := TreeView1.TopItem.getNext; Sleep(100); // пауза. End else. If Y < 10 then. Begin. TreeView1.TopItem := TreeView1.TopItem.getPrev; Sleep(100); // пауза. End; TargetNode := TreeView1.GetNodeAt(X, Y); SourceNode := TreeView1.Selected; If (TargetNode = nil) or (TargetNode = SourceNode) then Abort; Accept := True; // проверяем, является ли целевой элемент предком перетаскиваемого. NodeTmp := TargetNode.Parent; While Assigned(NodeTmp) do. If NodeTmp = SourceNode then. Abort. Else. NodeTmp := NodeTmp.Parent; Except. Accept := False; End; End; End.

Автор: Smike.

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

©Drkb::00374.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls; Type. TForm1 = class(TForm). TreeView1: TTreeView; Label1: TLabel; Procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Private. { Private declarations }. Procedure MoveNode(TargetNode, SourceNode : TTreeNode); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // // Procedure which will move node and its subnodes. // Procedure TForm1.MoveNode(TargetNode, SourceNode : TTreeNode); Var. NodeTmp : TTreeNode; I : Integer; Begin. With TreeView1 do. Begin. NodeTmp := Items.AddChild(TargetNode,SourceNode.Text); For i := 0 to SourceNode.Count -1 do. Begin. MoveNode(nodeTmp,SourceNode.Item[i]); End; End; End; Procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Var. TargetNode, SourceNode : TTreeNode; Begin. With TreeView1 do. Begin. TargetNode := GetNodeAt(X,Y); // Get target node. SourceNode := Selected; If (TargetNode = nil) then. Begin. EndDrag(False); Exit; End; MoveNode(TargetNode,SourceNode); SourceNode.Free; End; End; Procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. If (Sender = TreeView1) then // If TRUE than accept the draged item. Begin. Accept := True; End; End; End.

Drag and Drop c Explorer.

Code: Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Procedure FileIsDropped(var Msg: TMessage); message WM_DropFiles; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. Uses. Shellapi; {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. DragAcceptFiles(Handle, True); End; Procedure TForm1.FileIsDropped(var Msg: TMessage); Var. HDrop: THandle; FName: array[0..254] of CHAR; NumberOfFiles: INTEGER; FCounter: INTEGER; Names: string; Begin. HDrop := Msg.WParam; NumberOfFiles := DragQueryFile(hDrop, -1, fName, 254); Names := ''; For fCounter := 1 to NumberOfFiles do. Begin. DragQueryFile(hDrop, fCounter, fName, 254); // Здесь вы получаете один к одному имя вашего файла. Names := Names + #13#10 + fName; End; ShowMessage('Бросаем ' + IntToStr(NumberOfFiles) + ' файла(ов) : ' + Names); DragFinish(hDrop); End; End.

Drag and Drop из RichEdit.

Code: Var. Form1: TForm1; Richcopy: string; Transfering: boolean; Implementation. {$R *.DFM\}. Procedure TForm1.RichEdit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If length(richedit1.seltext)>0 then begin. Richcopy:=richedit1.seltext; Transfering:=true; End; //seltext. End; Procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If transfering then begin. Transfering:=false; Listbox1.items.add(richcopy); End; //transfering. End;

Drag and Drop из TScrollBox.

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

Drag and Drop несколько элементов в TListView.

Code: { ListView1.DragMode := dmAutomatic }. Procedure TForm1.ListView1DragDrop(Sender, Source: TObject; X, Y: Integer); Var. DragItem, DropItem, CurrentItem, NextItem: TListItem; Begin. If Sender = Source then. With TListView(Sender) do. Begin. DropItem := GetItemAt(X, Y); CurrentItem := Selected; While CurrentItem <> nil do. Begin. NextItem := GetNextItem(CurrentItem, SdAll, [IsSelected]); If DropItem = nil then DragItem := Items.Add. Else. DragItem := Items.Insert(DropItem.Index); DragItem.Assign(CurrentItem); CurrentItem.Free; CurrentItem := NextItem; End; End; End; Procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; Var Accept: Boolean); Begin. Accept := Sender = ListView1; End;

Drag and Drop со списками

Code: { This example shows how to drag&drop within a TListBox. The Demo Program also shows how to implement an autoscroll-feature. } Procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. Accept := Sender is TListBox; End; Procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer); Var. ITemp: Integer; PtTemp: TPoint; SzTemp: string; Begin. { change the x,y coordinates into a TPoint record }. PtTemp.x := x; PtTemp.y := y; { Use a while loop instead of a for loop due to items possible being removed. From listboxes this prevents an out of bounds exception }. ITemp := 0; While iTemp <= TListBox(Source).Items.Count-1 do. Begin. { look for the selected items as these are the ones we wish to move }. If TListBox(Source).selected[iTemp] then. Begin. { use a with as to make code easier to read }. With Sender as TListBox do. Begin. { need to use a temporary variable as when the item is deleted the. Indexing will change }. SzTemp := TListBox(Source).Items[iTemp]; { delete the item that is being dragged }. TListBox(Source).Items.Delete(iTemp); { insert the item into the correct position in the listbox that it. Was dropped on }. Items.Insert(itemAtPos(ptTemp, True), szTemp); End; End; Inc(iTemp); End; End;

Drag and Drop с минимизированным приложением

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

Drag and Drop TImage.

Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.

Code: Procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); Begin. With Source as TImage do. Begin. Left := X; Top := Y; End; End; Procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. Accept := Source is TImage; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. With TImage.Create(Self) do. Begin. Parent := Panel1; AutoSize := True; Picture.LoadFromFile('D:\DELPHI\IMAGES\CHIP.BMP'); DragMode := dmAutomatic; OnDragOver := Panel1DragOver; OnDragDrop := Panel1DragDrop; End; End;

©Drkb::00690.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Drag and Drop - как использовать ItemAtPos для получения элемента DirListBox.

Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:

Draw a polygon with Gouraud shading?

Code: Uses. Graphics, Dialogs; TRGBFloat = record. R : single; G : single; B : single; End; TPointColor = record. X : integer; Y : integer; RGB : TRGBFloat; End; TPointColorTriangle = array[0..2] of TPointColor; {This procedure draws a triangular polygon using Gouraud shading. You specify the position and colour of the 3 corners and it will. Draw a filled triangle with the colours smoothed out over the. Surface of the polygon. This is used a lot in 3D graphics for. Improved rendering of curved surfaces. The procedure is very fast. And can be used for realtime 3D animation.}. // fill a traingular polygon using Gouraud shading. Procedure T3DModel.GouraudPoly(var ABitmap : TBitmap ; V : TPointColorTriangle); Var. LX, RX, Ldx, Rdx : Single; Dif1, Dif2 : Single; LRGB, RRGB, RGB, RGBdx, LRGBdy, RRGBdy : TRGBFloat; RGBT : RGBTriple; Scan : PRGBTripleArray; Y, x, ScanStart, ScanEnd : integer; Vmax : byte; Right : boolean; Temp : TPointColor; Begin. Try. // sort vertices by Y. Vmax := 0; If V[1].Y > V[0].Y then Vmax := 1; If V[2].Y > V[Vmax].Y then Vmax := 2; If Vmax <> 2 then begin. Temp := V[2]; V[2] := V[Vmax]; V[Vmax] := Temp; End; If V[1].Y > V[0].Y then Vmax := 1. Else Vmax := 0; If Vmax = 0 then begin. Temp := V[1]; V[1] := V[0]; V[0] := Temp; End; Dif1 := V[2].Y - V[0].Y; If Dif1 = 0 then Dif1 := 0.001; // prevent EZeroDivide. Dif2 := V[1].Y - V[0].Y; If Dif2 = 0 then Dif2 := 0.001; { work out if middle point is to the left or right of the line. Connecting upper and lower points }. If V[1].X > (V[2].X - V[0].X) * Dif2 / Dif1 + V[0].X then Right := True. Else Right := False; // calculate increments in x and colour for stepping through the lines. If Right then begin. Ldx := (V[2].X - V[0].X) / Dif1; Rdx := (V[1].X - V[0].X) / Dif2; LRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1; LRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1; LRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1; RRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2; RRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2; RRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2; End else begin. Ldx := (V[1].X - V[0].X) / Dif2; Rdx := (V[2].X - V[0].X) / Dif1; RRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1; RRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1; RRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1; LRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2; LRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2; LRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2; End; LRGB := V[0].RGB; RRGB := LRGB; LX := V[0].X; RX := V[0].X; // fill region 1. For y := V[0].Y to V[1].Y - 1 do begin. // y clipping. If y > ABitmap.Height - 1 then Break; If y < 0 then begin. LX := LX + Ldx; RX := RX + Rdx; LRGB.B := LRGB.B + LRGBdy.B; LRGB.G := LRGB.G + LRGBdy.G; LRGB.R := LRGB.R + LRGBdy.R; RRGB.B := RRGB.B + RRGBdy.B; RRGB.G := RRGB.G + RRGBdy.G; RRGB.R := RRGB.R + RRGBdy.R; Continue; End; Scan := ABitmap.ScanLine[y]; // calculate increments in color for stepping through pixels. Dif1 := RX - LX + 1; If Dif1 = 0 then Dif1 := 0.001; RGBdx.B := (RRGB.B - LRGB.B) / Dif1; RGBdx.G := (RRGB.G - LRGB.G) / Dif1; RGBdx.R := (RRGB.R - LRGB.R) / Dif1; // x clipping. If LX < 0 then begin. ScanStart := 0; RGB.B := LRGB.B + (RGBdx.B * abs(LX)); RGB.G := LRGB.G + (RGBdx.G * abs(LX)); RGB.R := LRGB.R + (RGBdx.R * abs(LX)); End else begin. RGB := LRGB; ScanStart := round(LX); End; If RX - 1 > ABitmap.Width - 1 then ScanEnd := ABitmap.Width - 1. Else ScanEnd := round(RX) - 1; // scan the line. For x := ScanStart to ScanEnd do begin. RGBT.rgbtBlue := trunc(RGB.B); RGBT.rgbtGreen := trunc(RGB.G); RGBT.rgbtRed := trunc(RGB.R); Scan[x] := RGBT; RGB.B := RGB.B + RGBdx.B; RGB.G := RGB.G + RGBdx.G; RGB.R := RGB.R + RGBdx.R; End; // increment edge x positions. LX := LX + Ldx; RX := RX + Rdx; // increment edge colours by the y colour increments. LRGB.B := LRGB.B + LRGBdy.B; LRGB.G := LRGB.G + LRGBdy.G; LRGB.R := LRGB.R + LRGBdy.R; RRGB.B := RRGB.B + RRGBdy.B; RRGB.G := RRGB.G + RRGBdy.G; RRGB.R := RRGB.R + RRGBdy.R; End; Dif1 := V[2].Y - V[1].Y; If Dif1 = 0 then Dif1 := 0.001; // calculate new increments for region 2. If Right then begin. Rdx := (V[2].X - V[1].X) / Dif1; RX := V[1].X; RRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1; RRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1; RRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1; RRGB := V[1].RGB; End else begin. Ldx := (V[2].X - V[1].X) / Dif1; LX := V[1].X; LRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1; LRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1; LRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1; LRGB := V[1].RGB; End; // fill region 2. For y := V[1].Y to V[2].Y - 1 do begin. // y clipping. If y > ABitmap.Height - 1 then Break; If y < 0 then begin. LX := LX + Ldx; RX := RX + Rdx; LRGB.B := LRGB.B + LRGBdy.B; LRGB.G := LRGB.G + LRGBdy.G; LRGB.R := LRGB.R + LRGBdy.R; RRGB.B := RRGB.B + RRGBdy.B; RRGB.G := RRGB.G + RRGBdy.G; RRGB.R := RRGB.R + RRGBdy.R; Continue; End; Scan := ABitmap.ScanLine[y]; Dif1 := RX - LX + 1; If Dif1 = 0 then Dif1 := 0.001; RGBdx.B := (RRGB.B - LRGB.B) / Dif1; RGBdx.G := (RRGB.G - LRGB.G) / Dif1; RGBdx.R := (RRGB.R - LRGB.R) / Dif1; // x clipping. If LX < 0 then begin. ScanStart := 0; RGB.B := LRGB.B + (RGBdx.B * abs(LX)); RGB.G := LRGB.G + (RGBdx.G * abs(LX)); RGB.R := LRGB.R + (RGBdx.R * abs(LX)); End else begin. RGB := LRGB; ScanStart := round(LX); End; If RX - 1 > ABitmap.Width - 1 then ScanEnd := ABitmap.Width - 1. Else ScanEnd := round(RX) - 1; // scan the line. For x := ScanStart to ScanEnd do begin. RGBT.rgbtBlue := trunc(RGB.B); RGBT.rgbtGreen := trunc(RGB.G); RGBT.rgbtRed := trunc(RGB.R); Scan[x] := RGBT; RGB.B := RGB.B + RGBdx.B; RGB.G := RGB.G + RGBdx.G; RGB.R := RGB.R + RGBdx.R; End; LX := LX + Ldx; RX := RX + Rdx; LRGB.B := LRGB.B + LRGBdy.B; LRGB.G := LRGB.G + LRGBdy.G; LRGB.R := LRGB.R + LRGBdy.R; RRGB.B := RRGB.B + RRGBdy.B; RRGB.G := RRGB.G + RRGBdy.G; RRGB.R := RRGB.R + RRGBdy.R; End; Except. ShowMessage('Exception in GouraudPoly Method'); End; End;

Общие вопросы.

Delphi Russian Knowledge Base.

From Vit.

Version 3.0.

Полная версия.

Этот документ составлен по материалам форумов программистов.

Http://forum.vingrad.ru

И.

Http://forum.sources.ru.

Внимание! У DRKB появилась собственная web страница.

Www.drkb.ru.

Там вы всегда сможете найти самые свежие обновления и информацию по DRKB.

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

Vingrad.ru: http://forum.vingrad.ru/index.php?showforum=2.

Sоигсеs.ru: http://forum.sources.ru/index.php?showforum=11.

Найти информацию об авторах ответов можно по адресу:

Vingrad.ru: http://forum.vingrad.ru/index.php?act=Members.

Sоигсеs.ru: http://forum.sources.ru/index.php?act=Members.

Этот документ составлен Vit (www.delphist.com) и является дальнейшим развитием Delphist's FAQ.

Как запустить DTS из StoredProcedure.

Code: Use master. Exec xp_cmdshell "DTSRun /S servername /U username /P password /N packagename".

Аналог DumpBin.

Иногда на форуме проскакивает такой вопрос: "Как можно поглядеть экспортируемые ф-ии какой либо длл'ины?".

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

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

Подробно расписывать тут ничего не буду, тут идет разбор элементов PE заголовка - нахождение таблицы экспорта,

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

Базы используется GetModuleHandle().

Вставка:

The GetModuleHandle function returns a module handle for the specified module if the file has been mapped into the address.

Space of the calling process.

Для расширения возможностей - простмотра всех модулей, надо использовать.

Что нить другое, например "мэпирование" (CreateFileMapping() итд). Ведь надо хоть что нить самому сделать....

Code: Program ExpDump; Uses windows; Var. ImageBase : DWord; DosHeader : PImageDosHeader; PeHeader : PImageNtHeaders; PExport : PImageExportDirectory; Pname : PDWord; Name : PChar; I : Integer; Cmdline : string; //#### ?-??: ????? ? ???? Function Dump(const log: PChar): boolean; Var hFile : THandle; DwError : DWord; DwWritten : DWord; Buffer : PChar; Begin. HFile := CreateFile(PChar(cmdline + '_fexport.txt'), GENERIC_WRITE, 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); If (hFile = INVALID_HANDLE_VALUE) then begin. Result := FALSE; Exit; End; DwError := SetFilePointer(hFile, 0, nil, FILE_END); If (dwError = $FFFFFFFF) then begin. CloseHandle(hFile); Result := FALSE; Exit; End; Buffer := PChar(log + #13#10); WriteFile(hFile, buffer^, length(buffer), dwWritten, nil); If (dwWritten < DWord(length(buffer))) then begin. CloseHandle(hFile); Result := FALSE; Exit; End; CloseHandle(hFile); Result := TRUE; End; //#### //#### Start. Begin. If (ParamCount < 1) then halt(0) else cmdline := ParamStr(1); ImageBase := GetModuleHandle(PChar(cmdline)); If (ImageBase = 0) then begin. MessageBox(0, 'Error Load Module', 'Error', MB_OK); Halt(0); End; DosHeader := PImageDosHeader(ImageBase); If (DosHeader^.e_magic <> IMAGE_DOS_SIGNATURE) then begin. MessageBox(0,'Error Dos Header','Error',MB_OK); Halt(0); End; PEHeader := PImageNtHeaders(DWord(ImageBase) + DWord(DosHeader^._lfanew)); If (PEHeader^.Signature <> IMAGE_NT_SIGNATURE) then begin. MessageBox(0,'Error PE Header', 'Error', MB_OK); Halt(0); End; PExport := PImageExportDirectory(ImageBase + DWord(PEHeader^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress)); Pname := PDWord(ImageBase + DWord(PExport^.AddressOfNames)); Dump(PChar('Programm ExpDump =)')); Dump(PChar(cmdline + ' functions:')); Dump(PChar(#13#10)); For i := 0 to PExport^.NumberOfNames - 1 do begin. Name := PChar(PDWord(DWord(ImageBase) + PDword(pname)^)); If (not Dump(name)) then halt(0); Inc(pname); End; End. //#### End.

Duplicate Resources Error.

У вас есть исходный код VCL? Если да, то в этом случае ее можно всю перекомпилировать, добавив каталог к вашему библиотечному пути (Library path) в опциях среды (Environment Options | Library). Я думаю это нужно сделать, чтобы отделаться от этой ошибки. При другом способе необходимо вычислить вызывающую проблему директиву $R, временно удалить ее, и осуществить перекомпиляцию. Временно выключить директиву $R можно добавлением '.' перед $ (но это не единственный путь выключить ее).

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

©Drkb::02170.

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

Примечание от Vit.

В 99% случаев эта ошибка возникает при установке компонента, так как при добавлении компонента к пакету Дельфи автоматически к проекту добавляет и ресурс, если же этот ресурс уже определён в исходном коде компонента то и возникает эта ошибка. Откройте или менеджер проекта или исходный код DPK файла и удалите оттуда ссылку на ресурс, оставив её только в исходном коде компонента.

©Drkb::02171.

DXInput.

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

1. Клавиатура.

Опрос нажатия клавиши ведется через DXInput.States:

Code: If <тикер> in DXInput.States then. Begin. //действие. End.

DXInput.

Автор: Daddy WEB-сайт: http://daddy.mirgames.ru.

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

Code: If <тикер> in DXInput.States then. Begin. //действие. End.

,где

· <тикер> есть зарезервированное слово:

· isUp - по умолчанию "стрелка вверх"

· isDown - по умолчанию "стрелка вниз"

· isRight - по умолчанию "стрелка вправо"

· isLeft - по умолчанию "стрелка влево"

· IsButton1 - по умолчанию "Space"

· IsButton2 - по умолчанию "Enter"

· IsButton3-IsButton32 - по умолчанию не определены

Для сравнения два равноценных условия:

Code: //c использования DXInput. If isUp in DXInput.States then. Begin. //действие. End //а это - без. If Key=VK_UP then. Begin. //действие. End.

DXPlay.

Автор: SDil WEB-сайт: http://daddy.mirgames.ru.

Многие игры в нынешнее время поддерживают мультиплеер, почему? Потому что сейчас люди уже перестали довольствоватся Ai’ем, который играет в частности ‘линейно’, его нельзя обмануть, пошутить над его действиями или разозлить... =) С ним играть можно только на уровне обучения игры, а далее – сеть, живые игроки… ;). Если это маленькое вступление заставило вас захотеть добавить в свою игру мультиплеер то эта статья для вас. Итак, сразу к делу. Сделаем самую легкую программу, с одной кнопкой. =) Кидаем ее на форму, не забыв кинуть DXPlay. В этой программе давайте сделаем что бы форма подключения DXPlay выводилась при запуске. Идем в настройки DXPlay и устанавливаем любой Guid путем нажатия кнопки New, этот параметр (imho) “устанавливает” уникальности вашему мультиплееру. Далее так: TForm1<Events<OnCreate, и в процедуру кидаем:

Code: Try. DXPlay1.Open; //Пытаемся открыть форму подключения. Except. On E: Exception do. Begin. Application.ShowMainForm := False; Application.HandleException(E); Application.Terminate; //Если не подключаемся или ошибка выходим их программы. End; End;

Квадратное уравнение

Code: Unit SqRoot_; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, OleCtrls; Type. TForm1 = class(TForm). Edit1: TEdit; Edit2: TEdit; Edit3: TEdit; Label1: TLabel; Label2: TLabel; Label3: TLabel; Label4: TLabel; Button1: TButton; Label5: TLabel; Button2: TButton; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. // решает квадратное уравнение. Procedure SqRoot(a, b, c: real; var x1, x2: real; var ok: boolean); { a,b,c - коэффициенты уравнения. X1,x2 - корни уравнения. Ok = True - решение есть. Ok = False - решения нет }. Var. D: real; // дискриминант. Begin. D := Sqr(b) - 4 * a * c; If d < 0. Then. Ok := False // уравнение не имеет решения. Else. Begin. Ok := True; X1 := (-b + Sqrt(d)) / (2 * a); X2 := (b + Sqrt(d)) / (2 * a); End; End; {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. K1, k2: real; // корни уравнения. Rez: boolean; // True - решение есть, False - решения нет. Mes: string; // сообщение. Begin. SqRoot(StrToFloat(Edit1.Text), StrToFloat(Edit2.Text), StrToFloat(Edit3.Text), k1, k2, rez); If rez then. Mes := 'Корни уравнения' + #13 + 'x1=' + FloatToStrF(k1, ffGeneral, 4, 2) + #13 + 'x2=' + FloatToStrF(k2, ffGeneral, 4, 2) + #13. Else. Mes := 'Уравнение не имеет решения'; Label5.Caption := mes; End; Procedure TForm1.Button2Click(Sender: TObject); Begin. Winhelp(Form1.Handle, 'sqroot.hlp', HELP_CONTEXT, 1); End; End.

©Drkb::04094.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Легенда

Легенда диаграммы представляет собой подписи к той части, которая передает информацию в графическом виде. Как и любая область, она обладает типичными свойствами, присущими им. Есть одно отличие - шрифт элемента легенды. Чтобы легенда была видима на диаграмме, установите поле HasLegend объекта Chart в True.E.Charts.Item[name].HasLegend:=True. Затем можно установить координаты и размеры легенды, параметры границы (рамки) и области. Для этого используем следующие функции:

Установка размеров и координат.

Code: Function PositionSizeLegend (Name:variant; Left,Top,Width,Height:real):boolean; Begin. PositionSizeLegend:=true; Try. E.Charts.Item[name].Legend.Left:=Left; E.Charts.Item[name].Legend.Top:=Top; E.Charts.Item[name].Legend.Width:=Width; E.Charts.Item[name].Legend.Height:=Height; Except. PositionSizeLegend:=false; End; End;

Качественное увеличение изображения билинейной интерполяцией

Этот алгоритм увеличивает изображение в произвольное количество раз при помощи билинейной интерполяции. При создании нового изображения каждой его точке с целыми координатами (x,y) сопоставляется точка исходного изображения с дробными координатами (xo, yo), xo=x/dx, yo=y/dy (dx и dy – коэффициенты увеличения). Далее нужно провести поверхность через точки, лежащие вокруг (xo, yo). Цвет здесь рассматривается как третье измерение. На поверхности ищется точка с координатами (xo, yo) и ее цвет понимается за цвет точки (x,y) получаемого изображения.

Игра отражений

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

Идея стандартизации элементов клиента базы данных

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Идея стандартизации элементов клиента базы данных. Компонент доступа к данным,потомок TADOStoredProc. Предназначен для написания клиента для MS SQL Server 2000 (можно использовать и. Для более ранних версий, но придется поработать над шаблоном хранимой. Процедуры). Позволяет управлять операциями добавления, редактирования и. Удаления (и некоторыми другими)на клиенте со стороны сервера однообразно для. Всех данных. Тем самым достигается некоторая стандартизация клиента и при. Изменении серверной части не придется изменять клиента(конечно же в разумных. Пределах). Для большей красоты не помешает создать некоторые другие прибамбасы, например, Форму, исходную для всех форм проекта. Но это уже не относится к данному разделу. Зависимости: Windows, Messages, SysUtils, Classes, DB, ADODB. Автор: Пенов Сергей, spenov@narod.ru, ICQ:122597033, Москва. Copyright: Пенов Сергей. Дата: 07 мая 2002 г. ***************************************************** } //Шаблон хранимой процедуры. { CREATE PROCEDURE [upTemplateProcedure]. @KeyValue INT = NULL -- требуется для обновления измененной записи в клиенте. AS. -- Data (Требуемая информация). SELECT ColumnList. FROM TheTable. WHERE @KeyValue IS NULL OR TheKey=@KeyValue -- возвращаем либо все(операция. Открытия), либо конкретную запись (операция обновления). IF @KeyValue IS NULL BEGIN -- если операция открытия, то возвращаем необходимую. Дополнительную информацию для настройки клиента. -- Properties -- динамические свойства TADOStoredProc, список формируется. Таким образом. В большинстве случаев изменять его не приходится. SELECT 'Property'='Unique Table' , 'Value'='TheTable' UNION. SELECT 'Property'='Resync Command' , 'Value'='EXEC upTemplateProcedure ?' -- !!! команда обновления измененной записи !!! -- Table Operations. -- Здесь формируется набор данных, возвращающий какие операции может. Совершать текущий пользователь с этими данными. Это, естественно, простейший. Пример и возможно под конкретную ситуацию его надо будет изменить (запрос). SELECT DISTINCT PRIVILEGE_TYPE AS [Operation], 1 AS [Value] -- 1 - можно, 0. (или нет записи) - нельзя. Operation = INSERT,UPDATE,DELETE. FROM INFORMATION_SCHEMA.TABLE_PRIVILEGES. WHERE TABLE_NAME = 'TheTable' -- Columns Operations -- возможность редактирования столбцов пользователем. SELECT DISTINCT COLUMN_NAME AS [Column], 0 AS [ReadOnly] 0 - может. Редактировать, 1 ( или нет записи) - не может. FROM INFORMATION_SCHEMA.COLUMN_PRIVILEGES. WHERE TABLE_NAME = 'TheTable' AND PRIVILEGE_TYPE = 'UPDATE' -- Далее можно добавлять свои дополнительные данные для более детальной. Настройки клиета. В клиенте к ним доступ через свойство. TADOApostrofStoredProc .Recordsets. END. } Unit Un_TApostrofStoredProc; Interface. Uses. Windows, Messages, SysUtils, Classes, DB, ADODB; Type. TADOApostrofStoredProc = class(TADOStoredProc). Private. FCanINSERT: Boolean; FCanUPDATE: Boolean; FCanDELETE: Boolean; FRecordsets: TInterfaceList; FOpenTime: TDateTime; Function GetRecordset(I: Integer): _Recordset; Function GetRecordsetCount: Integer; Protected. Procedure DoBeforeOpen; override; Procedure DoBeforeClose; override; Procedure DoAfterOpen; override; Procedure OpenCursor(InfoQuery: Boolean = False); override; Procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); override; Public. Constructor Create(AOwner: TComponent); override; Property CanINSERT: Boolean read FCanINSERT; Property CanUPDATE: Boolean read FCanUPDATE; Property CanDELETE: Boolean read FCanDELETE; Property Recordsets[I: Integer]: _Recordset read. GetRecordset; //Дополнительные наборы данных, возвращенные хранимой процедурой. Property RecordsetCount: Integer read GetRecordsetCount; Property OpenTime: TDateTime read FOpenTime write FOpenTime; //Время. Открытия процедуры. End; Procedure Register; Implementation. Uses. ADOint, DBConsts; Procedure Register; Begin. RegisterComponents('ADOApostrof', [TADOApostrofStoredProc]); End; Function TADOApostrofStoredProc.GetRecordset(I: Integer): _Recordset; Begin. Result := _Recordset(FRecordsets[I]); End; Function TADOApostrofStoredProc.GetRecordsetCount: Integer; Begin. Result := FRecordsets.Count; End; Constructor TADOApostrofStoredProc.Create(AOwner: TComponent); Begin. Inherited; FRecordsets := TInterfaceList.Create; End; Procedure TADOApostrofStoredProc.DoBeforeOpen; Begin. FCanINSERT := False; FCanUPDATE := False; FCanDELETE := False; Inherited; End; Procedure TADOApostrofStoredProc.DoBeforeClose; Begin. Inherited; FRecordsets.Clear; End; Procedure TADOApostrofStoredProc.DoAfterOpen; Var. R: _Recordset; RecordsAffected, I: Integer; Begin. //Все столбцы в ReadOnly! For I := 0 to Fields.Count - 1 do. Fields[I].ReadOnly := True; //Установка некоторых свойств. Properties['Update Criteria'].Value := adCriteriaKey; Properties['Update Resync'].Value := adResyncAll; //Свойства из базы. R := NextRecordset(RecordsAffected); While Assigned(R) do. Begin. FRecordsets.Add(R); If (R.Fields.Count = 2) and (UpperCase(R.Fields[0].Name) = 'PROPERTY') and. (UpperCase(R.Fields[1].Name) = 'VALUE') then. Begin //Properties. If R.RecordCount > 0 then. Begin. R.MoveFirst; While not R.EOF do. Begin. Properties[R.Fields[0].Value].Value := R.Fields[1].Value; R.MoveNext; End; End; End. Else if (R.Fields.Count = 2) and (UpperCase(R.Fields[0].Name) = 'OPERATION'). And (UpperCase(R.Fields[1].Name) = 'VALUE') then. Begin //Операции над таблицей. If R.RecordCount > 0 then. Begin. R.MoveFirst; While not R.EOF do. Begin. If R.Fields[0].Value = 'INSERT' then. FCanINSERT := (R.Fields[1].Value = 1). Else if R.Fields[0].Value = 'UPDATE' then. FCanUPDATE := (R.Fields[1].Value = 1). Else if R.Fields[0].Value = 'DELETE' then. FCanDELETE := (R.Fields[1].Value = 1); R.MoveNext; End; End; End. Else if (R.Fields.Count = 2) and (UpperCase(R.Fields[0].Name) = 'COLUMN'). And (UpperCase(R.Fields[1].Name) = 'READONLY') then. Begin //Операции над столбцами. If R.RecordCount > 0 then. Begin. R.MoveFirst; While not R.EOF do. Begin. If Assigned(FindField(R.Fields[0].Value)) then. FieldByName(R.Fields[0].Value).ReadOnly := (R.Fields. [1].Value = 1); R.MoveNext; End; End; End; R := NextRecordset(RecordsAffected); End; Inherited; End; Procedure TADOApostrofStoredProc.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); Var. Buf: Boolean; Begin. Buf := Field.ReadOnly; Field.ReadOnly := Field.ReadOnly and (State <> dsInsert); Try. Inherited; Finally. Field.ReadOnly := Buf; End; End; Procedure TADOApostrofStoredProc.OpenCursor(InfoQuery: Boolean); Var. TheTime: TDateTime; Begin. TheTime := Time; Inherited; FOpenTime := Time - TheTime; End; End.

Какой из генераторов отчетов самый быстрый?

Почему самый быстрый?

Думаю, у каждого, кто столкнулся с выбором инструмента для генерации отчётов, возникал вопрос – как именно выбирать, что сравнивать?

По размеру? А по какому именно размеру? К примеру, по размеру, который добавится к вашему приложению? Но есть генераторы отчётов, которые к приложению вроде как ничего и не добавляют, а идут в отдельном dll-файле, который по своим размерам раз в несколько больше файла самого приложения. Или, к примеру, к самому исполняемому файлу добавляется совсем немного, зато файлы отчётов буквально "перевешивают" приложение...

Или по размеру файла отчёта? Наверное, это будет более весомый фактор, но не решающий.

По удобству для пользователя? А в чём его измерить?

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

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

Увидев в одном из зарубежных форумов результаты сравнения скорости работы двух генераторов отчетов, включаемых в поставку Borland Delphi: QuickReport и Rave Reports, меня посетила одна мысль: "Какие результаты покажут другие популярные у программистов генераторы отчетов?".

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

Осмотр трассы и участников

В качестве "участников забега" были выбраны 6 популярных генераторов отчетов:

· QuickReport Pro 4.06 фирмы QBS Software Ltd

· Rave Reports 7.0 фирмы Nevrona Designs

· FastReport 3.23 фирмы Fast Reports Inc

· FastReport 2.56 VCL фирмы Fast Reports Inc

· ReportBuilder 10.02 фирмы Digital Metaphors Corporation

· Crystal Reports 11.0 фирмы Business Objects SA

Все участники опытные, хорошо известны Delphi-разработчикам, обычно, именно между ними и стоит выбор. Надо сказать, что, если визуально различий между ними не так уж и много (к примеру, вы без проблем перейдёте от дизайнера отчётов Crystal Reports к ReportBuilder, как, впрочем, и почти к любому из участников) архитектурно же они различаются очень сильно.

QuickReport Известен тем, что с давних пор поставляется в составе Delphi. Точнее – поставлялся. Начиная с Delphi 7, это почётное место занял Rave Reports. Один из старейших продуктов. По идее, должен быть наиболее стабилен.

Rave Reports Раньше назывался Report Printer.Своё новое название приобрёл вместе с визуальным дизайнером отчётов (ранее сам дизайнер отчётов назывался Rave). Изначально был именно генератором отчётов, создаваемых из кода, не ориентированным на бэнды. И, надо сказать, это заметно. Среди участников визуальная часть у него наиболее непроработана.

FastReport Изучив внимательно FastReport 2 и FastReport 3, могу смело заявить: две версии одного продукта идеологически отличаются между собой практически как два разных продукта! Похоже, ребята из FastReports очень серьезно подошли к вопросу –заявления о "переработанной и улучшенной архитектуре в тройке" весьма скромны.

Несмотря на то, что общего между ними достаточно: все объекты являются внутренними объектами генератора отчётов (тут FastReport ближе, пожалуй, к CrystalReports), различий тоже предостаточно – единый внутренний скрипт у третьей версии и отдельные свои скрипты для каждого объекта во второй, куда большие возможности у третьей версии, поддержка четырёх различных скриптовых языков, поддержка матричных принтеров (из сравниваемых участников такие широкие возможности есть только у FastReport) и т.п. Есть даже конвертор из второй версии в третью (обратите внимание – другие участники не идут на столь радикальное изменение форматов! В этом есть и минусы – переход с версии на версию не всегда прост, лучше сразу выбирать третью версию, так и плюсы – по формату это самый новый генератор, не тянущий за собой пережитки и артефакты – отчёты хранятся в XML, что может служить гарантией теперь уже стабильности формата и его удобочитаемости), Судя по динамике развития, на сегодня это самый динамично растущий продукт.

ReportBuilder Ранее этот проект назывался PiParty. Достаточно долго он был безоговорочным лидером среди генераторов отчётов для Delphi. Надо сказать, что этот продукт выпускает новую версию сразу же после выпуска новой версии Delphi (потому и номер версии совпадает). Однако, хотелось бы более реальных изменений и улучшений от версии к версии, а не просто "поддержки следующей версии Delphi", особенно ярко это видно на фоне того же FastReport (но это уже моё личное мнение!).

Crystal Reports Самый опытный участник забега. Некоторые знают его под именем ReportSmith (кузнец отчётов) по Delphi 1. В силу возраста он достаточно велик в размерах и тяжёл в интеграции. Скидки на возраст не делаем – потому выстраиваем всех в один ряд. Borland опять включила его в состав своего продукта, на этот раз Delphi 2005. С Delphi 2006 на момент написания статьи ситуация не ясна...

Количество тестов я решил ограничить 4 этапами:

· Создание и сохранение в файл простого отчета из 2-х страниц с использованием 6-ти полей БД.

· Создание и сохранение в файл сложного отчета из 14-ти страниц с использованием всех полей БД.

· Экспорт в формат Acrobat PDF сложного отчета из 14-ти страниц с использованием всех полей БД.

· Экспорт в формат HTML сложного отчета из 14-ти страниц с использованием всех полей БД.

На старт!

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

Для получения средних результатов тестирования и исключить влияние архитектуры процессоров, тестирование было проведено на двух компьютерах следующей конфигурации: 1. AMD Athlon XP 3200+ , 1024 МБ RAM; 2. Intel Mobility Pentium M 1.7 ГГц, 512 МБ RAM.

Исходные тексты программы доступны в форматах zip (1.09M) и rar (468K).

Начали!

Пробки на дорогах?

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

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

Хочу обратить внимание потенциальных пользователей Crystal Reports на следующее: - при установке текущей версии Crystal Reports, другие программы, использующие другую версию Crystal Reports, с вероятностью 99% перестанут работать, выпадая в ошибку. - а если не устанавливать, то не будет работать текущая программа, а будет выпадать в ошибку. Я с этим столкнулся, когда попытался запустить программу с версией Crystal Reports 10.0 на компьютере с 9-й версией Crystal Reports. Кто сомневается – может сам это проверить. В итоге пришлось перекраивать работу с Crystal Reports в программе и вводить проверку установленного Crystal Reports на компьютере, где она запускается.

Для пользователей QuickReport тоже есть неприятная новость.

При экспорте в PDF для QuickReport Pro 4.04 происходит утечка памяти, при которой при выполнении 100 тестов не освобождается порядка 350 Мб RAM, что приводит к некорректной работе других программ. Эта проблема решена в последней версии продукта (в 4.06 этой проблемы не возникает).

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

У FastReport 2 отсутствует экспорт в формат PDF, поэтому в третьем тесте он участвовать не будет, хотя , забегая вперед, хотел бы я посмотреть на его результаты в этом тесте.

Марш!

Перейдем, собственно, к самому тестированию.

I – й этап. В этом тесте, все участники выполняют следующее задание: создание и сохранение в файл простого отчета, состоящего из 2-х страниц. Для заполнения используются 6 полей из БД, входящей в поставку любой версии среды программирования от фирмы Borland - customer.db.

Участник Время выполнения Размер получаемого файла ПК №1. ПК №2. Среднее QuickReport. 2.969. 2.523. 2.746. 106 кб Rave Reports. 2.140. 2.364. 2.252. 3.77 кб + 14.4 кб FastReport 3. 0.734. 1.051. 0.893. 0.251 кб FastReport 2. 1.109. 1.032. 1.070. 34.3 кб ReportBuilder. 4.234. 4.236. 4.235. 72.3 кб Crystal Reports. 12.281. 20.834. 20.783. 15 кб

II – й этап. В этом тесте, все участники выполняют следующее задание: создание и сохранение в файл сложного отчета, состоящего из 14-х страниц. Для заполнения используются все поля, в том числе и графические, из БД, входящей в поставку любой версии среды программирования от фирмы Borland - biolife.db.

Участник Время выполнения Размер получаемого файла ПК №1. ПК №2. Среднее QuickReport. 10.875. 10.345. 10.610. 1.32 Мб Rave Reports. 13.124. 20.519. 16.820. 4.62 кб + 1.08 МБ FastReport 3. 9.703. 11.307. 10.505. 2.10 МБ FastReport 2. 4.422. 3.004. 3.713. 519 кб ReportBuilder. 13.969. 11.677. 12.823. 1.15 МБ Crystal Reports. 24.141. 25.085. 24.613. 156 кб

III – й этап. В этом тесте, все участники выполняют следующее задание: экспорт в формат PDF сложного отчета, состоящего из 14-х страниц. Для заполнения используются все поля, в том числе и графические, из БД, входящей в поставку любой версии среды программирования от фирмы Borland - biolife.db.

Участник Время выполнения Размер получаемого файла ПК №1. ПК №2. Среднее QuickReport. 1072.796. 654.411. 863.604. 248 кб Rave Reports. 60.954. 48.980. 54.967. 515 кб FastReport 3. 98.577. 92.193. 95.385. 434 кб FastReport 2. ReportBuilder. 121.781. 40.919. 81.350. 3.11 МБ Crystal Reports. 250.750. 251.260. 251.009. 156 кб

IV – й этап. В этом тесте, все участники выполняют следующее задание: экспорт в формат HTML сложного отчета, состоящего из 14-х страниц. Для заполнения используются все поля, в том числе и графические, из БД, входящей в поставку любой версии среды программирования от фирмы Borland - biolife.db.

Участник Время выполнения Размер получаемого файла ПК №1. ПК №2. Среднее QuickReport. 68.845. 50.302. 59.569. 128 кб + 360 кб(карт.). Rave Reports. 354.062. 517.104. 435.583. 340 кб + 35.2 МБ (карт.). FastReport 3. 26.656. 25.797. 26.227. 76.6 кб + 7.21 МБ (карт.). FastReport 2. 25.453. 74.698. 50.076. 47.8 кб + 11.2 МБ (карт.). ReportBuilder. 340 кб + 35.2 МБ (карт.). Crystal Reports. 225.031. 226.102. 225.567. 197 кб + 20.2 МБ (карт.).

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

· При экспорте в HTML для QuickReport изображения выходят за границу блока и размеры изображения в экспорте не соответствуют размерам в исходном отчете.

· При экспорте в HTML для Rave Reports для каждой страницы отчета создается своя HTML-страница, и происходит создание для каждого отчета новых файлов изображений (28 изображений х 100 повторов = 2800 файлов изображений), что приводит к дополнительному расходу и дискового места и времени на экспорт.

· При экспорте в HTML для Crystal Reports происходит создание для каждого отчета новых файлов изображений (28 изображений х 100 повторов = 2800 файлов изображений), что приводит к дополнительному расходу и дискового места и времени на экспорт.

Финиш!

Итоги тестирования:

В первом тесте первое и второе места с большим отрывом занимают продукты от фирмы Fast Reports Inc. Третье занимает Rave Reports с отставанием от второго места на 110.5 %.

Во втором тесте первое и второе места отрывом занимают продукты от фирмы Fast Reports Inc. Третье занимает QuickReport с отставанием от второго места на 1 %.

В третьем тесте первое место занимает Rave Reports. Второе с отставанием на 48 % занял ReportBuilder. На третьем месте с отставанием от второго на 17 % расположился FastReport 3.

Четвертый тест опять завершился победой продуктов от фирмы Fast Reports Inc. На третьем месте с отставанием от второго на 19 % расположился QuickReport.

Кто победил?

По итогам всех четырех тестов первое и второе места заняли продукты от фирмы Fast Reports Inc: FastReport 3 и FastReport 2. Третье место занял Rave Reports от фирмы Nevrona Designs. Четвертое место с очень малым отставанием от третьего занял QuickReport Pro от фирмы QBS Software Ltd. Следом за ним идет ReportBuilder от фирмы DIGITAL METAPHORS CORPORATION. На последнем месте оказался Crystal Reports от фирмы Business Objects SA.

А в это время за кулисами...

Как показали результаты тестов и личные впечатления при создании программы практически все генераторы отчетов имеют свои "узкие места".

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

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

ReportBuilder для подключения к БД, помимо ppDBPipeline, требует наличие компонента DataSource (из палитры Data Access), что , по-меньшей мере не удобно для конечного пользователя. К тому же, сам компонент не поддерживает экспорт в формат HTML, для осуществления этой функции разработчики рекомендуют использовать сторонние компоненты, такие как: TExtraDevices by James Waler и TcdHTML Device by Cyberdyme Data Systems, которые также являются платными. Такое отношение к пользователям RB, мягко сказать удивляет, купив сам продукт, цена которого находится примерно на одном уровне с другими генераторами отчетов, приходится для осуществления возможности экспорта в HTML, приобретать еще и отдельные компоненты. Другие продукты имеют собственные методы экспорта.

Rave Reports, помимо вышеописанной неудачной реализации визуальности, еще обладает такой "незадокументированной" возможностью, вернее проводит скрытую от глаз пользователя деятельность: при запуске отчета сохраняет дамп подготовленного отчета в файле *.ndr. К тому же, чтобы Rave Reports нормально работал нужно еще добавить компонент RvNDRWriter, иначе ничего не работает. Ладно, с этим можно было смириться, но что самое интересное, экспорт невозможно осуществить без использования этого самого файла. Другим продуктам дополнительный файл не требуется. Единственным разумным объяснением требования наличия этого файла является предположение о том, что в этом файле находится каким-то образом преобразованный отчет для облегчения работы с его экспортом.

С экспортами в FastReport'ах тоже не все гладко. Например, в FastReport 2 для экспорта в HTML существует целых 3 компонента – для чего это нужно? Первый из них некорректно передает оформление документа, ко второму претензий – нет, это самый оптимальный метод, с 3-им я так и не добился успеха, так что ничего хорошего, так и плохого про него сказать не могу. Конечно, у фирмы Fast Reports Inc приоритетным продуктом является FastReport 3 и, такое количество экспортов скорее всего связано с отладкой разных алгоритмов, выбором лучшего для использования в 3-й версии самого оптимального. В FastReport 3, если для отчета, построенного с использованием определенного frxDBDataSet'а (используется, например при заполнении бэнда), если этот же frxDBDataSet выбрать в качестве источника данных для всего отчета, то при вызове просмотра приложение вылетает в ошибку "Нельзя использовать один DataSet для отчета и бэнда", такого же характера ошибка вылетает при установки этого frxDBDataSet'а для страницы. Как же такое может быть? Или бэнд, лежащий на странице и сама страница не принадлежит отчету, появление такой ошибки непонятно. И скорость экспорта в формат PDF оставляет желать лучшего.

©Drkb::03283.

Лексический анализ

7. Лексический анализ.

ВВЕДЕНИЕ.

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

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

Единственная причина, на самом деле, имеет отношение к ключевым словам. Это факт компьютерной жизни, что синтаксис ключевого слова имеет ту же самую форму, что и синтаксис любого другого идентификатора. Мы не можем сказать пока не получим полное слово действительно ли это ключевое слово. К примеру переменная IFILE и ключевое слово IF выглядят просто одинаковыми до тех пор, пока вы не получите третий символ. В примерах до настоящего времени мы были всегда способны принять решение, основанное на первом символе токена, но это больше невозможно когда присутствуют ключевые слова. Нам необходимо знать, что данная строка является ключевым словом до того, как мы начнем ее обрабатывать. И именно поэтому нам нужен сканер.

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

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

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

ЛЕКСИЧЕСКИЙ АНАЛИЗ.

Лексический анализ - это процесс сканирования потока входных символов и разделения его на строки, называемые лексемами. Большинство книг по компиляторам начинаются с этого и посвящают несколько глав обсуждению различных методов построения сканеров. Такой подход имеет свое место, но, как вы уже видели, существуют множество вещей, которые вы можете сделать даже никогда не обращавшись к этому вопросу, и, фактически, сканер, который мы здесь закончим, не очень будет напоминать то, что эти тексты описывают. Причина? Теория компиляторов и, следовательно, программы, следующие из нее, должны работать с большинством общих правил синтаксического анализа. Мы же не делаем этого. В реальном мире возможно определить синтаксис языка таким образом, что будет достаточно довольно простого сканера. И как всегда KISS - наш девиз.

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

Зачем необходимо разделение? Ответ имеет и теоретическую и практическую основы.

В 1956 Ноам Хомский определил "Иерархию Хомского" для грамматик. Вот они:

· Тип 0. Неограниченные (например Английский язык)

· Тип 1. Контекстно-зависимые

· Тип 2. Контекстно-свободные

· Тип 3. Регулярные.

Некоторые характеристики типичных языков программирования (особенно старых, таких как Фортран) относят их к Типу 1, но большая часть всех современных языков программирования может быть описана с использованием только двух последних типов и с ними мы и будем здесь работать.

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

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

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

<ident> ::= <letter> [ <letter> | <digit> ]*

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

Имеется другая, более практическая причина для отделения сканера от синтаксического анализатора. Мы хотим думать о входном исходном файле как потоке символов, которые мы обрабатываем справа налево без возвратов. На практике это невозможно. Почти каждый язык имеет некоторые ключевые слова типа IF, WHILE и END. Как я упомянул ранее, в действительности мы не можем знать является ли данная строка ключевым словом до тех пор пока мы не достигнем ее конца, что определено пробелом или другим разделителем. Так что мы должны хранить строку достаточно долго для того, чтобы выяснить имеем мы ключевое слово или нет. Это ограниченная форма перебора с возвратом.

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

КОНЕЧНЫЕ АВТОМАТЫ И АЛЬТЕРНАТИВЫ.

Я упомянул, что регулярные выражения могут анализироваться с использованием конечного автомата. В большинстве книг по компиляторам а также в большинстве компиляторов, вы обнаружите, что это применяется буквально. Обычно они имеют настоящую реализацию конечного автомата с целыми числами, используемыми для определения текущего состояния и таблицей действий, выполняемых для каждой комбинации текущего состояния и входного символа. Если вы пишите "front end" для компилятора, используя популярные Unix инструменты LEX и YACC, это то, что вы получите. Выход LEX - конечный автомат, реализованный на C плюс таблица действий, соответствующая входной грамматике данной LEX. Вывод YACC аналогичен... искусственный таблично управляемый синтаксический анализатор плюс таблица, соответствующая синтаксису языка.

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

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

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

ЭКСПЕРИМЕНТЫ ПО СКАНИРОВАНИЮ.

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

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

<ident> ::= <letter> [ <letter> | <digit> ]*

<number ::= [<digit>]+

(Не забудьте, что "*" указывает на ноль или более повторений условия в квадратных скобках, а "+" на одно и более.).

Мы уже работали с подобными элементами в третьей главе. Давайте начнем (как обычно) с пустого Cradle. Не удивительно, что нам понадобится новая процедура распознавания:

{ Recognize an Alphanumeric Character }.

Function IsAlNum(c: char): boolean; begin IsAlNum := IsAlpha(c) or IsDigit(c); end;

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

Code: { Get an Identifier }. Function GetName: string; Var x: string[8]; Begin. X := ''; If not IsAlpha(Look) then Expected('Name'); While IsAlNum(Look) do begin. X := x + UpCase(Look); GetChar; End; GetName := x; End; { Get a Number }. Function GetNum: string; Var x: string[16]; Begin. X := ''; If not IsDigit(Look) then Expected('Integer'); While IsDigit(Look) do begin. X := x + Look; GetChar; End; GetNum := x; End;

Как редактировать группы и пользователей.

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

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

Code: ADD USER пользователь. ALTER USER пользователь PASSWORD новыйПароль прежнийПароль. DROP USER пользователь.

а с группами как быть?

Code: CREATE GROUP группа код[, группа код, …]. GRANT {привилегия[, привилегия, …]} ON. {TABLE таблица | OBJECT объект| CONTAINER контейнер } TO {имяПравообладателя[, имяПравообладателя, …]}. REVOKE {привилегия[, привилегия, …]} ON. {TABLE таблица | OBJECT объект| CONTAINER контейнер}. FROM {имяПравообладателя[, имяПравообладателя, …]}. DROP USER пользователь[, пользователь, …] [FROM группа]. Удаление одной или нескольких групп: DROP GROUP группа[, группа, …].

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

Автор: BAS.

©Drkb::02761.

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

Как реализовать Drag and Drop в TTreeView.

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

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Controls, Forms, Dialogs, StdCtrls, ComCtrls; Type. TForm1 = class(TForm). TreeView1: TTreeView; Label1: TLabel; Procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Private. { Private declarations }. Procedure MoveNode(TargetNode, SourceNode: TTreeNode); Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // // Procedure which will move node and its subnodes. // Procedure TForm1.MoveNode(TargetNode, SourceNode: TTreeNode); Var. NodeTmp: TTreeNode; I: Integer; Begin. With TreeView1 do. Begin. NodeTmp := Items.AddChild(TargetNode, SourceNode.Text); For i := 0 to SourceNode.Count - 1 do. Begin. MoveNode(nodeTmp, SourceNode.Item[i]); End; End; End; Procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer); Var. TargetNode, SourceNode: TTreeNode; Begin. With TreeView1 do. Begin. TargetNode := GetNodeAt(X, Y); // Get target node. SourceNode := Selected; If (TargetNode = nil) then. Begin. EndDrag(False); Exit; End; MoveNode(TargetNode, SourceNode); SourceNode.Free; End; End; Procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); Begin. If (Sender = TreeView1) then // If TRUE than accept the draged item. Begin. Accept := True; End; End; End.

©Drkb::01113.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

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

Автор: Павел

Как реализовать поиск, замену

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. Memo1.Lines.LoadFromFile(OpenDialog1.FileName); End; Procedure TForm1.Button2Click(Sender: TObject); Var. Find: string; Text: string; St, len: integer; Res: integer; Begin. If Memo1.SelStart >= Length(Memo1.Text) then. Memo1.SelStart := 0; St := Memo1.SelStart + 1; If (Memo1.SelLength <= 0) or (not CheckBox1.Checked) then. Begin. Inc(st, Memo1.SelLength); Len := Length(Memo1.Text) - st; End. Else. Len := Memo1.SelLength; Text := copy(Memo1.Text, st, len); Find := Edit1.Text; Res := pos(find, text); If res = 0 then. Begin. ShowMessage('Search string "' + find + '" not found'); Exit; End; Memo1.SelStart := res + st - 2; Memo1.SelLength := length(find); End;

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

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

Code: LockWindowUpdate(Memo1.Handle); ... LockWindowUpdate(0);

©Drkb::03730.

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

Автор: Nomadic.

Как работать с битами

Есть два способа.

Как работать с GIF файлами

Этот код, делает следующее, загружаем в листбох список Gif файлов, затем это все дело обьединяетсяв один BMP файл,картинка к картинке, кто знает DirectX поймет для чего это надо (спрайты).

Code: Procedure TForm1.Button2Click(Sender: TObject); Begin. If opendialog1.Execute then. Begin. ListBox1.Items := opendialog1.Files; Edit2.Text := inttostr(ListBox1.Items.Count); End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. I, a: integer; Bm: TBItmap; Begin. A := 0; Bm := TBItmap.Create; Image1.Picture.LoadFromFile(listbox1.Items[0]); Bm.Height := image1.Height; Bm.Width := listbox1.Items.Count * image1.Picture.width; For i := 0 to listbox1.Items.Count - 1 do. Begin. Image1.Picture.LoadFromFile(listbox1.Items[i]); Bm.Canvas.Draw(a, 0, image1.Picture.Graphic); A := a + image1.Picture.Height; End; //form1.Canvas.Draw(0,0,bm); Bm.SaveToFile(Edit1.Text + '.bmp'); Bm.free; End;

Как добавить группу в Program Manager.

Code: Interface. Procedure CreateGroup; Implementation. Procedure TSetupForm.CreateGroup; { Для установки группы в Program Manager используем компонент TProgMan }. Var. ItemList: TStringList; GroupName: string; ItemName: string; I: word; Begin. { Получаем из INI-файла строку GroupName }. GroupName := IniFile.ReadString('General', 'PMGroup', ''); { Если один есть, устанавливаем группу }. If GroupName <> '' then. Begin. ItemList := TStringList.Create; Try. { читаем элементы для установки }. IniFile.ReadSectionValues('PMGroup', ItemList); With TProgMan.Create(Self) do. Try. CreateGroup(GroupName); For i := 0 to ItemList.Count - 1 do. Begin. { получаем имя файла } ItemName := Copy(ItemList.Strings[i], 1, Pos('=', ItemList.Strings[i]) - 1); { прибавляем путь к имени файла и добавляем элемент }. AddItem(GetTarget(ItemList.Values[ItemName][1]) + ItemName, ItemName); End; Finally. Free; End; Finally. ItemList.Free; End; End; End;

Как добавить в диалог TOpenDialog свой CheckBox.

Вообще, винда предоставляет возможность расширения некоторых стандартных диалогов с помощью шаблонов и hook-процедуры. Например, для OpenFileDialog'а пишется к примеру, такой rc-скрипт с шаблоном myres.rc.

Code: OFT DIALOG -1, 1, 304, 62. STYLE DS_3DLOOK | DS_CONTROL | WS_CHILD | WS_VISIBLE | WS_CLIPSIBLINGS. CAPTION "". FONT 8, "MS Sans Serif". { CONTROL "Select Options", 100, "button", BS_GROUPBOX | WS_CHILD | WS_VISIBLE | WS_GROUP, 69, 4, 224, 52. CONTROL "CheckBox1", 101, "button", BS_AUTOCHECKBOX | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 84, 19, 60, 12. CONTROL "CheckBox2", 102, "button", BS_AUTOCHECKBOX | WS_CHILD | WS_VISIBLE | WS_TABSTOP, 84, 38, 60, 12. }

потом он компилится

Brcc32.exe myres.rc.

и получается myres.res, который линкуется к проекту директивой {$R} (удобнее, конечно создавать и компилить шаблон в каком-нить редакторе ресурсов, типа Resource Workshop'а). Ну а в проге заполняется структура TOpenFileName (надо в uses подключить commdlg), у которой в поле lpTemplateName задается имя шаблона, а в поле lpfnHook - hook-процедура. В этой hook-процедуре и обрабатывается реакция на дополнительные контролы (например чекбоксы). Там же можно обработать смену типа файла, директории, выбранного файла, нажатие на OK, etc. Ну а для показа самого диалога вызывается API'шная GetOpenFileName Короче, вот пример кода

Code: Uses. Commdlg; {©Drkb v.3(2007): www.drkb.ru}. {$R *.dfm}. {$R MYRES.RES} // файл ресурсов с шаблоном. Var. Ofn:TOpenFileName; F:array[0..MAX_PATH-1] of Char; // hook-процедура. Function Fh(Wnd: HWND; Msg:cardinal; wParam,lParam: Integer): UINT stdcall; Begin. Result:=0; Case Msg of. WM_INITDIALOG: Begin. CheckDlgButton(Wnd,101,BST_CHECKED); // отметим первый чекбокс. End; WM_COMMAND: // реакция на изменение состояния чекбоксов. Case LOWORD(wParam) of. 101: Begin. If (IsDlgButtonChecked(Wnd,101)=BST_CHECKED) then MessageBox(Wnd,'CheckBox1 Checked!','FileOpenDialog',0); End; 102: Begin. If (IsDlgButtonChecked(Wnd,102)=BST_CHECKED) then MessageBox(Wnd,'CheckBox2 Checked!','FileOpenDialog',0); End; End; WM_NOTIFY: Case. POFNotify(lParam)^.hdr.code of. CDN_FILEOK: // реакция на выбор файла. Begin. If (IsDlgButtonChecked(Wnd,101)=BST_CHECKED) then. MessageBox(Wnd,PChar('CheckBox1 Checked and '+ofn.lpstrFile+' selected'),'FileOpenDialog',0); If (IsDlgButtonChecked(Wnd,102)=BST_CHECKED) then. MessageBox(Wnd,PChar('CheckBox2 Checked and '+ofn.lpstrFile+' selected'),'FileOpenDialog',0); End; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. FillChar(f,sizeof(f),0); FillChar(ofn,sizeof(ofn),0); Ofn.lStructSize := sizeof(TOpenFileName); Ofn.hwndOwner := Handle; Ofn.hInstance := hInstance; Ofn.lpstrFilter := 'Text Files (*.TXT)'#0'*.txt'#0+ 'Executables (*.EXE)'#0'*.exe'#0+ 'All files (*.*)'#0'*.*'#0#0; Ofn.lpstrTitle := 'Select File'; Ofn.lpstrFile := f; Ofn.nMaxFile := MAX_PATH; Ofn.lpTemplateName :='OFT'; // имя шаблона. Ofn.lpfnHook := Fh; // hook-процедура. Ofn.Flags := OFN_EXPLORER or OFN_CREATEPROMPT or. OFN_FILEMUSTEXIST or OFN_HIDEREADONLY or. OFN_PATHMUSTEXIST or OFN_ENABLEHOOK or. OFN_ENABLETEMPLATE; // показываем диалог. If GetOpenFileName(ofn) then ShowMessage(ofn.lpstrFile); End;

Автор: Krid.

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

©Drkb::01221.

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

Автор: Mekan Gara.

Как добавить функции картографирования в приложение.

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

Очень просто, идешь на http://www.dataplus.ru/win/DownLoad.htm и скачиваешь MapObjects LT Evaluation Copy (1,756 Mb) и MapObjects LT samples (3,343 Mb). Все это может работать под Visual Basic, Visual C++, Delphi и PowerBuilder. Ну а если есть деньги то советую MapObjects 2.1 http://www.dataplus.ru/WIN/NEWS/2001/May/MO2.1.htm.

©Drkb::04489.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как глобально перехватить нажатие кнопки PrintScreen?

В примере для глобального перехвата нажатия клавиши print screen регистрируется горячая клавиша (hot key).

Code: Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. Procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const id_SnapShot = 101; Procedure TForm1.WMHotKey (var Msg : TWMHotKey); Begin. If Msg.HotKey = id_SnapShot then. ShowMessage('GotIt'); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. RegisterHotKey(Form1.Handle, Id_SnapShot, 0, VK_SNAPSHOT); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. UnRegisterHotKey (Form1.Handle, id_SnapShot); End;

©Drkb::01506.

Как добовлять в ListView полноцветные иконки?

Code: Procedure TForm1.FormCreate(Sender: TObject); Var. SysIL : THandle; SysSIL : THandle; SFI : TSHFileInfo; Begin. SysImageList1 := TImageList.Create(self); With SysImageList1 do begin. Width := 16; Height := 16; SysSIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or SHGFI_SMALLICON); If SysSIL <> 0 then begin. SysImageList1.Handle := SysSIL; ShareImages := True; End; End; SysImageList2 := TImageList.Create(self); With SysImageList2 do begin. Width := 32; Height := 32; SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI), SHGFI_SYSICONINDEX or SHGFI_LARGEICON); If SysIL <> 0 then begin. SysImageList2.Handle := SysIL; ShareImages := True; End; End; End; Function GetIconIndex(const AFile: string; Attrs: DWORD): integer; Var. SFI: TSHFileInfo; Begin. SHGetFileInfo(PChar(AFile), Attrs, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES); Result := SFI.iIcon; End; .... With ListView.Items.Add do begin. Caption := FName; ImageIndex := GetIconIndex(Caption, FILE_ATTRIBUTE_NORMAL); SubItems.Add(FSize); SubItems.Add(FType); SubItems.Add(FDateTime); End;

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

Автор: alexanderm.

©Drkb::00634.

Как вшить иконку в мою прогу?, с нуля.

Как вшить иконку в мою прогу?, с нуля

в .RC - файле подключаемом к проекту пишешь

Code: 100 ICON "100.ico".

для загрузки икоки:

Code: With MainWindow do. Begin. {©Drkb v.3(2007): www.drkb.ru}. CbSize := SizeOf(MainWindow); Style := CS_HREDRAW or CS_VREDRAW; LpfnWndProc := @WindowProc; CbClsExtra := 0; CbWndExtra := 0; HIcon := LoadIcon(0, IDI_APPLICATION); HCursor := LoadCursor(0, IDC_ARROW); HbrBackground := COLOR_BTNFACE + 1; LpszMenuName := nil; LpszClassName := 'TDeliveryInstaller'; End; MainWindow.hInstance := HInstance; If RegisterClassEx(MainWindow) = 0 then Exit; Width := 360; Height := 200; InitCommonControls; Handle := CreateWindowEx(0, 'TDeliveryInstaller', PChar(TXT_CAPTION), WS_OVERLAPPED or WS_SYSMENU, Left, Top, Width, Height, 0, 0, HInstance, nil); SendMessage(Handle, WM_SETICON, 1, LoadIcon(HInstance, MAKEINTRESOURCE(100)));

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

Автор: Rouse_

©Drkb::02347.

Как раскрыть строки переменных окружения

Code: ExpandEnvironmentStrings( LPCTSTR lpSrc, LPTSTR lpDst, DWORD nSize );

Как распечатать decision grid?

Code: Procedure TForm1.Button2Click(Sender: TObject); Begin. Printer.BeginDoc; Try. Printer.canvas.moveto(100,100); SetMapMode( printer.canvas.handle, MM_ANISOTROPIC ); SetWindowExtEx(printer.canvas.handle, GetDeviceCaps(canvas.handle, LOGPIXELSX), GetDeviceCaps(canvas.handle, LOGPIXELSY), Nil); SetViewportExtEx(printer.canvas.handle, GetDeviceCaps(printer.canvas.handle, LOGPIXELSX), GetDeviceCaps(printer.canvas.handle, LOGPIXELSY), Nil); Grid.PaintTo( printer.canvas.handle, 100, 100 ); Finally. Printer.enddoc; End; End;

©Drkb::03259.

Как вставить Bitmap в TRichEdit?

Вот так можно вставить картинку в формате Bitmap в позицию курсора в TRichEdit:

Code: Unit re_bmp; Interface. Uses Windows; Procedure InsertBitmapToRE(Wnd:HWND; Bmp:HBITMAP); Implementation. Uses Activex, RichEdit; Const. IID_IDataObject: TGUID = ( D1:$0000010E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); IID_IOleObject: TGUID = ( D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); REO_CP_SELECTION = ULONG(-1); REO_IOB_SELECTION = ULONG(-1); REO_GETOBJ_POLEOBJ = $00000001; Type. TReobject = record. CbStruct: DWORD; Cp: ULONG; Clsid: TCLSID; Poleobj: IOleObject; Pstg: IStorage; Polesite: IOleClientSite; Sizel: TSize; DvAspect: Longint; DwFlags: DWORD; DwUser: DWORD; End; Type. IRichEditOle = interface(IUnknown). ['{00020d00-0000-0000-c000-000000000046}']. Function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall; Function GetObjectCount: HResult; stdcall; Function GetLinkCount: HResult; stdcall; Function GetObject(iob: Longint; out reobject: TReObject; DwFlags: DWORD): HResult; stdcall; Function InsertObject(var reobject: TReObject): HResult; stdcall; Function ConvertObject(iob: Longint; rclsidNew: TIID; LpstrUserTypeNew: LPCSTR): HResult; stdcall; Function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall; Function SetHostNames(lpstrContainerApp: LPCSTR; LpstrContainerObj: LPCSTR): HResult; stdcall; Function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall; Function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall; Function HandsOffStorage(iob: Longint): HResult; stdcall; Function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall; Function InPlaceDeactivate: HResult; stdcall; Function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; Function GetClipboardData(var chrg: TCharRange; reco: DWORD; Out dataobj: IDataObject): HResult; stdcall; Function ImportDataObject(dataobj: IDataObject; cf: TClipFormat; HMetaPict: HGLOBAL): HResult; stdcall; End; TImageDataObject=class(TInterfacedObject,IDataObject). Private. FBmp:HBITMAP; FMedium:TStgMedium; FFormatEtc: TFormatEtc; Procedure SetBitmap(bmp:HBITMAP); Function GetOleObject(OleClientSite:IOleClientSite; Storage:IStorage):IOleObject; Destructor Destroy;override; // IDataObject. Function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall; Function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall; Function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall; Function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall; Function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall; Function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall; Function DAdvise(const formatetc: TFormatEtc; advf: Longint; Const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall; Function DUnadvise(dwConnection: Longint): HResult; stdcall; Function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall; Public. Procedure InsertBitmap(wnd:HWND; Bitmap:HBITMAP); End; { TImageDataObject }. Function TImageDataObject.DAdvise(const formatetc: TFormatEtc; advf: Integer; Const advSink: IAdviseSink; out dwConnection: Integer): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.DUnadvise(dwConnection: Integer): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.EnumFormatEtc(dwDirection: Integer; out enumFormatEtc: IEnumFormatEtc): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; Begin. Result:=E_NOTIMPL; End; Function TImageDataObject.QueryGetData(const formatetc: TFormatEtc): HResult; Begin. Result:=E_NOTIMPL; End; Destructor TImageDataObject.Destroy; Begin. ReleaseStgMedium(FMedium); End; Function TImageDataObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; Begin. Medium.tymed := TYMED_GDI; Medium.hBitmap := FMedium.hBitmap; Medium.unkForRelease := nil; Result:=S_OK; End; Function TImageDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; Begin. FFormatEtc := formatetc; FMedium := medium; Result:= S_OK; End; Procedure TImageDataObject.SetBitmap(bmp: HBITMAP); Var. Stgm: TStgMedium; Fm:TFormatEtc; Begin. Stgm.tymed := TYMED_GDI; Stgm.hBitmap := bmp; Stgm.UnkForRelease := nil; Fm.cfFormat := CF_BITMAP; Fm.ptd := nil; Fm.dwAspect := DVASPECT_CONTENT; Fm.lindex := -1; Fm.tymed := TYMED_GDI; SetData(fm, stgm, FALSE); End; Function TImageDataObject.GetOleObject(OleClientSite: IOleClientSite; Storage: IStorage):IOleObject; Begin. If (Fmedium.hBitmap=0) then Result:=nil else. OleCreateStaticFromData(self, IID_IOleObject, OLERENDER_FORMAT, @FFormatEtc, OleClientSite, Storage, Result); End; Procedure TImageDataObject.InsertBitmap(wnd:HWND; Bitmap: HBITMAP); Var. OleClientSite:IOleClientSite; RichEditOLE:IRichEditOLE; Storage:IStorage; LockBytes:ILockBytes; OleObject:IOleObject; Reobject:TReobject; Clsid:TGUID; Begin. If (SendMessage(wnd, EM_GETOLEINTERFACE, 0, cardinal(@RichEditOle))=0) then exit; FBmp:=CopyImage(Bitmap,IMAGE_BITMAP,0,0,0); If FBmp=0 then exit; Try. SetBitmap(Fbmp); RichEditOle.GetClientSite(OleClientSite); If (OleClientSite=nil) then exit; CreateILockBytesOnHGlobal(0, TRUE,LockBytes); If (LockBytes = nil) then exit; If (StgCreateDocfileOnILockBytes(LockBytes, STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0,Storage)<> S_OK) then. Begin. LockBytes._Release; Exit. End; If (Storage = nil) then exit; OleObject:=GetOleObject(OleClientSite, Storage); If (OleObject = nil) then exit; OleSetContainedObject(OleObject, TRUE); ZeroMemory(@reobject, sizeof(TReobject)); Reobject.cbStruct := sizeof(TReobject); OleObject.GetUserClassID(clsid); Reobject.clsid := clsid; Reobject.cp := REO_CP_SELECTION; Reobject.dvaspect := DVASPECT_CONTENT; Reobject.poleobj := OleObject; Reobject.polesite := OleClientSite; Reobject.pstg := Storage; RichEditOle.InsertObject(reobject); Finally. DeleteObject(FBmp). End. End; Procedure InsertBitmapToRE(Wnd:HWND; bmp:HBITMAP); Begin. With TImageDataObject.Create do. Try. InsertBitmap(Wnd,Bmp); Finally. Free. End. End; End.

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

Code: Uses re_bmp; Procedure TForm1.Button1Click(Sender: TObject); Begin. InsertBitmapToRE(RichEdit1.Handle,Image1.Picture.Bitmap.Handle); End; ... Procedure TForm1.Button2Click(Sender: TObject); Var. Bmp:TBitmap; Begin. If (not OpenPictureDialog1.Execute) then exit; Bmp:=TBitmap.Create; Try. Bmp.LoadFromFile(OpenPictureDialog1.Filename); InsertBitmapToRE(RichEdit1.Handle,bmp.Handle); Finally. Bmp.Free. End. End;

Таким же образом можно вставлять картинки не только в TRichEdit, но и в RxRichEdit, стандартный виндовый RichEdit, etc.

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

Автор: Krid.

©Drkb::00582.

Code: Uses. RichEdit; // Stream Callback function. Type. TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte; Cb: Longint; var pcb: Longint): DWORD; Stdcall; TEditStream = record. DwCookie: Longint; DwError: Longint; PfnCallback: TEditStreamCallBack; End; // RichEdit Type. Type. TMyRichEdit = TRxRichEdit; // EditStreamInCallback callback function. Function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte; Cb: Longint; var pcb: Longint): DWORD; stdcall; // by P. Below. Var. TheStream: TStream; DataAvail: LongInt; Begin. TheStream := TStream(dwCookie); With theStream do. Begin. DataAvail := Size - Position; Result := 0; If dataAvail <= cb then. Begin. Pcb := read(pbBuff^, dataAvail); If pcb <> dataAvail then. Result := UINT(E_FAIL); End. Else. Begin. Pcb := read(pbBuff^, cb); If pcb <> cb then. Result := UINT(E_FAIL); End; End; End; // Insert Stream into RichEdit. Procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream); // by P. Below. Var. EditStream: TEditStream; Begin. With EditStream do. Begin. DwCookie := Longint(SourceStream); DwError := 0; PfnCallback := EditStreamInCallBack; End; RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream)); End; // Convert Bitmap to RTF Code. Function BitmapToRTF(pict: TBitmap): string; // by D3k. Var. Bi, bb, rtf: string; Bis, bbs: Cardinal; Achar: ShortString; Hexpict: string; I: Integer; Begin. GetDIBSizes(pict.Handle, bis, bbs); SetLength(bi, bis); SetLength(bb, bbs); GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^); Rtf := '{\rtf1 {\pict\dibitmap '; SetLength(hexpict, (Length(bb) + Length(bi)) * 2); I := 2; For bis := 1 to Length(bi) do. Begin. Achar := Format('%x', [Integer(bi[bis])]); If Length(achar) = 1 then. Achar := '0' + achar; Hexpict[I - 1] := achar[1]; Hexpict[I] := achar[2]; Inc(I, 2); End; For bbs := 1 to Length(bb) do. Begin. Achar := Format('%x', [Integer(bb[bbs])]); If Length(achar) = 1 then. Achar := '0' + achar; Hexpict[I - 1] := achar[1]; Hexpict[I] := achar[2]; Inc(I, 2); End; Rtf := rtf + hexpict + ' }}'; Result := rtf; End; // Example to insert image from Image1 into RxRichEdit1. Procedure TForm1.Button1Click(Sender: TObject); Var. SS: TStringStream; BMP: TBitmap; Begin. BMP := TBitmap.Create; BMP := Image1.Picture.Bitmap; SS := TStringStream.Create(BitmapToRTF(BMP)); Try. PutRTFSelection(RxRichEdit1, SS); Finally. SS.Free; End; End;

Как выравнивать текст в документе (по ширине, по центру и т.д.)?

Если выделить объект (часть объекта), то к нему можно применять операции выравнивания текста, используя методы и свойства объекта Selection. Используйте поле Alignment объекта Selection.ParagraphFormat. Например:

Code: W.Selection.ParagraphFormat.Alignment:=wdAlignParagraphCenter; W.Selection.ParagraphFormat.Alignment:=wdAlignParagraphRight; W.Selection.ParagraphFormat.Alignment:=wdAlignParagraphJustify;

Как вывести Hint для ячейки DBGrid.

Создайте на форме DataSource1, Table1, DataSource2, Table2, DBGrid1. Table1 и Table2 свяжите со своей базой данных. DataSource1 и DataSource2 свяжите соответственно с Table1 и Table2. DBGrid1 свяжите с DataSource1 Table2 и DataSource2 нужны для доступа к какой-нибудь ячейке. Другой способ без их использования: при отрисовке значений ячеек (соответствующее событие), необходимо запомнить значения всех ячеек, находящихся на экране и производить выбор среди них.

Как выделить файлы в Проводнике?

Просто открыть окно, и выделить в нём файлы|папки

Да в принципе путь то нам известен? Известен, посему делаем финт хвостом:

Code: Uses ..., SHDocVw; {©Drkb v.3(2007): www.drkb.ru}. Function OpenExplorerAndSelectFile(Path: String): Boolean; Function ParceURLName(const Value: String): String; Const. ScFilePath: array [0..7] of Char = ('f', 'i', 'l', 'e', ':', '/', '/', '/'); Begin. If CompareMem(@scFilePath[0], @Value[1], 8) then. Begin. Result := Copy(Value, 9, Length(Value)); Result := StringReplace(Result, '/', '\', [rfReplaceAll]); Result := StringReplace(Result, '%20', ' ', [rfReplaceAll]); Result := IncludeTrailingBackslash(Result); End. Else. Result := Value; End; Var. IShellWindow: IShellWindows; IWB: IWebBrowserApp; SpDisp: IDispatch; I: Integer; S, FilePath, FileName: String; Begin. Result := FileExists(Path); If not Result then Exit; FilePath := AnsiUpperCase(ExtractFilePath(Path)); FileName := ExtractFileName(Path); IShellWindow := CoShellWindows.Create; For I := 0 to iShellWindow.Count - 1 do. Begin. SpDisp := iShellWindow.Item(I); If spDisp = nil then Continue; SpDisp.QueryInterface(IWebBrowserApp, iWB); If iWB <> nil then. Begin. S := ParceURLName(iWB.LocationURL); If AnsiUpperCase(S) = FilePath then. Begin. SendMessage(iWB.HWnd, WM_SYSCOMMAND, SC_CLOSE, 0); Break; End; End; End; ShellExecute(0, 'open', 'explorer.exe', PChar('/select, ' + FileName), PChar(FilePath), SW_SHOWNORMAL); End; Procedure TForm18.Button4Click(Sender: TObject); Begin. If not OpenExplorerAndSelectFile('c:\windows\notepad.exe') then. ShowMessage('Файл не найден.'); End;

Это проще чем искать по заголовку.

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

Автор: Rouse_

©Drkb::02390.

Как вызвать диалог 'Найти файлы и паки' проводника?

Приведенный пример показывает использование DDE для вызова диалога 'Найти файлы и паки' Explorerа. Диалог открывается на каталоге "C:\Download".

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. With TDDEClientConv.Create(Self) do begin. ConnectMode := ddeManual; ServiceApplication := 'explorer.exe'; SetLink( 'Folders', 'AppProperties'); OpenLink; ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False); CloseLink; Free; End; End;

©Drkb::01217.

Как вызвать диалог свойств файла?

Code: Procedure ShowFileProperties(Const filename: String); Var. Sei: TShellExecuteinfo; Begin. FillChar(sei,sizeof(sei),0); Sei.cbSize := sizeof(sei); Sei.lpFile := Pchar(filename); Sei.lpVerb := 'properties'; Sei.fMask := SEE_MASK_INVOKEIDLIST; ShellExecuteEx(@sei); End;

©Drkb::03148.

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

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. If GetKeyState(VK_SHIFT) < 0 then. ShowMessage('Кнопка Shift нажата'). Else. ShowMessage('Обычное нажатие кнопки'); End;

Как выяснить дату последнего доступа к файлу?

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

Как выяснить дату создания файла?

Попробуйте следующую функцию, которая не требует вызова FindFirst:

Как быть, если таблица содержит столбцы, количество строк в которых разное?

Внести текст в ячейку можно, только если все ячейки одинаковой ширины и высоты. Иначе попросту OLE выдаст ошибку. Как быть, если таблица содержит столбцы, количество строк в которых разное?

Я использую перемещение от одной ячейки к следующей или поиск по шаблону. Затем заполняю выделенную ячейку информацией.

Как в байте информации выделить биты

В Delphi используй операцию and, которая возвращает результат побитового умножения. Пример a and $10 — выделить 4-ый бит. Если результат не ноль — бит установлен.

Как зарегистрировать свою команду в контекстном меню проводника?

Для подобных действий пишется маленький комсервер задача которого лишь реализовать 2 интерфейса IShellExtInit и IContextMenu. Для чего это делается - операционная система при инициализации меню проверит твою библиотеку на предмет: поддерживает ли она эти интерфейсы и если да - то вызовет нужные их методы. Ну а уж при срабатывании данных методов ты и добавляешь свои пункты меню. Для облегчения отладки, чтобы библиотека выгружалась сразу же как только не используется производим следующие действия: В реестре вот по этому пути HKEY_LOCAL_MASHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer устанавливаем строковое значение AlwaysUnloadDLL равным "1" (если такого значения нет, тогда нужно его создать). Далее пишем код: вот реализация сервера:

Code: // Test COM Server Shell Context menu extention. Library CONTMENU; {©Drkb v.3(2007): www.drkb.ru}. Uses. ComServ, ContextM in 'ContextM.pas'; Exports. DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; Begin. End.

Code: Unit ContextM; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, ActiveX, ComObj, ShlObj; Type. TContextMenu = class(TComObject, IShellExtInit, IContextMenu). Private. FFileName: array[0..MAX_PATH] of Char; TmpFileNames:String; Protected. { IShellExtInit }. Function IShellExtInit.Initialize = SEIInitialize; Function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject; HKeyProgID: HKEY): HResult; stdcall; { IContextMenu }. Function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, UFlags: UINT): HResult; stdcall; Function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall; Function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; PszName: LPSTR; cchMax: UINT): HResult; stdcall; End; Resourcestring. IDC_TEST1 = 'Тестовая строка номер 1'; IDC_TEST2 = 'Тестовая строка номер 2'; Const. Class_ContextMenu: TGUID = '{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'; Implementation. Uses ComServ, SysUtils, ShellApi, Registry, Graphics; // Тут наше меню инициализируется. // на вход приходит интерфейс IDataObject из которого мы можем получить. // список файлов и папок над которыми будут происходить действия. Function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject; HKeyProgID: HKEY): HResult; Var. StgMedium: TStgMedium; FormatEtc: TFormatEtc; FilesCount,I:Integer; Begin. If (lpdobj = nil) then. Begin. Result := E_INVALIDARG; Exit; End; With FormatEtc do begin. CfFormat := CF_HDROP; Ptd := nil; DwAspect := DVASPECT_CONTENT; Lindex := -1; Tymed := TYMED_HGLOBAL; End; Result := lpdobj.GetData(FormatEtc, StgMedium); If Failed(Result) then Exit; TmpFileNames := ''; FilesCount := DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, nil, 0); For I:= 0 to FilesCount - 1 do. Begin. DragQueryFile(StgMedium.hGlobal, I, FFileName, SizeOf(FFileName)); TmpFileNames := TmpFileNames + '"'+FFileName+'" '; End; Result := NOERROR; ReleaseStgMedium(StgMedium); End; // Создание меню. // по этому событию мы добавляем новые элементы меню... Function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, IdCmdLast, uFlags: UINT): HResult; Begin. Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0); If ((uFlags and $0000000F) = CMF_NORMAL) or. ((uFlags and CMF_EXPLORE) <> 0) then. Begin. // Разделитель. InsertMenu(Menu, indexMenu, MF_SEPARATOR or MF_BYPOSITION, 0, nil); // первый пункт меню. InsertMenu(Menu, indexMenu + 1, MF_STRING or MF_BYPOSITION, idCmdFirst, PChar(IDC_TEST1)); // второй пункт меню. InsertMenu(Menu, indexMenu + 2, MF_STRING or MF_BYPOSITION, idCmdFirst + 1, PChar(IDC_TEST2)); // разделитель. InsertMenu(Menu, indexMenu + 3, MF_SEPARATOR or MF_BYPOSITION, 0, nil); // указываем сколько пунктов меню мы добавили. // 2 пункта - т.к. разделители не считаются. Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 2); End; End; // данная функция срабатывает при нажатии на наш элемент меню. Function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; Begin. Result := E_FAIL; If (HiWord(Integer(lpici.lpVerb)) <> 0) then Exit; Result := NOERROR; // Выбор элементов меню идет по возрастающей в том порядке. // в каком они были добавлены. Case LoWord(lpici.lpVerb) of. 0: // первый элемент меню. // тут собственно и нужно делать реакцию на нажатие ;). MessageBox(lpici.hWnd, PChar(TmpFileNames), PChar(IDC_TEST1 + ' Pressed'), MB_OK); 1: // второй элемент меню. MessageBox(lpici.hWnd, PChar(TmpFileNames), PChar(IDC_TEST2 + ' Pressed'), MB_OK); Else. Result := E_INVALIDARG; End; End; // Данная функция вызывается когда статус бар в эксплорере активен. // и в нем отображается краткая информация о подсвеченном пункте меню. Function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT; PszName: LPSTR; cchMax: UINT): HRESULT; Begin. Result := S_OK; If uType = GCS_HELPTEXT then. Case idCmd of. 0: Begin. StrCopy(pszName, 'Справочная информация по первому пункту меню'); End; 1: Begin. StrCopy(pszName, 'Справочная информация по второму пункту меню'); End. Else. Result := E_INVALIDARG. End. End; Type. TContextMenuFactory = class(TComObjectFactory). Public. Procedure UpdateRegistry(Register: Boolean); override; End; // Это процедура которая будет выполнятся при вызове библиотеки из командной строки. // regsvr32 C:\CONTMENU.dll - регистрация библиотеки. // regsvr32 C:\CONTMENU.dll -unregister - снятие библиотеки с регистрации. Procedure TContextMenuFactory.UpdateRegistry(Register: Boolean); Var. ClassID: string; Begin. If Register then. Begin. Inherited UpdateRegistry(Register); ClassID := GUIDToString(Class_ContextMenu); CreateRegKey('Test\shellex', '', ''); CreateRegKey('Test\shellex\ContextMenuHandlers', '', ''); CreateRegKey('Test\shellex\ContextMenuHandlers\ContMenu', '', ClassID); If (Win32Platform = VER_PLATFORM_WIN32_NT) then. With TRegistry.Create do. Try. RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True); OpenKey('Approved', True); WriteString(ClassID, 'Test Context Menu Shell Extension'); Finally. Free; End; End. Else. Begin. DeleteRegKey('Test\shellex\ContextMenuHandlers\ContMenu'); DeleteRegKey('Test\shellex\ContextMenuHandlers'); DeleteRegKey('Test\shellex'); Inherited UpdateRegistry(Register); End; End; Initialization. TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu, '', 'Test Context Menu Shell Extension', ciMultiInstance, TmApartment); End.

Вот и все, компилишь этот код и у тебя готовый ком сервер... Регистрировать билиотеку из своей программы так:

Code: // Установка... {©Drkb v.3(2007): www.drkb.ru}. Procedure TForm1.btnRegClick(Sender: TObject); Begin. With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('CLSID\{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}\InprocServer32', True); WriteString('','C:\CONTMENU.dll'); WriteString('ThreadingModel','Apartment'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Classes\CLSID\{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}\InprocServer32', True); WriteString('','C:\CONTMENU.dll'); WriteString('ThreadingModel','Apartment'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', True); WriteString('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}', 'Test Context Menu Shell Extension'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('*\shellex\ContextMenuHandlers\Test', True); WriteString('','{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('Folder\shellex\ContextMenuHandlers\Test', True); WriteString('','{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'); CloseKey; Finally. Free; End; End; А снимать с регистрации вот так: // Удаление ... Procedure TForm1.btnUnRegClick(Sender: TObject); Begin. With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('CLSID', True); DeleteKey('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Classes\CLSID', True); DeleteKey('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_LOCAL_MACHINE; OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved', True); DeleteValue('{45C15F61-ACAD-48C6-8D86-321ED8A6CFC6}'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('*\shellex\ContextMenuHandlers', True); DeleteKey('Test'); CloseKey; Finally. Free; End; With TRegistry.Create do. Try. RootKey := HKEY_CLASSES_ROOT; OpenKey('Folder\shellex\ContextMenuHandlers', True); DeleteKey('Test'); CloseKey; Finally. Free; End; End;

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

Code: Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

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

Автор: Rouse_

©Drkb::02391.

Как заблокировать ввод нецифровых данных в Edit.

Блокировка вставки нецифровых данных через буфер обмена

Code: Uses Clipbrd; Function NewEditProc(wnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM):integer; stdcall; Var. S:string; I:integer; Begin. If (uMsg=WM_PASTE) and Clipboard.HasFormat(CF_TEXT) then. Begin. S := Clipboard.AsText; For i:=1 to Length(s) do if (not (s[i] in ['0'..'9'])) then begin uMsg:=0; break end. End; Result:=CallWindowProc(Pointer(GetWindowLong(wnd,GWL_USERDATA)),wnd,uMsg,wParam,lParam). End; Procedure TForm1.FormCreate(Sender: TObject); Begin. SetWindowLong(Edit1.Handle,GWL_STYLE,GetWindowLong(Edit1.Handle,GWL_STYLE) or ES_NUMBER); SetWindowLong(Edit1.Handle,GWL_USERDATA,SetWindowLong(Edit1.Handle, GWL_WNDPROC, LPARAM(@NewEditProc))). End;

Автор: Krid.

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

©Drkb::00543.

Следующий код создаёт TEdit который блокирует ввод любых нецифровых данных при вводе любым способом.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; { Пример TEdit с выравниванием по центру © Song. В модификации Vit}. {©Drkb v.3(2007): www.drkb.ru}. Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; { Обявляем класс нашего едита как потомок от стандартного}. Type TMySuperEdit=class(TCustomEdit). Public. { Внутри класса переопредялем процедуру CreateParams, Т.к. нужный нам стиль можно изменить только на создании или пересоздании. Окна }. Procedure CreateParams(Var Params: TCreateParams); override; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TMySuperEdit.CreateParams(Var Params: TCreateParams); Begin. { Вызываем родительский обработчик, чтобы он сделал все процедуры по созданию объекта класса }. Inherited CreateParams(Params); { Изменяем стиль }. With Params Do Style:=Style or ES_NUMBER; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. { Создаём едит на основе нашего класса и кладём его на форму }. With TMySuperEdit.Create(Self) Do. Parent:=Self; End; End.

©Drkb::00967.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

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

Автор: Full ( http://full.hotmail.ru/ ).

Code: Type. TNumEdit = class(TEdit). Procedure CreateParams(var Params: TCreateParams); override; Procedure KeyPress(var Key: Char); override; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Standard', [TNumEdit]); End; Procedure TNumEdit.CreateParams(var Params: TCreateParams); Begin. Inherited CreateParams(Params); Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT; End; Procedure TNumEdit.KeyPress(var Key: Char); Begin. Case key of. '0'..'9': ; // цифры. #8: ; // забой. '.', ',': if Pos(DecimalSeparator, Text)=0 then Key:=DecimalSeparator else Key:=#0; // десятичный разделитель. Else key:=#0; End; // case. End; End.

Как загрузить и отмасштабировать JPEGImage в TImage.

Code: Try. Image1.Picture.Graphic := nil; Image1.Picture.LoadFromFile(jpegfile); Except. On EInvalidGraphic do. Image1.Picture.Graphic := nil; End; If Image1.Picture.Graphic is TJPEGImage then. Begin. TJPEGImage(Image1.Picture.Graphic).Scale := Self.Scale; TJPEGImage(Image1.Picture.Graphic).Performance := jpBestSpeed; End;

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

Для того, чтобы отправить форму на сервер, необходимо: 1. Найти форму в исходном тексте страницы. Для этога найти в исходном тексте страницы теги <form>...</form> Например:

Code: <form method=GET action=http://localhost/cgi-bin/mget?> <input type=text name=name1 value="имя" size="40" maxlength="20"><br> <input type=text name=name2 value="фамилия" size="40" maxlength="20"><br> <input type=submit> </form>

2. Определить метод, который используется для отправки данных. В указанном выше примере это "GET" - form method=GET 3. Найти поля, которые необходимо заполнить. В примере это:

Code: <input type=text name=name1 value="имя" size="40" maxlength="20"><br> <input type=text name=name2 value="фамилия" size="40" maxlength="20"><br>

4. Используя компоненты для работы с протоколом TCP/IP, сформировать строку запроса. Для определенности пусть это будет компонент TIdHTTP из пакета Indy, входящий в стандартный набор компонент Delphi. -------------- Сформируем строку для отправки на сервер для нашего примера: Пусть нам нужно отправить значениядля полей: имя=Vasya, фамилия=Pupkin. В этом случае запрос будет выглядеть так:

Code: Var. S: String; Begin. S := IdHTTP1.Get('http://localhost/cgi-bin/mget?name1=Vasya&name2=Pupkin').

В случае, если форма использует метод POST:

Code: <form method=POST action=http://localhost/cgi-bin/mget?> <input type=text name=name1 value="имя" size="40" maxlength="20"><br> <input type=text name=name2 value="фамилия" size="40" maxlength="20"><br> <input type=submit> </form>

формируем запрос для отправки несколько по-другому:

Code: Var. TL: TStringList; S: String; Begin. TL := TStringList.Create; TL.Add('name1=Vasya'); TL.Add('name2=Pupkin'); Try. S := IdHTTP1.Post('http://localhost/cgi-bin/mget',tL); Finally. TL.Free; End;

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

Автор: Демо.

©Drkb::03584.

Как заставить системное меню выпасть в указанном месте?

Code: { How to popup the windows system menu? Maybe you can use Keybd_event to eumlate ALT+SPACE. Maybe you can use a TPopupmenu. But they always have some problem. The method below is a perfect solution! BTW: if your form has borderstyle = bsNone, Please do it like this: Set forms style = bsSingle; and use the code below to set form boder: SetWindowLong(Handle, GWL_STYLE,GetWindowLong(Handle, GWL_STYLE). And (not WS_CAPTION) or WS_DLGFRAME or WS_OVERLAPPED); } Procedure TForm1.Button1Click(Sender: TObject); Const. { Undocument message ID }. WM_POPUPSYSTEMMENU = $313; Begin. SendMessage(Handle, WM_POPUPSYSTEMMENU, 0, MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y)); End;

©Drkb::01312.

Как заставить форму находиться всегда позади всех окон.

Как заставить форму находиться всегда позади всех окон

Code: Type. TForm1 = class(TForm). Procedure WndProc (var message: TMessage); override; Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.WndProc (var message: TMessage); Begin. Case message.Msg of. WM_WINDOWPOSCHANGING: PWindowPos(Message.LParam)^.hwndInsertAfter:=HWND_BOTTOM; End; Inherited; End;

Автор: antonn.

©Drkb::00445.

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

Как заставить форму не разворачиваться из иконки

Code: Procedure WMQueryOpen(var Msg: TWMQueryOpen); Message WM_QUERYOPEN; // ... и ее реализация. Procedure TMainForm.WMQueryOpen(var Msg: TWMQueryOpen); Begin. Msg.Result := 0; End;

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

Автор: Nomadic.

Как заставить ORACLE анализировать все таблицы?

Конечно, можно использовать dbms_sql, dbms_job... А можно и так:

Code: #!/bin/sh. # # analyze all tables. # Sqlfile=/tmp/analyze.sql. Logfile=/tmp/analyze.log. Echo @connect dbo/passwd@ > $sqlfile. $oracle_home/bin/svrmgrl <> $sqlfile. Connect dbo/passwd. Select 'table', table_name from all_tables where owner = 'dbo'; Eof. Echo exit >> $sqlfile. Cat $sqlfile > $logfile. Cat $sqlfile | $oracle_home/bin/svrmgrl >> $logfile. Cat $logfile | /usr/bin/mailx -s 'analyze tables' tlk@nbd.kis.ru. Rm $sqlfile. Rm $logfile.

Источник: http://www.codenet.ru.

©Drkb::02724.

Как извлечь "Сводку" свойств файла?

Ниже показан пример получения набора свойств файла (которые отображаются на вкладке "Сводка" диалогового окна "Свойства:"). В файловой системе NTFS читаются свойства любого файла (если они вообще есть, конечно). В других ФС читаются св-ва только compound-файлов (они же structured storage, т.е. файлы хранения структурированной информации, такие как файлы MS Office, пакеты MSI, etc.), т.к. в этом случае вся информация о св-вах находится в самих файлах (опять же, она может там и отсутствовать). Ну и, естественно, не читаются нестандартные свойства, т.к. они нигде не хранятся, а динамически добавляются на вкладку соответствующим файлу COM-сервером - обработчиком вкладок св-в (PropertySheetHandlers). В этом примере считывается несколько св-в из набора SummaryInformation.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls; Type. TForm1 = class(TForm). Button1: TButton; ListView1: TListView; OpenDialog1: TOpenDialog; Procedure Button1Click(Sender: TObject); Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses ActiveX, ComObj; Function StgOpenStorageEx(const pwcsName : POleStr; grfMode : LongInt; stgfmt : DWORD; GrfAttrs : DWORD; pStgOptions : Pointer; reserved2 : Pointer; Riid : PGUID; out stgOpen : IStorage ) : HResult; stdcall; external 'ole32.dll'; Const. // GUID'ы для набора св-в SummaryInformation. FMTID_SummaryInformation : TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}'; IID_IPropertySetStorage : TGUID = '{0000013A-0000-0000-C000-000000000046}'; STGFMT_FILE = 3; STGFMT_ANY = 4; Type. PPropSpecArray=^TPropSpecArray; // массив спецификаций св-в. TPropSpecArray=array[0..999] of TPropSpec; PPropVariantArray=^TPropVariantArray; // массив - приемник, куда будут помещены значения нужных св-в. TPropVariantArray=array[0..999] of TPropVariant; // вспомогательные ф-ции ******* Function IsNTFS(AFileName : string) : boolean; Var. Fso, drv : OleVariant; Begin. Fso := CreateOleObject('Scripting.FileSystemObject'); Drv := fso.GetDrive(fso.GetDriveName(AFileName)); Result:=drv.FileSystem = 'NTFS' End; Function FileTimeToLocalSystemTime(ft:FILETIME):TSystemTime; Var. T:FILETIME; Begin. FileTimeToLocalFileTime(ft,t); FileTimeToSystemTime(t,result); End; Function SysTimeToStr(ST : TSystemTime):string; Begin. SetLength(result,15); GetTimeFormat(LOCALE_USER_DEFAULT,0,@st,nil,@result[1],15); SetLength(result, StrLen(@result[1])); End; Function SysDateToStr(ST : TSystemTime) : string; Begin. SetLength(Result, 255); GetDateFormat(LOCALE_USER_DEFAULT, DATE_LONGDATE, @ST, nil, @result[1], 255); SetLength(Result, LStrLen(@result[1])); End; Function SysDateTimeToStr(ST:TSystemTime):string; Begin. Result:=SysDateToStr(ST)+' '+SysTimeToStr(ST). End; // ******* Procedure TForm1.Button1Click(Sender: TObject); Var. StgRoot:IStorage; StgPS:IPropertySetStorage; StgP:IPropertyStorage; Ps:PPropSpecArray; Pv:PPropVariantArray; Lit:TListItem; // значения св-в записываем в ListView. Begin. If (not OpenDialog1.Execute) then exit; // выбираем файл. // Проверяем: если это не compound file и система - не NTFS, тогда выходим. // (для compound файлов FS не важна). If (StgIsStorageFile(StringToOleStr(OpenDialog1.FileName))<>S_OK) then. If (not IsNTFS(OpenDialog1.FileName)) then. Begin. MessageBox(Handle,'NTFS needed for non-compound files','Error',MB_ICONERROR); Exit; End; ListView1.Clear; If (StgOpenStorageEx(StringToOleStr(OpenDialog1.FileName), STGM_READ or STGM_SHARE_DENY_WRITE, STGFMT_ANY, 0, nil, nil, @IID_IPropertySetStorage, stgRoot)<>S_OK) then // открываем файл. Begin. MessageBox(Handle,'Can not open file','Error',MB_ICONERROR); Exit; End; StgPS:=stgRoot as IPropertySetStorage; // ссылаемся на нужный интерфейс. //открываем набор св-в. If (stgPS.Open(FMTID_SummaryInformation,STGM_READ or STGM_SHARE_EXCLUSIVE,stgP)<>S_OK) then. Begin. MessageBox(Handle,'Can not open property set','Error',MB_ICONERROR); Exit; End; Ps:=nil; Pv:=nil; Try. GetMem(ps,SizeOf(TPropSpec)); GetMem(pv,SizeOf(TPropVariant)); Ps[0].ulKind:=PRSPEC_PROPID; // считываем св-ва по их идентификатору (см. ActiveX.pas). // Прочитаем несколько св-в файла. // В этом примере - для наглядности - читаем по одному св-ву из потока (можно за один раз прочитать и больше), // поэтому каждый раз значение будет лежать в pv[0]. Ps[0].propid:=PIDSI_TITLE; // заголовок. Lit:=ListView1.Items.Add; Lit.Caption:='Title'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then // читаем св-во. Lit.SubItems.Add(pv[0].pszVal) // добавляем в ListView. Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_SUBJECT; // тема. Lit:=ListView1.Items.Add; Lit.Caption:='Subject'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(pv[0].pszVal). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_AUTHOR; // автор. Lit:=ListView1.Items.Add; Lit.Caption:='Author'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(pv[0].pszVal). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_COMMENTS; // комментарий. Lit:=ListView1.Items.Add; Lit.Caption:='Comment'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(pv[0].pszVal). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_REVNUMBER; // номер редакции. Lit:=ListView1.Items.Add; Lit.Caption:='Revision'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(pv[0].pszVal). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_APPNAME; // приложение, создавшее пакет. Lit:=ListView1.Items.Add; Lit.Caption:='Application'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(pv[0].pszVal). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_CREATE_DTM; // Дата создания. Lit:=ListView1.Items.Add; Lit.Caption:='Creation date'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(SysDateTimeToStr(FileTimeToLocalSystemTime(pv[0].filetime))). Else lit.SubItems.Add(''); Ps[0].propid:=PIDSI_WORDCOUNT; // кол-во слов в документе. Lit:=ListView1.Items.Add; Lit.Caption:='Word count'; If (stgP.ReadMultiple(1, @ps[0], @pv[0])=S_OK) then. Lit.SubItems.Add(IntToStr(pv[0].lVal)). Else lit.SubItems.Add(''); Finally. If assigned(ps) then FreeMem(ps); If assigned(pv) then FreeMem(pv); StgP:=nil; StgPS:=nil; StgRoot:=nil; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. // добавим в список 2 столбца (лучше это делать в дизайнере). ListView1.ViewStyle:=vsReport; ListView1.Columns.Add.Caption:='Name'; ListView1.Columns.Add.Caption:='Value'; // добавим в диалог открытия несколько типов compound-файлов. OpenDialog1.Filter:='All Files (*.*)|*.*|MS Office Documents (*.doc;*.xls;*.dot)'+ '|*.doc; *.xls; *.dot|MSI Databases (*.msi)|*.msi'; End; End.

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

Автор: Krid.

©Drkb::03147.

Как изменить заголовок кнопки ПУСК

Для начала создайте какой-нибудь Bitmap, который вы будете натягивать на кнопку [т.к. такого понятия как "заголовок кнопки ПУСК" в действительности не существует], а та надпись, что находится на стартовой кнопке, является рисунком. Создавая рисунок, учитывайте размеры и то, что левая сторона должна быть "плоской", как у нас на рисунке слева, это связано с особенностями наложения.

Как изменить шрифт в таблице?

Попробуем изменить шрифт только в ячейке таблицы. Для этого можно использовать объект Font как свойство ячейки, например: ActiveDocument.Tables.Item(Table).Columns.Item(Column).Cells.Item(Row).Range.font.

Есть и другой способ: можно выделить ячейку и работать с объектом Selection.Font. Второй способ выгоден тем, что его можно использовать для изменения шрифта не только в таблице, но и во всех выделенных объектах. Рассмотрим его подробнее. Выделим ячейку таблицы, используя метод Select объекта Cell. В Delphi эта функция будет выглядеть следующим образом:

Code: Function SelectCell(Table:integer; Row,Column:integer):boolean; Begin. SelectCell:=true; Try. W.ActiveDocument.Tables.Item(Table).Columns.Item. (Column).Cells.Item(Row).Select; Except. SelectCell:=false; End; End;

Как изменить положение таблицы на листе (подвинуть влево, вправо, вверх, вниз)?

Координаты таблицы можно изменить, но эти изменения ограничены по своим возможностям:

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

1. есть возможность менять только левый отступ таблицы от края листа. Вертикальное положение определяется строкой, на которой создается таблица. Поэтому чтобы изменить вертикальное положение таблицы, необходимо добавить или удалить строки, расположенные выше таблицы. Левый отступ определяется значением, записанным в поле LeftIndent коллекции Rows таблицы: W.ActiveDocument.Tables.Item (tab_).Rows.LeftIndent=Left; где Tab_ - номер таблицы, Left - левый отступ таблицы.

Как изменить цвет сетки таблицы?

Информация о стиле, цвете и других параметрах ячейки таблицы содержится в элементах коллекции Borders, которые, по сути, представляют собой линии, ограничивающие и пересекающие ячейку. Выбор элемента коллекции производится через константы WdBorderBottom, WdBorderHorizontal, WdBorderLeft, WdBorderRight, WdBorderTop, wdBorderVertical. Цвет сетки определяется индексом, который записывается в поле ColorIndex элемента коллекции. Оператор установки цвета для Delphi выглядит следующим образом, смотрите пример:

Code: W.ActiveDocument.Tables.Item(tab_).Columns.Item(col_).Cells.Item(row_).Borders.Item(wdBorderTop).ColorIndex:=wdDarkRed;

Как изменить фоновый цвет текста

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

Как из Handle битовой картинки, получить адрес битового изображения в памяти

Автор: Nomadic.

Как корректно определить изменения в оборудовании PlugNPlay?

Code: Type. TForm1 = class(TForm). Button1: TButton; Private. { Private declarations }. Procedure WMDeviceChange(var Message: TMessage); Message WM_DEVICECHANGE; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Const DBT_DEVICEARRIVAL = $8000; Const DBT_DEVICEQUERYREMOVE = $8001; Const DBT_DEVICEQUERYREMOVEFAILED = $8002; Const DBT_DEVICEREMOVEPENDING = $8003; Const DBT_DEVICEREMOVECOMPLETE = $8004; Const DBT_DEVICETYPESPECIFIC = $8005; Const DBT_CONFIGCHANGED = $0018; Procedure TForm1.WMDeviceChange(var Message: TMessage); Var. S : string; Begin. {Do Something here}. Case Message.wParam of. DBT_DEVICEARRIVAL : S := 'A device has been inserted and is now available'; DBT_DEVICEQUERYREMOVE: begin. S := 'Permission to remove a device is requested'; ShowMessage(s); {True grants premission}. Message.Result := integer(true); Exit; End; DBT_DEVICEQUERYREMOVEFAILED : S := 'Request to remove a device has been canceled'; DBT_DEVICEREMOVEPENDING : S := 'Device is about to be removed'; DBT_DEVICEREMOVECOMPLETE : S := 'Device has been removed'; DBT_DEVICETYPESPECIFIC : S := 'Device-specific event'; DBT_CONFIGCHANGED : S:= 'Current configuration has changed' Else s := 'Unknown Device Message'; End; ShowMessage(s); Inherited; End;

©Drkb::01334.

Как рисовать на экране

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

Как использовать различные шрифты и стили в Memo-объекте?

Просто создайте собственный TxxxMemo: наследуйтесь от стандартного TMemo и перекройте метод Paint.

Как использовать в UDF функциях GetDate() и NewID().

Их использование запрещено, но запрет можно обойти создав View в котором столбец является вычисляемым полем и принимает значение GetDate() или NewID(). В UDF выполнять Select из этого View.

©Drkb::02822.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Как использовать CreateWindow(Ex).

Автор: lel.

Как использовать клавишу-акселератор в TTabSheets (TPageControl).

Code: { With menus (and labels), If you use the '&' character in the caption of a menu, You can access that menu item with the short cut key. With this code you can do the same thing with TTabSheet objects. That are used with TPageControl objects. Zugriffstasten ermoglichen die Ausfuhrung eines Menubefehls mit Hilfe der Tastatur. Der Benutzer braucht nur die Taste Alt und den mit dem Zeichen & kombinierten. Buchstaben zu drucken. Dieser code erlaubt dieselebe Funktionalitat fur ein. TTabSheet eines TPageControls. } // in form declaration. Private. Procedure CMDialogChar(var Msg: TWMCHAR); message CM_DIALOGCHAR; End; Type. TPageControlCracker = class(TPageControl); {...} Implementation. Procedure TForm1.CMDialogChar(var Msg: TWMCHAR); Var. I: Integer; Begin. If (Msg.keydata and $20000000) <> 0 then. Begin. { Alt key is down }. With TPageControlCracker(PageControl1) do. For i := 0 to PageCount - 1 do. Begin. If IsAccel(Msg.charcode, Pages[i].Caption) then. Begin. If CanChange then. Begin. ActivePage := Pages[i]; Msg.Result := 1; Change; Exit; End; { If }. End; { If }. End; {For}. End; {If}. Inherited; End;

КАК ЧИТАТЬ ФАЙЛЫ OUTLOOK EXPRESS.

КАК ЧИТАТЬ ФАЙЛЫ OUTLOOK EXPRESS (.DBX) (формат файла *.DBX).

1)Структура файла.

Сообщения хранятся в таблицах, расположенных друг за другом, по порядку. Каждая таблица состоит из двух частей - заголовка и _входа_. Смещение первой таблицы от начала файла располагается со смещением $30 от начала файла и представляет собой знаковое 32-х битное число (тип integer или longint). Общее же количество записей (т.е. этих самых таблиц) расположено со смещением $C4 от начала файла, и представляет собой число типа integer (longint).

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

Code: Toe5_IndexHeader = record. FilePos: longint; {Это смещение структуры, используется для контроля}. Unknown1: longint; { ??? }. PrevIndex: longint; {Смещение предыдущей таблицы}. NextIndex: longint; {Смещение следующей таблицы}. Count: longint; {Количество _входов_, реальное количество находится так: count shr 8}. Unknown2: longint; { ??? }. End;

Как шифровать файлы при помощи windows NTFS API.

Code: { This tip works with Windows 2000 (NTFS 5) and later. These 2 functions are defined in windows.pas, but they're defined wrong. In this. Case our own definition. } Function EncryptFile(lpFilename: PChar): BOOL; stdcall; External advapi32 name 'EncryptFileA'; Function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall; External advapi32 name 'DecryptFileA'; {....} Procedure TForm1.Button1Click(Sender: TObject); Begin. If not EncryptFile('c:\temp') then. ShowMessage('Cannot encrypt directory.'); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. If not DecryptFile('c:\temp', 0) then. ShowMessage('Cannot decrypt directory.'); End;

Как перевести монитор в режим stand-by.

Если монитор поддерживает режим Stand by, то его можно программно перевести в этот режим. Данная возможность доступна на Windows95 и выше.

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

получатель:

Как передать UserName и Password в удаленный модуль данных

В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.

Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.

Code: Procedure Login(UserName, Password: WideString); Begin. { DB = TDatabase }. { Something unique between clients }. DB.DatabaseName := UserName + 'DB'; DB.Params.Values['USER NAME'] := UserName; DB.Params.Values['PASSWORD'] := Password; DB.Open; End;

Как обрезать форму по рисунку?

Вот пример, правда для Bitmap, хотя преобразовать PNG в BMP не составит труда.

Code: Unit Unit1; Interface. Uses. Windows, Classes, SysUtils, Graphics, Forms; Type. TRGBArray = array[0..32767] of TRGBTriple; PRGBArray = ^TRGBArray; Type. TForm1 = class(TForm). Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. { Private declarations }. FRegion: THandle; Function CreateRegion(Bmp: TBitmap): THandle; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function TForm1.CreateRegion(Bmp: TBitmap): THandle; Var. X, Y, StartX: Integer; Excl: THandle; Row: PRGBArray; TransparentColor: TRGBTriple; Begin. Bmp.PixelFormat := pf24Bit; Result := CreateRectRGN(0, 0, Bmp.Width, Bmp.Height); For Y := 0 to Bmp.Height - 1 do. Begin. Row := Bmp.Scanline[Y]; StartX := -1; If Y = 0 then. TransparentColor := Row[0]; For X := 0 to Bmp.Width - 1 do. Begin. If (Row[X].rgbtRed = TransparentColor.rgbtRed) and. (Row[X].rgbtGreen = TransparentColor.rgbtGreen) and. (Row[X].rgbtBlue = TransparentColor.rgbtBlue) then. Begin. If StartX = -1 then StartX := X; End. Else. Begin. If StartX > -1 then. Begin. Excl := CreateRectRGN(StartX, Y, X + 1, Y + 1); Try. CombineRGN(Result, Result, Excl, RGN_DIFF); StartX := -1; Finally. DeleteObject(Excl); End; End; End; End; If StartX > -1 then. Begin. Excl := CreateRectRGN(StartX, Y, Bmp.Width, Y + 1); Try. CombineRGN(Result, Result, Excl, RGN_DIFF); Finally. DeleteObject(Excl); End; End; End; End; Procedure TForm1.FormCreate(Sender: TObject); Var. Bmp: TBitmap; Begin. Bmp := TBitmap.Create; Try. Bmp.LoadFromFile('C:\YourBitmap.bmp'); FRegion := CreateRegion(Bmp); SetWindowRGN(Handle, FRegion, True); Finally. Bmp.Free; End; End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. DeleteObject(FRegion); End; End.

Автор: Smike.

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

©Drkb::03634.

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

Я не профи в Win API, просто у меня возникла именно такая проблема. Я нашел решение устраивающее меня. И к тому же решил, поделился с вами. Если кому-то требуется что-то другое - дерзайте, я с удовольствием прочту на "Королевстве" что и как у вас получилось. Handle = Хэндл = Рукоятка :).

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

Используем объект Selection. Объект Selection имеет поля Start и End. Эти поля имеют тип Integer и содержат номера символов начальной и конечной позиции выделенного текста. Если выделить весь документ, а затем считать значения этих полей, то сможем определить объем документа как количество символов. Если в поле Start объекта Selection записать значение из поля End этого же объекта, то курсор будет перемещен в конец документа. Используем это обстоятельство для перемещения курсора в конец документа. В Delphi это выглядит следующим образом:

Code: Function EndOfDoc:boolean; Begin. EndOfDoc:=true; Try. W.ActiveDocument.Range.Select; W.Selection.Start:=W.Selection.End; Except. EndOfDoc:=false; End; End;

Как перемещать компонент во время работы программы

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

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

Данный способ позволяет не погружаясь глубоко в создание компонент осуществить операцию "drag and drop" выделенного текста.

Как перетащить целую колонку из StringGrid в ListBox.

В Object Inspector установите свойство dragmode у StringGrid в dmAutomatic.

Как нарисовать Bitmap с прозрачностью

Code: Procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap; clTransparent: TColor); Var. BmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap; Oldcol: Longint; Begin. Try. BmpAND := TBitmap.Create; BmpAND.Width := Bmp.Width; BmpAND.Height := Bmp.Height; BmpAND.Monochrome := True; Oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent)); BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY); SetBkColor(Bmp.Canvas.Handle, oldcol); BmpINVAND := TBitmap.Create; BmpINVAND.Width := Bmp.Width; BmpINVAND.Height := Bmp.Height; BmpINVAND.Monochrome := True; BitBlt(bmpINVAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY); BmpXOR := TBitmap.Create; BmpXOR.Width := Bmp.Width; BmpXOR.Height := Bmp.Height; BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY); BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND); BmpTarget := TBitmap.Create; BmpTarget.Width := Bmp.Width; BmpTarget.Height := Bmp.Height; BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Cnv.Handle, x, y, SRCCOPY); BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND); BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT); BitBlt(Cnv.Handle, x, y, Bmp.Width, Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY); Finally. BmpXOR.Free; BmpAND.Free; BmpINVAND.Free; BmpTarget.Free; End; End;

©Drkb::03875.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как нарисовать фрактал

Code: Procedure DrawMandelbrot(ACanvas: TCanvas; X, Y, au, bu: Double; X2, Y2: Integer); Var. C1, c2, z1, z2, tmp: Double; I, j, Count: Integer; Begin. C2 := bu; For i := 10 to X2 do. Begin. C1 := au; For j := 0 to Y2 do. Begin. Z1 := 0; Z2 := 0; Count := 0; {count is deep of iteration of the mandelbrot set. If |z| >=2 then z is not a member of a mandelset}. While (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do. Begin. Tmp := z1; Z1 := z1 * z1 - z2 * z2 + c1; Z2 := 2 * tmp * z2 + c2; Inc(Count); End; //the color-palette depends on TColor(n*count mod t). {$IFDEF LINUX}. ACanvas.Pen.Color := (16 * Count mod 255); ACanvas.DrawPoint(j, i); {$ELSE}. ACanvas.Pixels[j, i] := (16 * Count mod 255); {$ENDIF}. C1 := c1 + X; End; C2 := c2 + Y; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. R: TRect; Au, ao: Integer; DX, dY, bo, bu: Double; Begin. // Initialize Mandelbrot. R.Left := 0; R.Right := 200; R.Top := 0; R.Bottom := 205; Ao := 1; Au := -2; Bo := 1.5; Bu := -1.5; //direct scaling cause of speed. DX := (ao - au) / (R.Right - R.Left); DY := (bo - bu) / (R.Bottom - R.Top); DrawMandelbrot(Self.Canvas, dX, dY, au, bu, R.Right, R.Bottom); End;

©Drkb::04223.

Взято с сайта: http://www.swissdelphicenter.ch.

Как найти каталог Windows.

Code: Function GetWindowsFolder:string; {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Var p:PChar; Begin. GetMem(p, MAX_PATH); Result:=''; If GetWindowsDirectory(p, MAX_PATH)>0 then. Result:=string(p); FreeMem(p); End;

©Drkb::01659.

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org).

Как найти позицию текстового курсора в пикселях?

Code: Var. Pt: TPoint; Begin. With richedit1 do begin. Perform( messages.EM_POSFROMCHAR, WPARAM(@pt), selstart ); Label1.caption := Format('(%d,%d)', [pt.x, pt.y]); End; End; Var. R: LongInt; Begin. With memo1 do begin. R := Perform( messages.EM_POSFROMCHAR, selstart, 0); If r >= 0 then begin. Label1.caption := IntToStr(HiWord(r)); Label2.caption := IntToStr(LoWord(r)); End; End; End;

©Drkb::00581.

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

Более подробно ищите в хелпе Delphi по словам "Variant" и "TVarData"...

Как напечатать документ без предварительной настройки принтера (что печатать, какое качество печати и т.д.)?

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

Code: Function PrintOutDoc(NumCopies:integer):boolean; Begin. PrintOutDoc:=true; Try. W.ActiveDocument.PrintOut(NumCopies); Except. PrintOutDoc:=false; End;

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

Для печати документа через диалог можно использовать элемент wdDialogFilePrint коллекции Dialogs, метод Show.W.Dialogs.Item(wdDialogFilePrint).Show; где wdDialogFilePrint=88; Если в этом диалоге использовать метод Execute, то будет запущена печать без диалога.

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

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

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

Code: Uses ..., WinSpool; {©Drkb v.3(2007): www.drkb.ru}. Procedure TForm1.Button1Click(Sender: TObject); Var. PrintersInfo, TmpPrintersInfo: PPrinterInfo1; PcbNeeded, pcReturned, jpcbNeeded, jpcReturned: DWORD; I, J: Integer; HPrinter: THandle; JobInfo, TmpJobInfo: PJobInfo3; Begin. EnumPrinters(PRINTER_ENUM_LOCAL, nil, 1, PrintersInfo, 0, pcbNeeded, pcReturned); If GetLastError = ERROR_INSUFFICIENT_BUFFER then. Begin. GetMem(PrintersInfo, pcbNeeded); Try. If EnumPrinters(PRINTER_ENUM_LOCAL, nil, 1, PrintersInfo, pcbNeeded, pcbNeeded, pcReturned) then. Begin. TmpPrintersInfo := PrintersInfo; For I := 0 to pcReturned - 1 do. Begin. If OpenPrinter(TmpPrintersInfo^.pName, hPrinter, nil) then. Begin. EnumJobs(hPrinter, 0, 100, 1, nil, 0, jpcbNeeded, jpcReturned); If GetLastError in [NO_ERROR, ERROR_INSUFFICIENT_BUFFER] then. Begin. GetMem(JobInfo, jpcbNeeded); Try. If EnumJobs(hPrinter, 0, 100, 3, JobInfo, JpcbNeeded, jpcbNeeded, jpcReturned) then. Begin. TmpJobInfo := JobInfo; For J := 0 to jpcReturned - 1 do. Begin. If not SetJob(hPrinter, TmpJobInfo^.JobId, 0, Nil, JOB_CONTROL_DELETE) then RaiseLastOSError; Inc(TmpJobInfo); End; End. Else. RaiseLastOSError; Finally. FreeMem(JobInfo); End; End. Else. RaiseLastOSError; End. Else. RaiseLastOSError; Inc(TmpPrintersInfo); End; End. Else. RaiseLastOSError; Finally. FreeMem(PrintersInfo); End; End. Else. RaiseLastOSError; End;

©Drkb::03256.

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

Автор: Rouse_

Как определение нажатия определенной клавиши во время загрузки приложения?

Используйту WinAPI функцию GetKeyState() для определения нажатия клавиши в тексте проекта. Для того чтобы увидеть текст файла проекта в главном меню Delphi 3 выберите "View">>"ProjectSource" в Delphi 4 "Project">>"View Source".

Code: Program Project1; Uses. Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES}. Begin. If GetKeyState(vk_F8) < 1 then. MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok); Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; End.

©Drkb::01530.

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

Как определить закрытие командного окна в консольном приложении

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

Как определить, имеет ли файл ASCII-формат

Code: Function isAscii(NomeFile: string): Boolean; Const. SETT = 2048; Var. I: Integer; F: file; A: Boolean; TotSize, IncSize, ReadSize: Integer; C: array[0..Sett] of Byte; Begin. If FileExists(NomeFile) then. Begin. {$I-}. AssignFile(F, NomeFile); Reset(F, 1); TotSize := FileSize(F); IncSize := 0; A := True; While (IncSize < TotSize) and (a = True) do. Begin. ReadSize := SETT; If IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize; IncSize := IncSize + ReadSize; BlockRead(F, c, ReadSize); // Iterate. For i := 0 to ReadSize - 1 do. If (c[i] < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False; End; { while }. CloseFile(F); {$I+}. If IOResult <> 0 then Result := False. Else. Result := a; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then. If isAscii(OpenDialog1.FileName) then. ShowMessage('ASCII File'); End;

Как определить нажаты ли клавиши Shift, Alt или Ctrl в какой-либо момент времени

В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, Ctrl.

Как определить формат изображения, загруженного в TMemoryStream?

Code: Type. TImageType = (NoImage, Bmp, Gif, Gif89, Png, Jpg); Function KindOfImage(Start: Pointer): TImageType; Type. ByteArray = array[0..10] of Byte; Var. PB: ^ByteArray absolute Start; PW: ^Word absolute Start; PL: ^DWord absolute Start; Begin. If PL^ = $38464947 then. Begin. If PB^[4] = Ord('9') then Result := Gif89. Else Result := Gif; End. Else if PW^ = $4D42 then Result := Bmp. Else if PL^ = $474E5089 then Result := Png. Else if PW^ = $D8FF then Result := Jpg. Else Result := NoImage; End;

Пользоваться можно так:

Code: Case KindOfImage(MemoryStream.Memory) of. ...

Для тех, кого смущает absolute:

Code: Type. TImageType = (NoImage, Bmp, Gif, Gif89, Png, Jpg); Function KindOfImage(Start: Pointer): TImageType; Begin. If LongWord(Start^) = $38464947 then. Begin. If (PChar(Start) + 4)^ = '9' then Result := Gif89. Else Result := Gif; End. Else if Word(Start^) = $4D42 then Result := Bmp. Else if LongWord(Start^) = $474E5089 then Result := Png. Else if Word(Start^) = $D8FF then Result := Jpg. Else Result := NoImage; End;

Автор: Smike.

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

©Drkb::03633.

Как определить, что два слова имеют схожее произношение

Автор: Lloyd.

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

Code: //На русский. Procedure TForm1.Button1Click(Sender: TObject); Var. Layout: array[0.. KL_NAMELENGTH] of char; Begin. LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE); End;

Как подгружать JPG-картинки, но чтобы они быстро отображались

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. If Image1.Picture.Graphic is TJPEGImage then. Begin. TJPEGImage(Image1.Picture.Graphic).DIBNeeded; End; End;

Как можно работать с DDE под Delphi, используя вызовы API.

Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.

Как можно определить доступные сервера приложений на этой машине через Registry.

Автор: Nomadic.

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

Как можно узнать что было изменениие, Наприме сдвиг мыши или нажатие клавиши

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Memo1: TMemo; Procedure FormCreate(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Var. MouseHook: HHOOK; Function LowLevelMouseProc(nCode: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; Begin. Result := CallNextHookEx(MouseHook, nCode, WParam, LParam); Case WParam of. WM_LBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась левой кнопкой.'); WM_LBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась левой кнопкой.'); WM_LBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась левой кнопкой.'); WM_RBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась правой кнопкой.'); WM_RBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась правой кнопкой.'); WM_RBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась правой кнопкой.'); WM_MBUTTONDOWN: Form1.Memo1.Lines.Add('Мыша вдавилась средней кнопкой.'); WM_MBUTTONUP: Form1.Memo1.Lines.Add('Мыша отдавилась средней кнопкой.'); WM_MBUTTONDBLCLK: Form1.Memo1.Lines.Add('Мыша дважды клацнулась средней кнопкой.'); WM_MOUSEMOVE: Form1.Memo1.Lines.Add('Мыша побежала.'); WM_MOUSEWHEEL: Form1.Memo1.Lines.Add('Мыша тащиться.'); Else. Form1.Memo1.Lines.Add('Мыша сошла с ума, купите новую мышу.'); End; End; Procedure TForm1.FormCreate(Sender: TObject); Const. WH_MOUSE_LL = 14; Begin. MouseHook := SetWindowsHookEx(WH_MOUSE_LL, @LowLevelMouseProc, HInstance, 0); End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. UnhookWindowsHookEx(MouseHook); End; End.

Тож самое и на клавиатуру, код хука - Цифра 13 Соответственно принимай уже мессаги от клавиатуры... Только начиная с Win 2000.

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

Автор: Rouse_

©Drkb::01612.

Как проводить локализацию своих приложений

В Delphi есть специальные механизмы, позволяющие приложение "переделать" на любой язык после компиляции. Для D3 надо посмотреть в хелпе, по-моему, internationalization или что-то в этом роде. Для D4 вообще все делается ОЧЕНЬ просто:

Как показать иконку, ассоциированную с данным типом файла

Code: Uses. ShellAPI; ... Procedure TForm1.Button1Click(Sender: TObject); Var. Icon: hIcon; IconIndex: word; Begin. IconIndex := 1; Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex); DrawIcon(Canvas.Handle, 10, 10, Icon); End;

Как показать на экpане и сохранить в базе картинку формата JPEG.

Code: If Picture.Graphic is TJPegImage then. Begin. Bs:=TBlobStream.Create(TBlobField(Field),bmWrite); Picture.Graphic.SaveToStream(bs); Bs.Free; End. Else. If Picture.Graphic is TBitmap then. Begin. Jpg:=TJPegImage.Create; Jpg.CompressionQuality:=...; Jpg.PixelFormat:=...; Jpg.Assign(Picture.Graphic); Jpg.JPEGNeeded; Bs:=TBlobStream.Create(TBlobField(Field),bmWrite); Jpg.SaveToStream(bs); Bs.Free; Jpg.Free; End. Else. Field.Clear;

Как показать округлённое окошко подсказки в Tray в Windows2000.

В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.

Как показать подсказки Hints для элементов меню

В примере создается обработчик события Application.Hint - подсказки меню изображаются на status Panel:

Как прочитать базу данных с Досовским шрифтом.

Как прочитать базу данных с Досовским шрифтом

При старте приложения попробуй вызвать вот такую процедуру:

Code: Procedure SetLangForParadoxAndDBase; Var. P :TStringList; C :TConfigMode; Begin. P := TStringList.Create; C := Session.ConfigMode; Session.ConfigMode := cmSession; Try. P.Text := 'LANGDRIVER=ancyrr'^M^J'LEVEL=7'; Session.ModifyDriver('PARADOX',p); P.Text := 'LANGDRIVER=db866ru0'^M^J'LEVEL=7'; Session.ModifyDriver('DBASE',p); Finally. Session.ConfigMode := c; P.Free; End; End;

©Drkb::02715.

Взято с Vingrad.ru http://forum.vingrad.ru.

Как прочитать русский текст MS-DOS.

Для перекодировки из Win(1251) кодовой страницы в Dos(866) кодовую страницу и обратно используются функции:

Как получить версию Windows?

Code: Type TOSVersion=(osUnknown, osUnknown9x, osUnknownNT, osWin95, osWin98, osWin98SE, osWinME, osWinNT, osWin2000, osXP); {©Drkb v.3(2007): www.drkb.ru, ®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}. Function GetOSVersion : TOSVersion; Var osVerInfo : TOSVersionInfo; MajorVer, minorVer : Integer; Begin. Result := OsUnknown; OsVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); If GetVersionEx(osVerInfo) then. Begin. MajorVer := osVerInfo.dwMajorVersion; MinorVer := osVerInfo.dwMinorVersion; Case osVerInfo.dwPlatformId of. VER_PLATFORM_WIN32_NT : Case majorVer of. 4:result := OsWinNT; 5:if minorVer=0 then result := OsWin2000. Else. If minorVer=1 then result := OsXP else result := osUnknownNT; Else result := osUnknownNT; End; {Case majorVer of}. VER_PLATFORM_WIN32_WINDOWS : Case majorVer of. 4: Case minorVer of. 0:result := OsWin95; 10: if osVerInfo.szCSDVersion[1] = 'A' then result := OsWin98SE else result := OsWin98; 90: result := OsWinME; Else result := osUnknown9x; End;{Case minorVer of}. Else result := osUnknown9x; End{case majorVer of}. Else result := OsUnknown; End;{case osVerInfo.dwPlatformId of}. End;{if GetVersionEx(osVerInfo) then}. End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Case GetOSVersion of. OsUnknown: Showmessage('Unknown'); OsWin95: Showmessage('Win95'); OsWin98: Showmessage('Win98'); OsWin98SE: Showmessage('Win98SE'); OsWinME: Showmessage('WinME'); OsWinNT: Showmessage('WinNT'); OsWin2000: Showmessage('Win2000'); OsXP: Showmessage('XP'); End; End;

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

В следуещем примере используется функция Windows API FindWindow(). Обратите внимание, что WndClass консольного окна отличаются для Windows 95 и Window NT и заголовок окна может содержать полный путь под Windows NT.

Как получить длинное имя файла или каталога, зная короткое имя?

Используйте Win32_Find_Data поле TSearchRec.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. SearchRec : TSearchRec; Success : integer; Begin. Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', FaAnyFile, SearchRec); If Success = 0 then begin. ShowMessage(SearchRec.FindData.CFileName); End; SysUtils.FindClose(SearchRec); End;

©Drkb::03165.

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

Автор: P.O.D.

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); End; Function GetLongPathNameA(lpszShortPath, lpszLongPath: PChar; CchBuffer: DWORD): DWORD; stdcall; external kernel32; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function ExpandFileName(Path: String): String; Begin. SetLength(Result, MAX_PATH); If GetLongPathNameA(PChar(Path), @Result[1], MAX_PATH) = 0 then. RaiseLastOSError; Result := Trim(Result); End; Procedure TForm1.Button1Click(Sender: TObject); Var. S: String; Begin. // Получаем полное имя. S := ExpandFileName('C:\DOCUME~1\'); ShowMessage(S); // Получаем урезанное имя. GetShortPathName(PChar(S), PChar(S), MAX_PATH); ShowMessage(S); End; End.

©Drkb::03166.

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

Автор: Rouse_

Как получить иконку чужого окна

Code: { First Start Notepad.exe and run this code: } Procedure TForm1.Button1Click(Sender: TObject); Var. Hwindow : THandle; H: HIcon; Begin. Hwindow := FindWindow('notepad',nil); H := CopyIcon(GetClassLong(hwindow, GCL_HICON )); DrawIcon(Canvas.Handle, 30, 30, H); End;

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

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

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

Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage.

Как получить инфу о сервисе в ХР?

Code: //////////////////////////////////////////////////////////////////////////////// // // **************************************************************************** // * Project : Project1. // * Unit Name : Unit1. // * Purpose : Демо получения информации по сервисам. // * Author : Александр (Rouse_) Багель. // * Version : 1.00. // **************************************************************************** // Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, ExtCtrls, WinSvc; Type. TfrmMain = class(TForm). LvReport: TListView; RgServiceState: TRadioGroup; SbCount: TStatusBar; OpenDialog1: TOpenDialog; Procedure FormCreate(Sender: TObject); Procedure rgServiceStateClick(Sender: TObject); Private. Procedure EnumServices(const State: DWORD); End; Var. FrmMain: TfrmMain; Implementation. {$R *.dfm}. Procedure TfrmMain.EnumServices(const State: DWORD); Var. HSCObject, hService: SC_HANDLE; LpServices, TmpEnum: PEnumServiceStatus; LpServiceConfig: PQueryServiceConfig; I, cbBuffSize, pcbBytesNeeded, LpServicesReturned, lpResumeHandle: DWORD; Begin. LvReport.Items.BeginUpdate; Try. LvReport.Items.Clear; // Открываем менеджер сервисов. HSCObject := OpenSCManager(nil, nil, SC_MANAGER_ENUMERATE_SERVICE); If hSCObject <> 0 then. Try. LpResumeHandle := 0; LpServices := nil; // Смотрим сколько нужно памяти чтобы получить информацию. EnumServicesStatus(hSCObject, SERVICE_WIN32, State, LpServices^, 0, pcbBytesNeeded, lpServicesReturned, lpResumeHandle); If GetLastError = ERROR_MORE_DATA then. Begin. // Выделяем нужную память. GetMem(lpServices, pcbBytesNeeded); Try. CbBuffSize := pcbBytesNeeded; // Получаем требуемую информацию по установленным сервисам. If EnumServicesStatus(hSCObject, SERVICE_WIN32, State, LpServices^, cbBuffSize, pcbBytesNeeded, lpServicesReturned, lpResumeHandle) then. Begin. TmpEnum := lpServices; // Бежим в цикле по записям. For I := 0 to lpServicesReturned - 1 do. Begin. // Выводим данные на экран. With lvReport.Items.Add do. Begin. // Наименование сервиса. Caption := TmpEnum^.lpServiceName; // Описание сервиса. SubItems.Add(TmpEnum^.lpDisplayName); // Состояние. Case TmpEnum^.ServiceStatus.dwCurrentState of. SERVICE_RUNNING: SubItems.Add('Работает'); SERVICE_STOPPED: SubItems.Add('Остановлен'); Else. SubItems.Add('Неизвестно'); End; // Для дополнительной информаци по сервису получаем описатель сервиса. HService := OpenService(hSCObject, TmpEnum^.lpServiceName, SERVICE_QUERY_CONFIG); If hService <> 0 then. Try. // Смотрим сколько нужно памяти. QueryServiceConfig(hService, nil, 0, pcbBytesNeeded); If GetLastError = ERROR_INSUFFICIENT_BUFFER then. Begin. CbBuffSize := pcbBytesNeeded; // Берем память. GetMem(lpServiceConfig, pcbBytesNeeded); Try. // Получаем расширенную информацию по сервису. If QueryServiceConfig(hService, lpServiceConfig, CbBuffSize, pcbBytesNeeded) then. Begin. // Путь к сервису. SubItems.Add(lpServiceConfig^.lpBinaryPathName); // Доступ к рабочему столу. If (lpServiceConfig^.dwServiceType and SERVICE_INTERACTIVE_PROCESS) = SERVICE_INTERACTIVE_PROCESS then. Begin. SubItems.Add('Да'); LpServiceConfig^.dwServiceType := LpServiceConfig^.dwServiceType - SERVICE_INTERACTIVE_PROCESS; End. Else. SubItems.Add('Нет'); // Тип сервиса. Case lpServiceConfig^.dwServiceType of. SERVICE_WIN32_OWN_PROCESS: SubItems.Add('Одиночный'); SERVICE_WIN32_SHARE_PROCESS: SubItems.Add('Не одиночный'); Else. SubItems.Add('Неизвестный тип службы'); End; // Группа. SubItems.Add(lpServiceConfig^.lpLoadOrderGroup); // Тип запуска. Case lpServiceConfig^.dwStartType of. SERVICE_AUTO_START: SubItems.Add('Автоматический'); SERVICE_DEMAND_START: SubItems.Add('Вручную'); SERVICE_DISABLED: SubItems.Add('Отключен'); End; End; // Завершающее освобождение памяти. Finally. FreeMem(lpServiceConfig); End; End; Finally. CloseServiceHandle(hService); End; End; Inc(TmpEnum); End; End; Finally. FreeMem(lpServices); End; End; Finally. CloseServiceHandle(hSCObject); End; Finally. LvReport.Items.EndUpdate; SbCount.Panels.Items[0].Text := ' Общее количество: ' + IntToStr(lvReport.Items.Count); End; End; Procedure TfrmMain.FormCreate(Sender: TObject); Begin. RgServiceState.OnClick(nil); End; Procedure TfrmMain.rgServiceStateClick(Sender: TObject); Begin. // В зависимости от выбранного RadioItem перечисляем - // все сервисы, только активные или неактивные. If rgServiceState.ItemIndex = 0 then. EnumServices(SERVICE_STATE_ALL). Else. EnumServices(rgServiceState.ItemIndex); End; End.

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

Автор: Rouse_

Как получить имя программы, с которой ассоциировано то или иное расширение

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

Code: Uses. {$IFDEF WIN32}. Registry; {We will get it from the registry}. {$ELSE}. IniFiles; {We will get it from the win.ini file}. {$ENDIF}. {$IFNDEF WIN32}. Const. MAX_PATH = 144; {$ENDIF}. Function GetProgramAssociation(Ext: string): string; Var. {$IFDEF WIN32}. Reg: TRegistry; S: string; {$ELSE}. WinIni: TIniFile; WinIniFileName: array[0..MAX_PATH] of char; S: string; {$ENDIF}. Begin. {$IFDEF WIN32}. S := ''; Reg := TRegistry.Create; Reg.RootKey := HKEY_CLASSES_ROOT; If reg.OpenKey('.' + ext + '\shell\open\command', False) <> false then. Begin. {The open command has been found}. S := reg.ReadString(''); Reg.CloseKey; End. Else. Begin. {perhaps thier is a system file pointer}. If reg.OpenKey('.' + ext, False) <> false then. Begin. S := reg.ReadString(''); Reg.CloseKey; If s <> '' then. Begin. {A system file pointer was found}. If reg.OpenKey(s + '\shell\open\command', False) <> false then. {The open command has been found}. S := reg.ReadString(''); Reg.CloseKey; End; End; End; {Delete any command line, quotes and spaces}. If Pos('%', s) > 0 then. Delete(s, Pos('%', s), length(s)); If ((length(s) > 0) and. (s[1] = '"')) then. Delete(s, 1, 1); If ((length(s) > 0) and. (s[length(s)] = '"')) then. Delete(s, Length(s), 1); While ((length(s) > 0) and. ((s[length(s)] = #32) or. (s[length(s)] = '"'))) do. Delete(s, Length(s), 1); {$ELSE}. GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); S := WinIni.ReadString('Extensions', Ext, ''); WinIni.Free; {Delete any command line}. If Pos(' ^', s) > 0 then. Delete(s, Pos(' ^', s), length(s)); {$ENDIF}. Result := s; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. ShowMessage(GetProgramAssociation('gif')); End;

Как получить Handle рабочего стола

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

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

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Обратная связь от MSSQL-сервера к клиенту. На форуме постоянно возникает вопрос - "Как получить обновление данных, по событию, а не таймером", чтобы снять его раз и навсегда привожу код dll-ки, которая является Extended Stored Procedure с единственной функцией - отправкой UDP-broadcast сообщения. Зависимости: Windows, SysUtils, IdUDPClient. Автор: Delirium, VideoDVD@hotmail.com, ICQ:118395746, Москва. Copyright: Delirium (Master BRAIN) 2003. Дата: 24 октября 2003 г. ********************************************** } Library Messager; Uses. Windows, SysUtils, IdUDPClient; Function srv_rpcparams(srvproc:Pointer):integer; cdecl; external 'opends60.dll' name 'srv_rpcparams'; Function srv_paramdata(srvproc:Pointer; n:integer):integer; cdecl; external 'opends60.dll' name 'srv_paramdata'; Function srv_paramlen(srvproc:Pointer; n:integer):integer; cdecl; external 'opends60.dll' name 'srv_paramlen'; Procedure SendUDPMessage(Params:Pointer); stdcall; cdecl; export; Var id:TIdUDPClient; Msg:String; Host,Port:String; Begin. Try. If srv_rpcparams(Params)<2 then exit; Host:=Copy(PChar(srv_paramdata(Params,1)), 1, srv_paramlen(Params,1)); Port:=Copy(Host,Pos(':',Host)+1,Length(Host)); Delete(Host,Pos(':',Host),Length(Host)); Msg:=Copy(PChar(srv_paramdata(Params,2)), 1, srv_paramlen(Params,2)); Id:=TIdUDPClient.Create(nil); Id.BroadcastEnabled:=True; Id.Host:=Host; Id.Port:=StrToInt(Port); Id.ReceiveTimeout:=-1; Id.Send(Msg); Id.Free; Except end; End; Exports SendUDPMessage; Begin. End.

Для регистрации на MSSQL скопировать dll в.

C:\Program Files\Microsoft SQL Server\80\Tools\Binn.

И исполнить скрипт.

Sp_addextendedproc 'SendUDPMessage', 'Messager.dll'

На клиенте рекомендую использовать компонент TIdUDPServer.

Передача сообщений осуществляется так.

Как поменять цвет Неаdеr'а в TListView.

Как поменять цвет Header'а в TListView.

Для этого нужно в оконной процедуре ListView обработать сообщение WM_NOTIFY с кодом NM_CUSTOMDRAW. И в обработчике этого сообщения назначить цвета фона и текста (можно назначить и шрифт). Но при этом правая часть header'а (область заголовка ListView, находящаяся справа от колонок) закрашиваться не будет. Чтобы закрасить и её, надо в оконной процедуре header'а обработать сообщение WM_ERASEBKGND, в котором и залить нужным цветом эту область. Ниже - небольшой примерчик с сабклассингом.

Code: Uses CommCtrl; Var. BkBrush:HBRUSH; // тут сохраняем brush для фона. // процедура hеаdеr'а. Function NewHeaderProc(wnd: HWND; Msg: Cardinal; wParam: wParam; LParam: lParam): Longint; stdcall; Var. BrushOld: HBRUSH; ClientRect:TRect; Begin. Result := CallWindowProc(Pointer(GetWindowLong(wnd, GWL_USERDATA)), Wnd, Msg, wParam, lParam); If Msg=WM_ERASEBKGND then // закрашиваем область справа от колонок. Begin. GetClientRect(wnd,ClientRect); BrushOld := SelectObject(wParam, BkBrush); FillRect(wParam, ClientRect, BkBrush); SelectObject(wParam, BrushOld); Result := 1; End. End; // процедура ListView. Function NewListProc(wnd:HWND; uMsg:UINT; wParam:WPARAM; LParam:LPARAM):integer; stdcall; Var. Nmlvcd:PNMLVCUSTOMDRAW; Begin. Result:=CallWindowProc(Pointer(GetWindowLong(wnd,GWL_USERDATA)),wnd, UMsg,wParam,lParam); If uMsg=WM_NOTIFY then. If PNMLISTVIEW(lParam)^.hdr.code=NM_CUSTOMDRAW then. Begin. Nmlvcd:=PNMLVCUSTOMDRAW(lparam); Case nmlvcd.nmcd.dwDrawStage of. CDDS_PREPAINT: result:=CDRF_NOTIFYITEMDRAW; CDDS_ITEMPREPAINT: Begin. SetTextColor(nmlvcd.nmcd.hdc,clRed); // цвет текста. SetBkColor(nmlvcd.nmcd.hdc,clYellow); // цвет фона. Result:=CDRF_DODEFAULT; End; CDDS_ITEMPOSTPAINT: result := CDRF_DODEFAULT; End. End; End; Procedure TForm1.FormCreate(Sender: TObject); Var. I,j:integer; Lit:TListItem; Begin. With ListView1 do. Begin. ViewStyle := vsReport; // стиль, естественно vsReport. GridLines:=true; // заполним ListView чем-нибудь. For i:=0 to 2 do. Begin. Columns.Add.Caption:='Column'+IntToStr(i); Columns[i].Width:=70; Lit:=Items.Add; Lit.Caption:='Item'+IntToStr(i); For j:=1 to 2 do lit.SubItems.Add('SubItem'+IntToStr(j)+IntToStr(i)). End. End; //меняем процедуру у ListView. SetWindowLong(ListView1.Handle,GWL_USERDATA,SetWindowLong(ListView1.Handle, GWL_WNDPROC, LPARAM(@NewListProc))); //тоже самое у Неаdеr'а. SetWindowLong(GetWindow(ListView1.Handle, GW_CHILD),GWL_USERDATA, SetWindowLong(GetWindow(ListView1.Handle, GW_CHILD), GWL_WNDPROC, LPARAM(@NewHeaderProc))); BkBrush := CreateSolidBrush(clYellow); // цвет фона. End;

Ещё вариант: для каждого элемента header'а установить флаг HDF_OWNERDRAW и в оконной процедуре ListView обрабатывать WM_DRAWITEM, где так же назначать цвета для элементов заголовка ListView.

Автор: Krid.

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

©Drkb::00635.

Как поменять цвет фона в RichEdit.

Code: Uses. RichEdit; Procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor); Var. Format: CHARFORMAT2; Begin. FillChar(Format, SizeOf(Format), 0); With Format do. Begin. CbSize := SizeOf(Format); DwMask := CFM_BACKCOLOR; CrBackColor := AColor; Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format)); End; End; // Example: Set clYellow background color for the selected text. Procedure TForm1.Button1Click(Sender: TObject); Begin. RE_SetSelBgColor(RichEdit1, clYellow); End;

Как поменять установки на case-sensitive у сервера.

Как поменять установки на case-sensitive у сервера

Rebuild Master Utility, она же Binn\rebuildm.exe. Если память не подводит, то схема такая: backup всех баз -> shutdown -> rebuild -> startup -> restore.

Guderian (Sources.ru).

©Drkb::02863.

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

Представим, что данные находятся в массиве:

Как поместить прозрачный текст на Canvas TBitmap.

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

Как послать файл на принтер?

Code: Uses winspool; Const. GenericPrinter: Pchar = 'Universal/Nur Text'; // Change to systems generic drivers name, it's localized. Procedure PrintLineToGeneric(Const line: string ); Var. BytesWritten: DWORD; HPrinter: THandle; DocInfo: TDocInfo1; Begin. If not WinSpool.OpenPrinter(GenericPrinter, hPrinter, nil) Then. Raise exception.create('Printer not found'); Try. DocInfo.pDocName := 'MyDocument'; DocInfo.pOutputFile := Nil; DocInfo.pDatatype := 'RAW'; If StartDocPrinter(hPrinter, 1, @DocInfo) = 0 Then. Abort; Try. If not StartPagePrinter(hPrinter) Then. Abort; Try. If not WritePrinter(hPrinter, @line[1], Length(line), BytesWritten). Then. Abort; Finally. EndPagePrinter(hPrinter); End; Finally. EndDocPrinter(hPrinter); End; Finally. WinSpool.ClosePrinter(hPrinter); End; End;

©Drkb::03258.

Как поставить свой формат в TDateTimePicker?

Code: Uses CommCtrl; Const fmt: PChar = 'hh:mm'; SendMessage(DateTimePicker1.Handle, DTM_SETFORMAT, 0, LongInt(fmt));

©Drkb::01323.

Как по PID процесса узнать CMDLINE?, то есть командную строку.

Как по PID процесса узнать CMDLINE?, то есть командную строку

Code: Function GetProcessCmdLine(PID:DWORD):string; {©Drkb v.3(2007): www.drkb.ru}. Var. H:THandle; Pbi:TProcessBacicInformation; Ret:NTSTATUS; R:Cardinal; Ws:WideString; Begin. Result:=''; If pid=0 then exit; H:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, pid); If h=0 then exit; Try. Ret:=NtQueryInformationProcess(h,ProcessBasicInformation,@pbi,sizeof(pbi),@r); If ret=STATUS_SUCCESS then. If ReadProcessMemory(h,pbi.PebBaseAddress.ProcessParameters.CommandLine.Buffer,PWideChar(ws), Pbi.PebBaseAddress.ProcessParameters.CommandLine.Length,r) then. Result:=string(ws); Finally. Closehandle(h). End. End;

Автор: Krid.

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

©Drkb::02134.

Как отбрасывать тень от текста.

Как отбрасывать тень от текста

Вот ещё одну функцию обнаружил DrawShadowText(...), которая позволяет отбрасывать тень от текста на hdc контексте. Большой минус состоит в том, что она появилась только в XP. Чтобы пример заработал, нужно в системной директории найти новую версию библиотеки comctl32.dll и скопировать её в папку с примером. У меня эта библиотека лежала в папке C:\WINDOWS\WinSxS\x86_Microsoft.Windows.Common-Controls_6595b64144ccf1df_6.0.0.0_x-ww_1382d70a.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls; Type. TShadowText = function (dc : HDC; PszText : PWideChar; Cch : DWORD; Prc : PRECT; DwFlags : DWORD; CrText : TColor; CrShadow : TColor; IxOffset : integer; IyOffset : integer):integer;stdcall; Type. TForm1 = class(TForm). Image1: TImage; TB_PosX: TTrackBar; TB_PosY: TTrackBar; Label1: TLabel; Label2: TLabel; Procedure TB_PosXChange(Sender: TObject); Procedure TB_PosYChange(Sender: TObject); Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. Lib : THandle; DrawShadowText: TShadowText; Procedure ShadowText; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Begin. Lib:=LoadLibrary(PChar(GetCurrentDir+'\comctl32.dll')); If lib=0 then. Begin. MessageBox(Handle, 'Библиотеки нет...', '!', MB_OK or MB_ICONERROR); Exit; End; @DrawShadowText:=GetProcAddress(lib, 'DrawShadowText'); If @DrawShadowText=nil then. Begin. FreeLibrary(lib); MessageBox(Handle, 'Функции нет... не та библиотека!', '!', MB_OK or MB_ICONERROR); Exit; End; ShadowText; End; Procedure TForm1.ShadowText; Var. Rect : TRECT; Text : PWChar; Begin. If @DrawShadowText=nil then exit; Text:='forum.sources.ru'+#13+'самый лучший форум'; Image1.Canvas.Brush.Color:=clWhite; Image1.Canvas.FillRect(Image1.ClientRect); Rect.Left:=Image1.Width div 10; Rect.Top:=Image1.Height div 4; Rect.Right:=Image1.Width; Rect.Bottom:=Image1.Height; Image1.Canvas.Font.Size:=20; Image1.Canvas.Font.Style:=Image1.Canvas.Font.Style+[fsBold]; Image1.Canvas.Font.Name:='Times New Roman'; DrawShadowText(Image1.Canvas.Handle, Text, Length(text), @rect, 1, //-> центрировать текст. ClRed, ClBlack, TB_PosX.Position, TB_PosY.Position); End; Procedure TForm1.TB_PosXChange(Sender: TObject); Begin. ShadowText(); End; Procedure TForm1.TB_PosYChange(Sender: TObject); Begin. ShadowText(); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. If lib<>0 then FreeLibrary(lib); End; End.

Автор: Deni.

©Drkb::03746.

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

Как отключать стили XP для отдельных контролов?

Темы должны быть включены и манифест лежать на форме:

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, XPMan; Type. TForm1 = class(TForm). Button1: TButton; Button2: TButton; Button3: TButton; Button4: TButton; Button5: TButton; XPManifest1: TXPManifest; Procedure FormCreate(Sender: TObject); Private. Procedure Unload2Themes(var M:TMSG); message WM_USER+1; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function SetWindowTheme(hwnd: HWND; pszSubAppName: LPCWSTR; PszSubIdList: LPCWSTR): HRESULT; stdcall; external 'uxtheme.dll'; Procedure TForm1.Unload2Themes(var M: TMSG); Begin. SetWindowTheme(Button4.Handle, ' ', ' '); SetWindowTheme(Button5.Handle, ' ', ' '); SetWindowTheme(Form1.Handle, ' ', ' '); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. PostMessage(Handle,WM_USER+1,0,0). End; End.

Автор: Krid.

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

©Drkb::00402.

Как отключить комбинацию Alt+Tab.

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

Как отключить курсор мыши

Code: //Выключение курсора. Procedure TForm1.Button1Click(Sender: TObject); Var. CState: Integer; Begin. CState := ShowCursor(True); While Cstate >= 0 do. Cstate := ShowCursor(False); End; //Включение курсора. Procedure TForm1.Button2Click(Sender: TObject); Var. Cstate: Integer; Begin. Cstate := ShowCursor(True); While CState < 0 do. CState := ShowCursor(True); End;

©Drkb::02336.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как отличить нажат правый или левый CTRL?

Для того, чтобы отличить нажат левый или правый Ctrl, нужно перехватить событие WM_KEYDOWN. В зависимости от состояния 24-ого бита параметра LParam нажата правая или левая клавиша.

Как отловить правый Enter (NumPad).

Для этого можно воспользоваться функцией GetHeapStatus:

Как открыть индексированную таблицу dBase, если отсутствует файл индекса

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

Для этого в заголовок файла dbf по смещению 28(dec) записываешь 0.

По другому никак не выходит(я долго бился)- вот для Paradox таблиц все Ok.

С помощью BDE Callbacks. Пpимеp для Delphi 2.0, на пеpвом не пpовеpял:

Code: Unit Callback; Interface. Uses BDE, Classes, Forms, DB, DBTables; Type. TForm1 = class(TForm). Table1: TTable; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. CBack: TBDECallback; // определение BDE CallBack. CBBuf: CBInputDesc; // просто буфер. Function CBFunc(CBInfo: Pointer): CBRType; // Callback-функция. Public. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. Session.Open; // В это время сессия ещ? не открыта. CBack := TBDECallback.Create(Session {Например}, nil, cbINPUTREQ, @CBRegBuf, SizeOf(CBBuf), CBFunc, False); // Определили Callback. Table1.Open; //^^^^^^^^^^^ - здесь возможна ошибка с индексом, etc. End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. CBack.Free; // Освобождаем CallBack. End; Function TForm1.CBFunc(CBInfo: Pointer): CBRType; Begin. With PCBInputDesc(CBInfo)^ do. Case eCbInputId of. CbiMDXMissing {, cbiDBTMissing - можно ещ? и очищать BLOB-поля}: Begin. ISelection := 3; // Номер варианта ответа (1-й - открыть только. // для чтения, 2-й - не открывать, 3-й - отсоединить индекс). // Возможный источник неприятностей: а вдруг в последующих версиях. // BDE номера будут другими? Result := cbrCHKINPUT; // Обрабатывать введ?нный ответ. End; End; End; End.

Как отобразить не главные окна своей программы в панели задач Windows.

Code: Procedure TMyForm.CreateParams(var Params :TCreateParams); {override;}. Begin. Inherited CreateParams(Params); {CreateWindowEx}. Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow; End;

©Drkb::01785.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как отобразить модально MDIChild форму

Как выполнить код после создания MDIChild-формы но до появления ее на экране? Как отобразить MDIChild-форму модально?

1.Убераешь свою MDIChild форму из автосоздания: (MainMenu) Project->Options->Forms. Там её перебрасываешь в: Available forms.

Как пpогpаммно вывести окно свойств экpана

Автор: Nomadic.

Code: ShellExecute(Application.Handle, 'open', 'desk.cpl', nil, nil, sw_ShowNormal);

©Drkb::01840.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Как ListView перевести в режим редактирования по нажатию на F2.

Code: Procedure TForm1.ListView1KeyDown(Sender: TObject; Var Key: Word; Shift: TShiftState); Begin. If Ord(Key) = VK_F2 then. ListView1.Selected.EditCaption; End;

©Drkb::01133.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

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

Code: Function IconsAreEqual(const Icon1, Icon2: TIcon): Boolean; Var. Ms1: TMemoryStream; Ms2: TMemoryStream; Begin. Result := False; Ms1 := TMemoryStream.Create; Try. Icon1.SaveToStream(ms1); Ms2 := TMemoryStream.Create; Try. Icon2.SaveToStream(ms2); If ms1.Size = ms2.Size then. // Compare the streams, Streams vergleichen: Result := CompareMem(ms1.Memory, ms2.Memory, ms1.Size). Finally. Ms2.Free. End. Finally. Ms1.Free. End. End; Procedure TForm1.Button1Click(Sender: TObject); Var. Icon1: TIcon; Icon2: TIcon; Begin. Icon1 := TIcon.Create; Icon2 := TIcon.Create; Try. Icon1.LoadFromFile('c:\Icon1.ico'); Icon2.LoadFromFile('c:\Icon2.ico'); If IconsAreEqual(icon1, icon2) then. ShowMessage('Icon 1 and Icon 2 match'). Else. ShowMessage('Icon 1 and Icon 2 do not match'); Finally. Icon1.Free; Icon2.Free; End; End;

Как сравнить Bookmarks в таблице?

Code: Function TBDEDirect.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Boolean; Var. Res: DBIResult; CompareRes: Word; Begin. Result := False; If CheckDatabase then. Begin. Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle, Bookmark1, Bookmark2, CompareRes); If Res = 0 then. If CompareRes = 0 then. Result := True. Else. Else. Check(Res); End; End;

Как сделать ADO-connection.

Code: Uses. ComObj; Function OpenConnection(ConnectionString: AnsiString): Integer; Var. ADODBConnection: OleVariant; Begin. ADODBConnection := CreateOleObject('ADODB.Connection'); ADODBConnection.CursorLocation := 3; // User client. ADODBConnection.ConnectionString := ConnectionString; Result := 0; Try. ADODBConnection.Open; Except. Result := -1; End; End; Function DataBaseConnection_Test(bMessage: Boolean): AnsiString; Var. AsTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString; IReturn: Integer; OldCursor: TCursor; Begin. OldCursor := Screen.Cursor; Screen.Cursor := crHourGlass; AsTimeout := '150'; AsUserName := 'NT_Server'; AsPassword := 'SA'; AsDataSource := 'SQL Server - My DataBase'; ConnectionString := 'Data Source = ' + asDataSource + 'User ID = ' + asUserName + 'Password = ' + asPassword + 'Mode = Read|Write;Connect Timeout = ' + asTimeout; Try. IReturn := OpenConnection(ConnectionString); If (bMessage) then. Begin. If (iReturn = 0) then. Application.MessageBox('Connection OK!', 'Information', MB_OK). Else if (iReturn = -1) then. Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK); End; If (iReturn = 0) then. Result := ConnectionString. Else if (iReturn = -1) then. Result := ''; Finally. Screen.Cursor := OldCursor; End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. DataBaseConnection_Test(True); End;

Как сделать картинки в TImageList прозрачными

Procedure TForm1.Button1Click(Sender: TObject);

Var.

Bm : TBitmap;

Il : TImageList;

Begin.

Bm := TBitmap.Create;

Bm.LoadFromFile('C:\DownLoad\TEST.BMP');

Il := TImageList.CreateSize(bm.Width,bm.Height);

Il.DrawingStyle := dsTransparent;

Il.Masked := true;

Il.AddMasked(bm, clRed);

Il.Draw(Form1.Canvas, 0, 0, 0);

Bm.Free;

Il.Free;

End;

Как сделать клавишу-акселератор (keyboard shortcut) компонету, у которого нет заголовка

Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонент TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, переведите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo.

Как сделать родительское окно с фоновым рисунком в клиентской области?

Для того чтобы сделать это выполните следующие шаги:

Создайте новый проект.

Установите FormStyle формы в fsMDIForm.

Разместите Image на форме и загрузите в него картинку.

Найдите { Private Declarations } в объявлении формы и добавьте следующие строки:

Как сделать окошко подсказки в редакторе как Delphi по CTRL-J.

Автор: Hog.

Как сделать прозрачным фон текста

Используйте функцию SetBkMode():

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

Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.

Как сделать, чтобы неглавная форма минимизировалась не на TaskBar, а выше него

Code: Void __fastcall CreateParams(TCreateParams &Params); ... Void __fastcall TForm1::CreateParams(TCreateParams &Params). { TForm::CreateParams(Params); Params.ExStyle |= WS_EX_APPWINDOW; Params.WndParent = GetDesktopWindow(); }

Как сделать форму активной, Форма находится в DLL.

Code: Procedure ShowMainForm; {©Drkb v.3(2007): www.drkb.ru}. Var. HWnd, hCurWnd, dwThreadID, dwCurThreadID: THandle; OldTimeOut: DWORD; AResult: Boolean; Begin. ShowWindow(Application.Handle, SW_RESTORE); Application.MainForm.Visible := True; // Показываем главную форму. // Ставим нашу форму впереди всех окон. HWnd := Application.Handle; SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @OldTimeOut, 0); SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, Pointer(0), 0); SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); HCurWnd := GetForegroundWindow; AResult := False; While not AResult do. Begin. DwThreadID := GetCurrentThreadId; DwCurThreadID := GetWindowThreadProcessId(hCurWnd); AttachThreadInput(dwThreadID, dwCurThreadID, True); AResult := SetForegroundWindow(hWnd); AttachThreadInput(dwThreadID, dwCurThreadID, False); End; SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, Pointer(OldTimeOut), 0); End;

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

Автор: Rouse_

©Drkb::00444.

Как сделать ProgressBar таким же, как на заставке Windows XP.

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, XPMan, ComCtrls, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; ProgressBar1: TProgressBar; Button2: TButton; Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Const. PBS_MARQUEE = $08; PBM_SETMARQUEE = WM_USER + 10; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. FSpeed: Integer; Begin. FSpeed := 100; SetWindowLong(ProgressBar1.Handle, GWL_STYLE, GetWindowLong(ProgressBar1.Handle, GWL_STYLE) Or PBS_MARQUEE); { Включить }. SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 1, FSpeed); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. { Выключить }. SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 0, 0); End; End.

Как самому определить метод сортировки TStringList.

Code: { Suppose you have a TListBox containing some date values. If you want to sort the dates by setting the "Sorted". Property to "True" you will see that the dates are not sorted correctly: 12.03.2003. 13.03.2003. 29.01.2003. 30.03.2003. Now what you can do is to is create a TStringlist, Assign the listbox.Items. Property to it, sort the stringlist using CustomSort, Then Assign it back to listbox.items. } Function CompareDates(List: TStringList; Index1, Index2: Integer): Integer; Var. D1, d2: TDateTime; Begin. D1 := StrToDate(List[Index1]); D2 := StrToDate(List[Index2]); If d1 < d2 then. Result := -1. Else if d1 > d2 then Result := 1. Else. Result := 0; End; Procedure TForm1.Button1Click(Sender: TObject); Var. Sl: TStringList; Begin. Sl := TStringList.Create; Try. // listbox1.Sorted := False ! Sl.Assign(listbox1.Items); Sl.CustomSort(CompareDates); Listbox1.Items.Assign(sl); Finally. Sl.Free. End; End; End. {********************************************************************} { To sort Integer values:}. Function CompareInt(List: TStringList; Index1, Index2: Integer): Integer; Var. D1, d2: Integer; R1, r2: Boolean; Function IsInt(AString : string; var AInteger : Integer): Boolean; Var. Code: Integer; Begin. Val(AString, AInteger, Code); Result := (Code = 0); End; Begin. R1 := IsInt(List[Index1], d1); R2 := IsInt(List[Index2], d2); Result := ord(r1 or r2); If Result <> 0 then. Begin. If d1 < d2 then. Result := -1. Else if d1 > d2 then. Result := 1. Else. Result := 0; End else. Result := lstrcmp(PChar(List[Index1]), PChar(List[Index2])); End; Procedure TForm1.Button1Click(Sender: TObject); Var. Sl: TStringList; Begin. Sl := TStringList.Create; Try. // listbox1.Sorted := False; Sl.Assign(listbox1.Items); Sl.CustomSort(CompareInt); Listbox1.Items.Assign(sl); Finally. Sl.Free; End; End;

Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?

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

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

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

Автор: Nomadic.

Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки.

Здесь немного исправленный пример из этой книги -

Code: Function TMyClass.CreateCalcField(const AFieldName: string; AFieldClass: TFieldClass; ASize: Word): TField; Begin. Result := FDataSet.FindField(AFieldName); // Field may already exists! If Result <> nil then. Exit; If AFieldClass = nil then. Begin. DBErrorFmt(SUnknownFieldType, [AFieldName]); End; Result := FieldClass.Create(Owner); With Result do. Try. FieldName := AFieldName; If (Result is TStringField) or (Result is TBCDField) or. (Result is TBlobField) or (Result is TBytesField) or. (Result is TVarBytesField) then. Begin. Size := ASize; End; Calculated := True; DataSet := FDataset; Name := FDataSet.Name + AFieldName; Except. Free; // We must release allocated memory on error! Raise; End; End;

©Drkb::02621.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

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

Code: Uses. Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls; Type. TForm1 = class(TForm). Table1: TTable; // DBDemos customer table. Table2: TTable; // DBDemos orders table. Button1: TButton; DBLookupComboBox1: TDBLookupComboBox; DataSource1: TDataSource; Table2CustNo: TFloatField; // CustNo key field object used for Lookup. Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.Button1Click(Sender: TObject); Begin. With TStringField.Create(Table2) do. Begin. FieldName := 'MyLookup'; FieldKind:= fkLookup; DataSet := Table2; Name := Dataset.name + FieldName; KeyFields:= 'CustNo'; LookUpDataset:= Table1; LookUpKeyFields:= 'CustNo'; LookUpResultField:= 'Company'; DbLookupCombobox1.DataField:= FieldName; DataSource1.DataSet:= Dataset; Table2.FieldDefs.Add(name, ftString, 20, false); End; DbLookupCombobox1.DataSource:= Datasource1; Table1.Active:= True; Table2.Active:= True; End; End.

Как создать собственное Hint-окно

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

Как создать таблицу в Word'е?

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

Как создать таблицу в Word'е? Так же просто, как это делается в обычном объектно-ориентированном языке. В объекте Document мы имеем коллекцию Tables, с помощью методов и объектов которой можем создать таблицу и получить доступ к ее свойствам, ячейкам и тексту в ячейках. Если в нашем отчете несколько таблиц, то к любой из них мы имеем доступ с помощью коллекции Tables и индекса таблицы.

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

Определим функцию создания таблицы CreateTable. Так как количество таблиц в документе может быть больше одной, то для идентификации каждой таблицы используем ее номер. Для создания применим метод ADD коллекции Tables. Метод ADD имеет аргументы: область, где создается таблица, количество строк и количество столбцов. Наша функция будет создавать таблицу там, где расположен курсор, и иметь еще один аргумент: числовую переменную, через которую будет возвращаться порядковое значение(индекс) таблицы в документе. Функция выглядит следующим образом:

Code: Function CreateTable(NumRows, NumColumns:integer; Var index:integer):boolean; Var sel_:variant; Begin. CreateTable:=true; Try. Sel_:=W.selection; W.ActiveDocument.Tables.Add (Range:=sel_.Range,NumRows: =NumRows, NumColumns:=NumColumns); Index:=W.ActiveDocument. Tables.Count; Except. CreateTable:=false; End; End;

Как сохранить иконку в файл имея её хендл?

Code: Uses. Windows,ActiveX; {©Drkb v.3(2007): www.drkb.ru}. Function OleSavePictureFile(dispPicture: IDispatch; bstrFileName: TBStr): HResult; stdcall; External 'oleaut32.dll'; // icon - дескриптор иконки. // FileName - файл, в который сохранять. // DestroyAfterSave - уничтожать дескриптор иконки после сохранения или нет. Function StoreIconFile(icon:HICON; FileName:string; DestroyAfterSave:boolean=false):boolean; Const. IID_IPictureDisp:TGUID = '{7BF80981-BF32-101A-8BBB-00AA00300CAB}'; Var. Pd:TPictDesc; Ipd:IPictureDisp; Begin. Pd.cbSizeofstruct:=sizeof(TPictDesc); Pd.picType:=PICTYPE_ICON; Pd.hIcon:=icon; Result:=(OleCreatePictureIndirect(pd,IID_IPictureDisp,DestroyAfterSave,ipd)=S_OK) and. (OleSavePictureFile(ipd, StringToOLEStr(FileName))=S_OK). End;

©Drkb::02351.

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

Автор: Krid.

Как сохранить содержимое TPaintBox в BMP.

Code: Var. Bitmap: TBitmap; Source: TRect; Dest: TRect; Begin. Bitmap := TBitmap.Create; Try. With Bitmap do. Begin. Width := MyPaintBox.Width; Height := MyPaintBox.Height; Dest := Rect(0, 0, Width, Height); End; With MyPaintBox do. Source := Rect(0, 0, Width, Height); Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source); Bitmap.SaveToFile('MYFILE.BMP'); Finally. Bitmap.Free; End; End;

Как спрятать и отключить кнопку "Пуск"?

Приведенный пример прячет и показывает кнопку "Пуск", а также разрешает и запрещает ее.

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Rgn : hRgn; Begin. {Спрятать кнопку "Пуск"}. Rgn := CreateRectRgn(0, 0, 0, 0); SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', Nil), Rgn, True); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. {Показать кнопку "Пуск"}. SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', Nil), 0, True); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. {Запретить кнопку "Пуск"}. EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', Nil), False); End; Procedure TForm1.Button4Click(Sender: TObject); Begin. {Разрешить кнопку "Пуск"}. EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', Nil), True); End.

©Drkb::01797.

Сохранение изображения экрана в файле

На форме у меня стоит TImage (его можно сделать невидимым).

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

Code: { If you have installed the Internet Explorer 4.0 or high, in TTreeView component. Always displaying a hint for cutted items. It's useful but sometimes prevents and. Irritates (at least, me). But there is a simple way to switch off this feature: } Procedure TForm1.FormShow(Sender: TObject); Const. TVS_NOTOOLTIPS = $0080; Begin. SetWindowLong(Treeview1.Handle, GWL_STYLE, GetWindowLong(TreeView1.Handle, GWL_STYLE) xor TVS_NOTOOLTIPS); End;

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

Как текст на кнопке расположить под заданным углом

Как выдать текст под наклоном?

Как узнать размер файла в интернете?

Code: Uses wininet; ... Function GetUrlSize(const URL:string):integer;//результат в байтах. Var. HSession,hFile:hInternet; DwBuffer:array[1..20] of char; DwBufferLen,dwIndex:DWORD; Begin. Result:=0; HSession:=InternetOpen('GetUrlSize',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0); If Assigned(hSession) then begin. HFile:=InternetOpenURL(hSession,PChar(URL),nil,0,INTERNET_FLAG_RELOAD,0); DwIndex:=0; DwBufferLen:=20; If HttpQueryInfo(hFile,HTTP_QUERY_CONTENT_LENGTH,@dwBuffer,dwBufferLen,dwIndex) then Result:=StrToInt(StrPas(@dwBuffer)); If Assigned(hFile) then InternetCloseHandle(hFile); InternetCloseHandle(hsession); End; End;

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

Автор: P.O.D.

©Drkb::03582.

Как узнать все открытые дескрипторы файлов?

Code: //////////////////////////////////////////////////////////////////////////////// // // **************************************************************************** // * Unit Name : Unit15. // * Purpose : Перечисление всех открытых файлов в системе. // * (до которых получилось достучаться). // * Author : Александр (Rouse_) Багель. // * Version : 1.00. // **************************************************************************** // {©Drkb v.3(2007): www.drkb.ru}. Unit Unit15; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls; Type. TForm15 = class(TForm). Button1: TButton; Memo1: TMemo; ProgressBar1: TProgressBar; Procedure Button1Click(Sender: TObject); Public. Procedure ShowLockedProcess(FileName: String); End; Var. Form15: TForm15; Implementation. {$R *.dfm}. Type. NT_STATUS = Cardinal; TFileDirectoryInformation = packed record. NextEntryOffset: ULONG; FileIndex: ULONG; CreationTime: LARGE_INTEGER; LastAccessTime: LARGE_INTEGER; LastWriteTime: LARGE_INTEGER; ChangeTime: LARGE_INTEGER; EndOfFile: LARGE_INTEGER; AllocationSize: LARGE_INTEGER; FileAttributes: ULONG; FileNameLength: ULONG; FileName: array[0..0] of WideChar; End; FILE_DIRECTORY_INFORMATION = TFileDirectoryInformation; PFileDirectoryInformation = ^TFileDirectoryInformation; PFILE_DIRECTORY_INFORMATION = PFileDirectoryInformation; PSYSTEM_THREADS = ^SYSTEM_THREADS; SYSTEM_THREADS = packed record. KernelTime: LARGE_INTEGER; UserTime: LARGE_INTEGER; CreateTime: LARGE_INTEGER; WaitTime: ULONG; StartAddress: Pointer; UniqueProcess: DWORD; UniqueThread: DWORD; Priority: Integer; BasePriority: Integer; ContextSwitchCount: ULONG; State: Longint; WaitReason: Longint; End; PSYSTEM_PROCESS_INFORMATION = ^SYSTEM_PROCESS_INFORMATION; SYSTEM_PROCESS_INFORMATION = packed record. NextOffset: ULONG; ThreadCount: ULONG; Reserved1: array [0..5] of ULONG; CreateTime: FILETIME; UserTime: FILETIME; KernelTime: FILETIME; ModuleNameLength: WORD; ModuleNameMaxLength: WORD; ModuleName: PWideChar; BasePriority: ULONG; ProcessID: ULONG; InheritedFromUniqueProcessID: ULONG; HandleCount: ULONG; Reserved2 : array[0..1] of ULONG; PeakVirtualSize : ULONG; VirtualSize : ULONG; PageFaultCount : ULONG; PeakWorkingSetSize : ULONG; WorkingSetSize : ULONG; QuotaPeakPagedPoolUsage : ULONG; QuotaPagedPoolUsage : ULONG; QuotaPeakNonPagedPoolUsage : ULONG; QuotaNonPagedPoolUsage : ULONG; PageFileUsage : ULONG; PeakPageFileUsage : ULONG; PrivatePageCount : ULONG; ReadOperationCount : LARGE_INTEGER; WriteOperationCount : LARGE_INTEGER; OtherOperationCount : LARGE_INTEGER; ReadTransferCount : LARGE_INTEGER; WriteTransferCount : LARGE_INTEGER; OtherTransferCount : LARGE_INTEGER; ThreadInfo: array [0..0] of SYSTEM_THREADS; End; PSYSTEM_HANDLE_INFORMATION = ^SYSTEM_HANDLE_INFORMATION; SYSTEM_HANDLE_INFORMATION = packed record. ProcessId: DWORD; ObjectTypeNumber: Byte; Flags: Byte; Handle: Word; PObject: Pointer; GrantedAccess: DWORD; End; PSYSTEM_HANDLE_INFORMATION_EX = ^SYSTEM_HANDLE_INFORMATION_EX; SYSTEM_HANDLE_INFORMATION_EX = packed record. NumberOfHandles: dword; Information: array [0..0] of SYSTEM_HANDLE_INFORMATION; End; PFILE_NAME_INFORMATION = ^FILE_NAME_INFORMATION; FILE_NAME_INFORMATION = packed record. FileNameLength: ULONG; FileName: array [0..MAX_PATH - 1] of WideChar; End; PUNICODE_STRING = ^TUNICODE_STRING; TUNICODE_STRING = packed record. Length : WORD; MaximumLength : WORD; Buffer : array [0..MAX_PATH - 1] of WideChar; End; POBJECT_NAME_INFORMATION = ^TOBJECT_NAME_INFORMATION; TOBJECT_NAME_INFORMATION = packed record. Name : TUNICODE_STRING; End; PIO_STATUS_BLOCK = ^IO_STATUS_BLOCK; IO_STATUS_BLOCK = packed record. Status: NT_STATUS; Information: DWORD; End; PGetFileNameThreadParam = ^TGetFileNameThreadParam; TGetFileNameThreadParam = packed record. HFile: THandle; Data: array [0..MAX_PATH - 1] of Char; Status: NT_STATUS; End; Const. STATUS_SUCCESS = NT_STATUS($00000000); STATUS_INVALID_INFO_CLASS = NT_STATUS($C0000003); STATUS_INFO_LENGTH_MISMATCH = NT_STATUS($C0000004); STATUS_INVALID_DEVICE_REQUEST = NT_STATUS($C0000010); ObjectNameInformation = 1; FileDirectoryInformation = 1; FileNameInformation = 9; SystemProcessesAndThreadsInformation = 5; SystemHandleInformation = 16; Function ZwQuerySystemInformation(ASystemInformationClass: DWORD; ASystemInformation: Pointer; ASystemInformationLength: DWORD; AReturnLength: PDWORD): NT_STATUS; stdcall; external 'ntdll.dll'; Function NtQueryInformationFile(FileHandle: THandle; IoStatusBlock: PIO_STATUS_BLOCK; FileInformation: Pointer; Length: DWORD; FileInformationClass: DWORD): NT_STATUS; Stdcall; external 'ntdll.dll'; Function NtQueryObject(ObjectHandle: THandle; ObjectInformationClass: DWORD; ObjectInformation: Pointer; ObjectInformationLength: ULONG; ReturnLength: PDWORD): NT_STATUS; stdcall; external 'ntdll.dll'; Function GetLongPathNameA(lpszShortPath, lpszLongPath: PChar; CchBuffer: DWORD): DWORD; stdcall; external kernel32; Procedure TForm15.Button1Click(Sender: TObject); Begin. ShowLockedProcess(''); End; Procedure TForm15.ShowLockedProcess(FileName: String); Function GetInfoTable(ATableType: DWORD): Pointer; Var. DwSize: DWORD; PPtr: Pointer; NtStatus: NT_STATUS; Begin. Result := nil; DwSize := WORD(-1); GetMem(pPtr, dwSize); NtStatus := ZwQuerySystemInformation(ATableType, pPtr, dwSize, nil); While ntStatus = STATUS_INFO_LENGTH_MISMATCH do. Begin. DwSize := dwSize * 2; ReallocMem(pPtr, dwSize); NtStatus := ZwQuerySystemInformation(ATableType, pPtr, dwSize, nil); End; If ntStatus = STATUS_SUCCESS then. Result := pPtr. Else. FreeMem(pPtr); End; Function GetFileNameThread(lpParameters: Pointer): DWORD; stdcall; Var. FileNameInfo: FILE_NAME_INFORMATION; ObjectNameInfo: TOBJECT_NAME_INFORMATION; IoStatusBlock: IO_STATUS_BLOCK; PThreadParam: TGetFileNameThreadParam; DwReturn: DWORD; Begin. ZeroMemory(@FileNameInfo, SizeOf(FILE_NAME_INFORMATION)); PThreadParam := PGetFileNameThreadParam(lpParameters)^; Result := NtQueryInformationFile(pThreadParam.hFile, @IoStatusBlock, @FileNameInfo, MAX_PATH * 2, FileNameInformation); If Result = STATUS_SUCCESS then. Begin. Result := NtQueryObject(pThreadParam.hFile, ObjectNameInformation, @ObjectNameInfo, MAX_PATH * 2, @dwReturn); If Result = STATUS_SUCCESS then. Begin. PThreadParam.Status := Result; WideCharToMultiByte(CP_ACP, 0, @ObjectNameInfo.Name.Buffer[ObjectNameInfo.Name.MaximumLength - ObjectNameInfo.Name.Length], ObjectNameInfo.Name.Length, @pThreadParam.Data[0], MAX_PATH, nil, nil); End. Else. Begin. PThreadParam.Status := STATUS_SUCCESS; Result := STATUS_SUCCESS; WideCharToMultiByte(CP_ACP, 0, @FileNameInfo.FileName[0], IoStatusBlock.Information, @pThreadParam.Data[0], MAX_PATH, nil, nil); End; End; PGetFileNameThreadParam(lpParameters)^ := pThreadParam; ExitThread(Result); End; Function GetFileNameFromHandle(hFile: THandle): String; Var. LpExitCode: DWORD; PThreadParam: TGetFileNameThreadParam; HThread: THandle; Begin. Result := ''; ZeroMemory(@pThreadParam, SizeOf(TGetFileNameThreadParam)); PThreadParam.hFile := hFile; HThread := CreateThread(nil, 0, @GetFileNameThread, @pThreadParam, 0, PDWORD(nil)^); If hThread <> 0 then. Try. Case WaitForSingleObject(hThread, 100) of. WAIT_OBJECT_0: Begin. GetExitCodeThread(hThread, lpExitCode); If lpExitCode = STATUS_SUCCESS then. Result := pThreadParam.Data; End; WAIT_TIMEOUT: TerminateThread(hThread, 0); End; Finally. CloseHandle(hThread); End; End; Function SetDebugPriv: Boolean; Var. Token: THandle; Tkp: TTokenPrivileges; Begin. Result := false; If OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Token) then. Begin. If LookupPrivilegeValue(nil, PChar('SeDebugPrivilege'), Tkp.Privileges[0].Luid) then. Begin. Tkp.PrivilegeCount := 1; Tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; Result := AdjustTokenPrivileges(Token, False, Tkp, 0, PTokenPrivileges(nil)^, PDWord(nil)^); End; End; End; Type. DriveQueryData = record. DiskLabel: String; DiskDosQuery: String; DosQueryLen: Integer; End; Var. HFile, hProcess: THandle; PHandleInfo: PSYSTEM_HANDLE_INFORMATION_EX; I, Drive: Integer; ObjectTypeNumber: Byte; FileDirectory, FilePath, ProcessName: String; SystemInformation, TempSI: PSYSTEM_PROCESS_INFORMATION; DosDevices: array [0..25] of DriveQueryData; LongFileName, TmpFileName: String; Begin. SetLength(LongFileName, MAX_PATH); GetLongPathNameA(PChar(FileName), @LongFileName[1], MAX_PATH); For Drive := 0 to 25 do. Begin. DosDevices[Drive].DiskLabel := Chr(Drive + Ord('a')) + ':'; SetLength(DosDevices[Drive].DiskDosQuery, MAXCHAR); ZeroMemory(@DosDevices[Drive].DiskDosQuery[1], MAXCHAR); QueryDosDevice(PChar(DosDevices[Drive].DiskLabel), @DosDevices[Drive].DiskDosQuery[1], MAXCHAR); DosDevices[Drive].DosQueryLen := Length(PChar(DosDevices[Drive].DiskDosQuery)); SetLength(DosDevices[Drive].DiskDosQuery, DosDevices[Drive].DosQueryLen); End; ObjectTypeNumber := 0; SetDebugPriv; HFile := CreateFile('NUL', GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0); If hFile = INVALID_HANDLE_VALUE then RaiseLastOSError; Try. PHandleInfo := GetInfoTable(SystemHandleInformation); If pHandleInfo = nil then RaiseLastOSError; Try. For I := 0 to pHandleInfo^.NumberOfHandles - 1 do. If pHandleInfo^.Information[I].Handle = hFile then. If pHandleInfo^.Information[I].ProcessId = GetCurrentProcessId then. Begin. ObjectTypeNumber := pHandleInfo^.Information[I].ObjectTypeNumber; Break; End; Finally. FreeMem(pHandleInfo); End; Finally. CloseHandle(hFile); End; SystemInformation := GetInfoTable(SystemProcessesAndThreadsInformation); If SystemInformation <> nil then. Try. PHandleInfo := GetInfoTable(SystemHandleInformation); If pHandleInfo <> nil then. Try. ProgressBar1.Position := 0; ProgressBar1.Max := pHandleInfo^.NumberOfHandles; For I := 0 to pHandleInfo^.NumberOfHandles - 1 do. Begin. If pHandleInfo^.Information[I].ObjectTypeNumber = ObjectTypeNumber then. Begin. HProcess := OpenProcess(PROCESS_DUP_HANDLE, True, PHandleInfo^.Information[I].ProcessId); If hProcess > 0 then. Try. If DuplicateHandle(hProcess, pHandleInfo^.Information[I].Handle, GetCurrentProcess, @hFile, 0, False, DUPLICATE_SAME_ACCESS) then. Try. If Application.Terminated then Exit; FilePath := GetFileNameFromHandle(hFile); If FilePath <> '' then. Begin. FileDirectory := ''; For Drive := 0 to 25 do. If DosDevices[Drive].DosQueryLen > 0 then. If Copy(FilePath, 1, DosDevices[Drive].DosQueryLen) = DosDevices[Drive].DiskDosQuery then. Begin. FileDirectory := DosDevices[Drive].DiskLabel; Delete(FilePath, 1, DosDevices[Drive].DosQueryLen); Break; End; If FileDirectory = '' then Continue; TempSI := SystemInformation; Repeat. If TempSI^.ProcessID = PHandleInfo^.Information[I].ProcessId then. Begin. ProcessName := TempSI^.ModuleName; Break; End; TempSI := Pointer(DWORD(TempSI) + TempSI^.NextOffset); Until TempSI^.NextOffset = 0; SetLength(TmpFileName, MAX_PATH); GetLongPathNameA(PChar(FileDirectory + FilePath), @TmpFileName[1], MAX_PATH); Memo1.Lines.Add(ProcessName + ': ' + TmpFileName); End; Finally. CloseHandle(hFile); End; Finally. CloseHandle(hProcess); End; End; ProgressBar1.Position := ProgressBar1.Position + 1; Application.ProcessMessages; End; Finally. FreeMem(pHandleInfo); End; Finally. FreeMem(SystemInformation); End; ShowMessage('All handles found.'); End; End.

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

Автор: Rouse_

©Drkb::02122.

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

GetSystemDefaultLangID.

GetSystemDefaultLCID.

GetLocaleInfo.

Как узнать какое окно закрывает форму.

Как узнать какое окно закрывает форму

Code: //Find windows that may cover another window. Var. HW: HWnd; R: TRect; Begin. Hw := Handle; While IsWindow(hw) Do Begin. Hw := GetWindow( hw, GW_HWNDPREV ); If IsWindowVisible(hw) and not IsIconic( hw ) Then Begin. ... use GetWindowRect( hw, r ) to get candidate windows. Rect and check if it intersects the forms BoundsRects via. IntersectRect. End; End; End;

©Drkb::00513.

Как узнать количество CD в системе?

Code: Function GetNumberOfCDDrives: Byte; Var. Drivemap, mask: DWORD; I: integer; Root: string; Begin. Result := 0; Root := 'A:\'; Drivemap := GetLogicalDrives; Mask := 1; For i := 1 to 32 do. Begin. If (mask and drivemap) <> 0 then. If GetDriveType(PChar(root)) = DRIVE_CDROM then. Begin. Inc(Result); End; Mask := mask shl 1; Inc(root[1]); End; End; Procedure TForm1.Button1Click(Sender: TObject); Begin. Label1.Caption := IntToStr(GetNumCDDrives); End;

Как узнать имя пользователя

Code: Function GetUserFromWindows: string; Var. UserName : string; UserNameLen : Dword; Begin. UserNameLen := 255; SetLength(userName, UserNameLen); If GetUserName(PChar(UserName), UserNameLen) then. Result := Copy(UserName,1,UserNameLen - 1). Else. Result := ''; End;

©Drkb::01730.

Как узнать путь к программе, известно ее имя.

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

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Uses. TlHelp32; Function GetExeFilePath(ExeFileName: String): String; Var. HSnapshot, hSnapshot2: THandle; Proc: TProcessEntry32; M: TModuleEntry32; Begin. Result := ''; HSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0); Try. Proc.dwSize := Sizeof(proc); If Process32First(hSnapshot, proc) then. Repeat. If AnsiSameText(proc.szExeFile, ExeFileName) then. Begin. HSnapshot2 := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, Proc.th32ProcessID); Try. M.dwSize := SizeOf(TModuleEntry32); If Module32First(hSnapshot2, m) then. Begin. Result := m.szExePath; Exit; End; Finally. CloseHandle(hSnapshot2); End; End; Until not Process32Next(hSnapshot, proc); Finally. CloseHandle(hSnapshot); End; End;

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

Автор: Rouse_, P.O.D.

©Drkb::02121.

Как узнать о нажатии NON-MENU клавиши в момент когда меню показано

Создайте обработчик сообщения WM_MENUCHAR.

Вывод даты в нужном формате

Code: Function CheckDateFormat(SDate: string): string; Var. IDateChar: string; X, y: integer; Begin. IDateChar := '.,\/'; For y := 1 to length(IDateChar) do. Begin. X := pos(IDateChar[y], SDate); While x > 0 do. Begin. Delete(SDate, x, 1); Insert('-', SDate, x); X := pos(IDateChar[y], SDate); End; End; CheckDateFormat := SDate; End; Function DateEncode(SDate:string):longint; Var. Year, month, day: longint; Wy, wm, wd: longint; Dummy: TDateTime; Check: integer; Begin. DateEncode := -1; SDate := CheckDateFormat(SDate); Val(Copy(SDate, 1, pos('-', SDate) - 1), day, check); Delete(Sdate, 1, pos('-', SDate)); Val(Copy(SDate, 1, pos('-', SDate) - 1), month, check); Delete(SDate, 1, pos('-', SDate)); Val(SDate, year, check); Wy := year; Wm := month; Wd := day; Try. Dummy := EncodeDate(wy, wm, wd); Except. Year := 0; Month := 0; Day := 0; End; DateEncode := (year * 10000) + (month * 100) + day; End;

©Drkb::00201.

Формат даты.

У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.

Как узнать что MIDI форма изменила статус?

Code: Private. Procedure WMSize( Var msg: TWMSize ); Message WM_SIZE; ... Procedure TChildForm.WMSize( Var msg: TWMSize ); Begin. Inherited; If msg.SizeType = SIZE_MINIMIZED Then. ... End;

©Drkb::00503.

Как узнать что форма потеряла фокус?

Code: Application.OnDeactivate.

Как формировать документ в формате Word?

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

Приступим к решению задачи. Как было сказано выше, Word является COM-сервером и может управляться внешними программами. Для этого Word предоставляет три объекта, через которые можно получить доступ к внутренним объектам Word`а и документов. Эти объекты - Word.Application, Word.Document и Word.Basic. Ко всем остальным объектам (текст, таблицы, кнопки, меню и др.) доступ возможен только через них.

Чтобы реализовать все эти возможности Word`а и для удобства своей работы мне пришлось разработать динамическую библиотеку процедур и функций, которую можно было использовать в различных своих приложениях для формирования и печати выходных документов. Зачем нужна такая библиотека, почему бы не вставлять программный код непосредственно в программу? Здесь причина в универсальности и гибкости использования библиотеки. Поэтому все ниже описанные коды легко могут быть оформлены в виде библиотеки для того, чтобы вы могли использовать ее непосредственно в своих приложениях, не теряя зря времени.

Чтобы почувствовать эффективность использования объектов Word, для начала попробуем написать несколько функций, которые позволят запустить Word, создать документ, изменить документ (записать текст), сохранить документ и закрыть Word. Для создания объекта и его использования применяем переменную W типа variant и библиотеку ComObj.

Рассмотрим следующий фрагмент кода:

Code: Uses ComObj; Var W:variant; Function CreateWord:boolean; Begin. CreateWord:=true; Try. W:=CreateOleObject('Word.Application'); Except. CreateWord:=false; End; End;

Как у Комбобокса сделать BorderStyle := bsNone?

Code: Procedure TForm1.FormCreate(Sender: TObject); {©Drkb v.3(2007): www.drkb.ru}. Begin. SetWindowRgn( ComboBox1.Handle, CreateRectRgn(2, 2, ComboBox1.Width - 2, ComboBox1.Height - 2), True); End;

Автор: Smike.

©Drkb::01159.

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

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). ComboBox1: TComboBox; Procedure FormCreate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Function NewComboProc(wnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM):integer; stdcall; Var. R,r1:TRect; Begin. Case uMsg of. WM_PAINT: begin. GetWindowRect(wnd,r); SetWindowRgn(wnd,CreateRectRgn(2, 2, r.Right-r.Left - 2, r.Bottom-r.Top - 2), True); End; WM_CTLCOLORLISTBOX: Begin. GetWindowRect(wnd,r); GetWindowRect(lParam,r1); If (r.Left=r1.Left) and (r.Right=r1.Right) then. Begin. InflateRect(r1,-2,0); SetWindowPos(lParam,0,r.Left+2,r.Bottom-2,r1.Right-r1.Left,r1.Bottom-r1.Top,SWP_NOZORDER); End. End; End; Result:=CallWindowProc(Pointer(GetWindowLong(wnd,GWL_USERDATA)),wnd,uMsg,wParam,lParam); End; Procedure TForm1.FormCreate(Sender: TObject); Begin. SetWindowLong(ComboBox1.Handle,GWL_USERDATA,SetWindowLong(ComboBox1.Handle, GWL_WNDPROC, LPARAM(@NewComboProc))). End; End.

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

Автор: Krid.

Канва для метафайлов

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

Как мне в Delphi использовать возвращаемый THandle для получения или создания канвы (Canvas) для рисования?

Содержание.

Работа с ресурсами без TResourceSteram.
Работа с Bluetooth в Delphi.
Работа с КАЗАХСКИМИ ШРИФТАМИ.
Работа с системным логом событий.
Работа с WinInet, Демо получения HTML кода страницы.
Разработка Internet-приложений с использованием Borland Delphi и Kylix.
Разработка системного сервиса.
Размер Bitmap.
Разное.
Расширенный Label для отображения имени файла.
Распределенные информационные системы и базы данных.
Data segment too large error.
Технология DataSnap (статья).
Delphi 2005 Patch.
Delphi 7 and FastNet Components.
Delphi ActiveForms и Web Modules (intranet).
Delphi и Windows API для защиты секретов.
Рисование линий, Как в Paint.
Deploying Midas.
Detect if a USB device is connected or disconnected?
DFM -->TXT, TXT --> DFM.
DOC ---> HTML.
Does Delphi have an equivalent to the Visual Basic SendKeys function?
Does Delphi have an equivalent for the VB function DoEvents?
Does Kylix support ODBC?
Does Kylix support Postgres?
Drag and Drop TImage.
Общие вопросы.
Duplicate Resources Error.
Какой из генераторов отчетов самый быстрый?
Как редактировать группы и пользователей.
Как временно отключить перерисовку окна?
Как добавить в диалог TOpenDialog свой CheckBox.
Как добавить функции картографирования в приложение.
Как глобально перехватить нажатие кнопки PrintScreen?
Как добовлять в ListView полноцветные иконки?
Как вшить иконку в мою прогу?, с нуля.
Как распечатать decision grid?
Как выделить файлы в Проводнике?
Как вызвать диалог 'Найти файлы и паки' проводника?
Как вызвать диалог свойств файла?
Как быть, если таблица содержит столбцы, количество строк в которых разное?
Как зарегистрировать свою команду в контекстном меню проводника?
Как заполнить форму и отправить на сервер?
Как заставить системное меню выпасть в указанном месте?
Как заставить форму находиться всегда позади всех окон.
Как заставить ORACLE анализировать все таблицы?
Как извлечь "Сводку" свойств файла?
Как изменить положение таблицы на листе (подвинуть влево, вправо, вверх, вниз)?
Как корректно определить изменения в оборудовании PlugNPlay?
Как использовать в UDF функциях GetDate() и NewID().
Как обрезать форму по рисунку?
Как найти позицию текстового курсора в пикселях?
Как напечатать документ с предварительной настройкой принтера?
Как очистить очередь печати принтера?
Как определение нажатия определенной клавиши во время загрузки приложения?
Как определить формат изображения, загруженного в TMemoryStream?
Как можно узнать что было изменениие, Наприме сдвиг мыши или нажатие клавиши.
Как прочитать базу данных с Досовским шрифтом.
Как получить длинное имя файла или каталога, зная короткое имя?
Как получить инфу о сервисе в ХР?
Как поменять цвет Неаdеr'а в TListView.
Как поменять установки на case-sensitive у сервера.
Как послать файл на принтер?
Как поставить свой формат в TDateTimePicker?
Как по PID процесса узнать CMDLINE?, то есть командную строку.
Как отбрасывать тень от текста.
Как отключать стили XP для отдельных контролов?
Как сделать форму активной, Форма находится в DLL.
Как создать вычисляемые поля во время исполнения программы.
Как сохранить иконку в файл имея её хендл?
Как спрятать и отключить кнопку "Пуск"?
Как узнать размер файла в интернете?
Как узнать все открытые дескрипторы файлов?
Как узнать какое окно закрывает форму.
Как узнать путь к программе, известно ее имя.
Как узнать что MIDI форма изменила статус?
Как у Комбобокса сделать BorderStyle := bsNone?